packages feed

goatee (empty) → 0.1.0

raw patch · 32 files changed

+7147/−0 lines, 32 filesdep +HUnitdep +basedep +containerssetup-changed

Dependencies added: HUnit, base, containers, goatee, mtl, parsec, template-haskell, test-framework, test-framework-hunit

Files

+ LICENSE 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.hs view
@@ -0,0 +1,19 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++import Distribution.Simple+main = defaultMain
+ goatee.cabal view
@@ -0,0 +1,94 @@+name: goatee+version: 0.1.0+synopsis: A monadic take on a 2,500-year-old board game - library.+category: Game+license: AGPL-3+license-file: LICENSE+copyright: Copyright 2014 Bryan Gardiner+author: Bryan Gardiner <bog@khumba.net>+maintainer: Bryan Gardiner <bog@khumba.net>+homepage: http://khumba.net/projects/goatee+bug-reports: https://savannah.nongnu.org/projects/goatee/+tested-with: GHC+cabal-version: >=1.8+build-type: Simple+data-files: LICENSE+description:+    Goatee is a Go library and game editor, written in Haskell.  It provides a GUI+    for recording, studying, and editing game records.  Underneath this is a+    portable library for manipulating SGF files, to build UIs and tools.+    .+    Goatee, the library and GUI, aims to be full-featured, supporting all of the SGF+    spec and allowing for full customization of the game records you create.+    Currently it is in an alpha stage, supporting basic game viewing and editing.+    .+    This package is the shared library.++source-repository head+    type: git+    location: git://git.savannah.gnu.org/goatee.git++library+    build-depends:+        base >= 4 && < 5,+        containers >= 0.4 && < 0.6,+        mtl >= 2.1 && < 2.3,+        parsec >= 3.1 && < 3.2,+        template-haskell >= 2.7 && < 2.9+    exposed-modules:+        Game.Goatee.App+        Game.Goatee.Common+        Game.Goatee.Sgf.Board+        Game.Goatee.Sgf.Monad+        Game.Goatee.Sgf.Parser+        Game.Goatee.Sgf.Property+        Game.Goatee.Sgf.Property.Parser+        Game.Goatee.Sgf.Renderer+        Game.Goatee.Sgf.Renderer.Tree+        Game.Goatee.Sgf.Tree+        Game.Goatee.Sgf.Types+    extensions:+        ExistentialQuantification+        FlexibleContexts+        FlexibleInstances+        FunctionalDependencies+        MultiParamTypeClasses+        UndecidableInstances+    ghc-options: -W -fwarn-incomplete-patterns+    hs-source-dirs: src+    other-modules:+        Game.Goatee.Sgf.Property.Base+        Game.Goatee.Sgf.Property.Info+        Game.Goatee.Sgf.Property.Renderer+        Game.Goatee.Sgf.Property.Value+        Paths_goatee++test-suite test-goatee+    build-depends:+        base >= 4 && < 5,+        containers >= 0.4 && < 0.6,+        goatee,+        HUnit >= 1.2 && < 1.3,+        mtl >= 2.1 && < 2.3,+        parsec >= 3.1 && < 3.2,+        test-framework >= 0.6 && < 0.9,+        test-framework-hunit >= 0.2 && < 0.4+    ghc-options: -W -fwarn-incomplete-patterns+    hs-source-dirs: tests+    main-is: Test.hs+    other-modules:+        Game.Goatee.CommonTest+        Game.Goatee.Sgf.BoardTest+        Game.Goatee.Sgf.MonadTest+        Game.Goatee.Sgf.ParserTest+        Game.Goatee.Sgf.ParserTestUtils+        Game.Goatee.Sgf.Property.ParserTest+        Game.Goatee.Sgf.PropertyTest+        Game.Goatee.Sgf.RoundTripTest+        Game.Goatee.Sgf.TestInstances+        Game.Goatee.Sgf.TestUtils+        Game.Goatee.Sgf.TreeTest+        Game.Goatee.Sgf.TypesTest+        Game.Goatee.Test.Common+        Test+    type: exitcode-stdio-1.0
+ src/Game/Goatee/App.hs view
@@ -0,0 +1,40 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Properties of Goatee the application.+module Game.Goatee.App (+  applicationName,+  applicationCopyright,+  applicationWebsite,+  applicationAuthors,+  ) where++-- | A string containing the name of this application, @\"Goatee\"@.+applicationName :: String+applicationName = "Goatee"++-- | A user-presentable copyright message.+applicationCopyright :: String+applicationCopyright = "Copyright 2014 Bryan Gardiner"++-- | The home page for Goatee on the web.+applicationWebsite :: String+applicationWebsite = "http://khumba.net/projects/goatee"++-- | A list of contributors to Goatee.+applicationAuthors :: [String]+applicationAuthors = ["Bryan Gardiner <bog@khumba.net>"]
+ src/Game/Goatee/Common.hs view
@@ -0,0 +1,160 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Common utilities used throughout the project.+module Game.Goatee.Common (+  listDeleteIndex,+  listReplace,+  listUpdate,+  fromLeft,+  fromRight,+  onLeft,+  onRight,+  andEithers,+  for,+  mapTuple,+  whenMaybe,+  cond,+  if',+  andM,+  forIndexM_,+  whileM,+  whileM',+  doWhileM,+  Seq(..),+  ) where++import Control.Arrow ((***))+import Control.Monad (forM_, join, when)+import Data.Either (partitionEithers)+import Data.Monoid (Monoid, mempty, mappend)++-- | Drops the element at an index from a list.  If the index is out of bounds+-- then the list is returned unmodified.+listDeleteIndex :: Int -> [a] -> [a]+listDeleteIndex index list = take index list ++ drop (index + 1) list++-- | @listReplace old new list@ replaces all occurrences of @old@ with @new@ in+-- @list@.+listReplace :: Eq a => a -> a -> [a] -> [a]+listReplace from to = map $ replace from to+  where replace from to x = if x == from then to else x++-- | Modifies the element at a specific index in a list.+listUpdate :: Show a => (a -> a) -> Int -> [a] -> [a]+listUpdate fn ix xs = listSet' ix xs+  where listSet' 0 (x':xs') = fn x':xs'+        listSet' ix' (x':xs') = x':listSet' (ix' - 1) xs'+        listSet' _ _ = error ("Cannot update index " ++ show ix +++                              " of list " ++ show xs ++ ".")++-- | Extracts a left value from an 'Either'.+fromLeft :: Either a b -> a+fromLeft (Left a) = a+fromLeft _ = error "fromLeft given a Right."++-- | Extracts a right value from an 'Either'.+fromRight :: Either a b -> b+fromRight (Right b) = b+fromRight _ = error "fromRight given a Left."++-- | Transforms the left value of an 'Either', leaving a right value alone.+onLeft :: (a -> c) -> Either a b -> Either c b+f `onLeft` e = case e of+  Left x -> Left $ f x+  Right y -> Right y++-- | Transforms the right value of an 'Either', leaving a left value alone.+-- This is just 'fmap', but looks nicer when used beside 'onLeft'.+onRight :: (b -> c) -> Either a b -> Either a c+onRight = fmap++-- | If any item is a 'Left', then the list of 'Left's is returned, otherwise+-- the list of 'Right's is returned.+andEithers :: [Either a b] -> Either [a] [b]+andEithers xs = let (as, bs) = partitionEithers xs+                in if not $ null as then Left as else Right bs++-- | @for@ is @flip map@.+for :: [a] -> (a -> b) -> [b]+for = flip map++-- | Transforms both values in a homogeneous tuple.+mapTuple :: (a -> b) -> (a, a) -> (b, b)+mapTuple = join (***)++-- | Executes the monadic function if a 'Maybe' contains a value.+whenMaybe :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenMaybe = flip $ maybe (return ())++-- | Finds the first tuple whose first element is true, and returns its second+-- element.  If all of the first values are false, then the first argument to+-- @cond@ is returned instead.+cond :: a -> [(Bool, a)] -> a+cond fallback ((test, body):rest) = if test then body else cond fallback rest+cond fallback _ = fallback++-- | A function form of @if@ that takes its test last.+if' :: a -> a -> Bool -> a+if' true false test = if test then true else false++-- | 'and' in a monad.  Executes the actions in the list in order.  If any+-- action returns false then the remaining actions are skipped and the result is+-- false.  Otherwise all actions returned true, and the result is true.  An+-- empty list returns true.+andM :: Monad m => [m Bool] -> m Bool+andM (x:xs) = x >>= if' (andM xs) (return False)+andM _ = return True++-- | 'forM_' that also passes in the index of each element.+forIndexM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m ()+forIndexM_ list = forM_ (zip [0..] list) . uncurry++-- | @whileM test body@ repeatedly evaluates @test@ until it returns false.+-- Every time @test@ returns true, @body@ is executed once.+whileM :: Monad m => m Bool -> m () -> m ()+whileM test body = do x <- test+                      when x $ body >> whileM test body++-- | @whileM' test body@ repeatedly evaluates @test@ until it returns 'Nothing'.+-- Every time it returns a 'Just', that value is passed to @body@ and the result+-- is executed.+whileM' :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()+whileM' test body = do x <- test+                       case x of+                         Nothing -> return ()+                         Just y -> body y >> whileM' test body++-- | @doWhileM init body@ repeatedly calls @body@ with @init@.  As long as+-- @body@ returns a @Right@ value, it is re-executed with the returned value.+-- When it returns a @Left@ value, the loop stops and the value is returned.+doWhileM :: Monad m => a -> (a -> m (Either b a)) -> m b+doWhileM init body = do+  value <- body init+  case value of+    Right next -> doWhileM next body+    Left end -> return end++-- | This sequences @()@-valued monadic actions as a monoid.  If @m@ is some+-- monad, then @Seq m@ is a monoid where 'mempty' does nothing and 'mappend'+-- sequences actions via '>>'.+newtype Seq m = Seq (m ())++instance Monad m => Monoid (Seq m) where+  mempty = Seq $ return ()++  (Seq x) `mappend` (Seq y) = Seq (x >> y)
+ src/Game/Goatee/Sgf/Board.hs view
@@ -0,0 +1,792 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Data structures that wrap and provide a higher-level interface to the SGF+-- game tree, including a zipper that navigates the tree and provides the+-- current board state.+module Game.Goatee.Sgf.Board (+  RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode,+  gameInfoToProperties,+  BoardState(..), boardWidth, boardHeight,+  CoordState(..), rootBoardState, boardCoordState, mapBoardCoords,+  isValidMove, isCurrentValidMove,+  Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren,+  cursorChildCount, cursorChildPlayingAt, cursorProperties,+  cursorModifyNode,+  cursorVariations,+  colorToMove,+  ) where++import Control.Monad (unless, when)+import Control.Monad.Writer (execWriter, tell)+import Data.List (find, intercalate, nub)+import Data.Maybe (fromMaybe, isJust, isNothing)+import qualified Data.Set as Set+import Game.Goatee.Common+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Tree+import Game.Goatee.Sgf.Types++-- TODO Stop using errors everywhere, they're not testable.++-- | Properties that are specified in the root nodes of game trees.+data RootInfo = RootInfo { rootInfoWidth :: Int+                         , rootInfoHeight :: Int+                         , rootInfoVariationMode :: VariationMode+                         } deriving (Eq, Show)++-- | Properties that are specified in game info nodes.+data GameInfo = GameInfo { gameInfoRootInfo :: RootInfo++                         , gameInfoBlackName :: Maybe String+                         , gameInfoBlackTeamName :: Maybe String+                         , gameInfoBlackRank :: Maybe String++                         , gameInfoWhiteName :: Maybe String+                         , gameInfoWhiteTeamName :: Maybe String+                         , gameInfoWhiteRank :: Maybe String++                         , gameInfoRuleset :: Maybe Ruleset+                         , gameInfoBasicTimeSeconds :: Maybe Rational+                         , gameInfoOvertime :: Maybe String+                         , gameInfoResult :: Maybe GameResult++                         , gameInfoGameName :: Maybe String+                         , gameInfoGameComment :: Maybe String+                         , gameInfoOpeningComment :: Maybe String++                         , gameInfoEvent :: Maybe String+                         , gameInfoRound :: Maybe String+                         , gameInfoPlace :: Maybe String+                         , gameInfoDatesPlayed :: Maybe String+                         , gameInfoSource :: Maybe String+                         , gameInfoCopyright :: Maybe String++                         , gameInfoAnnotatorName :: Maybe String+                         , gameInfoEntererName :: Maybe String+                         } deriving (Show)++-- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data.+emptyGameInfo :: RootInfo -> GameInfo+emptyGameInfo rootInfo =+  GameInfo { gameInfoRootInfo = rootInfo++           , gameInfoBlackName = Nothing+           , gameInfoBlackTeamName = Nothing+           , gameInfoBlackRank = Nothing++           , gameInfoWhiteName = Nothing+           , gameInfoWhiteTeamName = Nothing+           , gameInfoWhiteRank = Nothing++           , gameInfoRuleset = Nothing+           , gameInfoBasicTimeSeconds = Nothing+           , gameInfoOvertime = Nothing+           , gameInfoResult = Nothing++           , gameInfoGameName = Nothing+           , gameInfoGameComment = Nothing+           , gameInfoOpeningComment = Nothing++           , gameInfoEvent = Nothing+           , gameInfoRound = Nothing+           , gameInfoPlace = Nothing+           , gameInfoDatesPlayed = Nothing+           , gameInfoSource = Nothing+           , gameInfoCopyright = Nothing++           , gameInfoAnnotatorName = Nothing+           , gameInfoEntererName = Nothing+           }++-- | Returns whether a node contains any game info properties.+internalIsGameInfoNode :: Node -> Bool+internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties++-- | Converts a 'GameInfo' into a list of 'Property's that can be used to+-- reconstruct the 'GameInfo'.+gameInfoToProperties :: GameInfo -> [Property]+gameInfoToProperties info = execWriter $ do+  copy (PB . toSimpleText) gameInfoBlackName+  copy (BT . toSimpleText) gameInfoBlackTeamName+  copy (BR . toSimpleText) gameInfoBlackRank++  copy (PW . toSimpleText) gameInfoWhiteName+  copy (WT . toSimpleText) gameInfoWhiteTeamName+  copy (WR . toSimpleText) gameInfoWhiteRank++  copy RU gameInfoRuleset+  copy TM gameInfoBasicTimeSeconds+  copy (OT . toSimpleText) gameInfoOvertime+  copy RE gameInfoResult++  copy (GN . toSimpleText) gameInfoGameName+  copy (GC . toSimpleText) gameInfoGameComment+  copy (ON . toSimpleText) gameInfoOpeningComment++  copy (EV . toSimpleText) gameInfoEvent+  copy (RO . toSimpleText) gameInfoRound+  copy (PC . toSimpleText) gameInfoPlace+  copy (DT . toSimpleText) gameInfoDatesPlayed+  copy (SO . toSimpleText) gameInfoSource+  copy (CP . toSimpleText) gameInfoCopyright++  copy (AN . toSimpleText) gameInfoAnnotatorName+  copy (US . toSimpleText) gameInfoEntererName+  where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x]++-- | An object that corresponds to a node in some game tree, and represents the+-- state of the game at that node, including board position, player turn and+-- captures, and also board annotations.+data BoardState = BoardState {+  boardCoordStates :: [[CoordState]]+  -- ^ The state of individual points on the board.  Stored in row-major order.+  -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer+  -- 'boardCoordState').+  , boardHasInvisible :: Bool+    -- ^ Whether any of the board's 'CoordState's are invisible.  This is an+    -- optimization to make it more efficient to set the board to "all visible."+  , boardHasDimmed :: Bool+    -- ^ Whether any of the board's 'CoordState's are dimmed.  This is an+    -- optimization to make it more efficient to clear all dimming from the+    -- board.+  , boardArrows :: ArrowList+  , boardLines :: LineList+  , boardLabels :: LabelList+  , boardMoveNumber :: Integer+  , boardPlayerTurn :: Color+  , boardBlackCaptures :: Int+  , boardWhiteCaptures :: Int+  , boardGameInfo :: GameInfo+  }++instance Show BoardState where+  show board = concat $ execWriter $ do+    tell ["Board: (Move ", show (boardMoveNumber board),+          ", ", show (boardPlayerTurn board), "'s turn, B:",+          show (boardBlackCaptures board), ", W:",+          show (boardWhiteCaptures board), ")\n"]+    tell [intercalate "\n" $ flip map (boardCoordStates board) $+          \row -> unwords $ map show row]++    let arrows = boardArrows board+    let lines = boardLines board+    let labels = boardLabels board+    unless (null arrows) $ tell ["\nArrows: ", show arrows]+    unless (null lines) $ tell ["\nLines: ", show lines]+    unless (null labels) $ tell ["\nLabels: ", show labels]++-- | Returns the width of the board, in stones.+boardWidth :: BoardState -> Int+boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo++-- | Returns the height of the board, in stones.+boardHeight :: BoardState -> Int+boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo++-- | Used by 'BoardState' to represent the state of a single point on the board.+-- Records whether a stone is present, as well as annotations and visibility+-- properties.+data CoordState = CoordState { coordStar :: Bool+                               -- ^ Whether this point is a star point.+                             , coordStone :: Maybe Color+                             , coordMark :: Maybe Mark+                             , coordVisible :: Bool+                             , coordDimmed :: Bool+                             }++instance Show CoordState where+  show c = if not $ coordVisible c+           then "--"+           else let stoneChar = case coordStone c of+                      Nothing -> if coordStar c then '*' else '\''+                      Just Black -> 'X'+                      Just White -> 'O'+                    markChar = case coordMark c of+                      Nothing -> ' '+                      Just MarkCircle -> 'o'+                      Just MarkSquare -> 's'+                      Just MarkTriangle -> 'v'+                      Just MarkX -> 'x'+                      Just MarkSelected -> '!'+                in [stoneChar, markChar]++-- | Creates a 'BoardState' for an empty board of the given width and height.+emptyBoardState :: Int -> Int -> BoardState+emptyBoardState width height =+  BoardState { boardCoordStates = coords+             , boardHasInvisible = False+             , boardHasDimmed = False+             , boardArrows = []+             , boardLines = []+             , boardLabels = []+             , boardMoveNumber = 0+             , boardPlayerTurn = Black+             , boardBlackCaptures = 0+             , boardWhiteCaptures = 0+             , boardGameInfo = emptyGameInfo rootInfo+             }+  where rootInfo = RootInfo { rootInfoWidth = width+                            , rootInfoHeight = height+                            , rootInfoVariationMode = defaultVariationMode+                            }+        emptyCoord = CoordState { coordStar = False+                                , coordStone = Nothing+                                , coordMark = Nothing+                                , coordVisible = True+                                , coordDimmed = False+                                }+        starCoord = emptyCoord { coordStar = True }+        isStarPoint' = isStarPoint width height+        coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord)+                                [0..width-1])+                     [0..height-1]++rootBoardState :: Node -> BoardState+rootBoardState rootNode =+  foldr applyProperty+        (emptyBoardState width height)+        (nodeProperties rootNode)+  where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $+                          findProperty propertySZ rootNode++-- | Returns the 'CoordState' for a coordinate on a board.+boardCoordState :: Coord -> BoardState -> CoordState+boardCoordState (x, y) board = boardCoordStates board !! y !! x++-- | Maps a function over each 'CoordState' in a 'BoardState', returning a+-- list-of-lists with the function's values.  The function is called like @fn y+-- x coordState@.+mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]]+mapBoardCoords fn board =+  zipWith applyRow [0..] $ boardCoordStates board+  where applyRow y = zipWith (fn y) [0..]++-- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a+-- 'BoardState'.+updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState+updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo ->+  gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo }++-- | Applies a function to update the 'GameInfo' of a 'BoardState'.+updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState+updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board }++-- | Performs necessary updates to a 'BoardState' between nodes in the tree.+-- Clears marks.+boardChild :: BoardState -> BoardState+boardChild board =+  board { boardCoordStates = map (map clearMark) $ boardCoordStates board+        , boardArrows = []+        , boardLines = []+        , boardLabels = []+        }+  where clearMark coord = case coordMark coord of+          Nothing -> coord+          Just _ -> coord { coordMark = Nothing }++-- | Sets all points on a board to be visible (if given true) or invisible (if+-- given false).+setBoardVisible :: Bool -> BoardState -> BoardState+setBoardVisible visible board =+  if visible+  then if boardHasInvisible board+       then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board+                  , boardHasInvisible = False+                  }+       else board+  else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board+             , boardHasInvisible = True+             }+  where setVisible vis coord = coord { coordVisible = vis }++-- | Resets all points on a board not to be dimmed.+clearBoardDimmed :: BoardState -> BoardState+clearBoardDimmed board =+  if boardHasDimmed board+  then board { boardCoordStates = map (map clearDim) $ boardCoordStates board+             , boardHasDimmed = False+             }+  else board+  where clearDim coord = coord { coordDimmed = False }++-- |> isStarPoint width height x y+--+-- Returns whether @(x, y)@ is a known star point on a board of the given width+-- and height.+isStarPoint :: Int -> Int -> Int -> Int -> Bool+isStarPoint width height+  | width == 9 && height == 9 = isStarPoint9+  | width == 13 && height == 13 = isStarPoint13+  | width == 19 && height == 19 = isStarPoint19+  | otherwise = const $ const False++isStarPoint' :: [Int] -> Int -> Int -> Bool+isStarPoint' ixs x y = x `elem` ixs && y `elem` ixs++isStarPoint9, isStarPoint13, isStarPoint19 :: Int -> Int -> Bool+isStarPoint9 = isStarPoint' [2, 4, 6]+isStarPoint13 = isStarPoint' [3, 6, 9]+isStarPoint19 = isStarPoint' [3, 9, 15]++-- | Applies a property to a 'BoardState'.  This function covers all properties+-- that modify 'BoardState's, including making moves, adding markup, and so on.+applyProperty :: Property -> BoardState -> BoardState++applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of+  Nothing -> board  -- Pass.+  Just xy -> getApplyMoveResult board $+             applyMove playTheDarnMoveGoParams Black xy board+applyProperty KO board = board+applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum }+applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of+  Nothing -> board  -- Pass.+  Just xy -> getApplyMoveResult board $+             applyMove playTheDarnMoveGoParams White xy board++applyProperty (AB coords) board =+  updateCoordStates' (\state -> state { coordStone = Just Black }) coords board+applyProperty (AW coords) board =+  updateCoordStates' (\state -> state { coordStone = Just White }) coords board+applyProperty (AE coords) board =+  updateCoordStates' (\state -> state { coordStone = Nothing }) coords board+applyProperty (PL color) board = board { boardPlayerTurn = color }++applyProperty (C {}) board = board+applyProperty (DM {}) board = board+applyProperty (GB {}) board = board+applyProperty (GW {}) board = board+applyProperty (HO {}) board = board+applyProperty (N {}) board = board+applyProperty (UC {}) board = board+applyProperty (V {}) board = board++applyProperty (BM {}) board = board+applyProperty (DO {}) board = board+applyProperty (IT {}) board = board+applyProperty (TE {}) board = board++applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board }+applyProperty (CR coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board+applyProperty (DD coords) board =+  let coords' = expandCoordList coords+      board' = clearBoardDimmed board+  in if null coords'+     then board'+     else updateCoordStates (\state -> state { coordDimmed = True }) coords'+          board { boardHasDimmed = True }+applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board }+applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board }+applyProperty (MA coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board+applyProperty (SL coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board+applyProperty (SQ coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board+applyProperty (TR coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board++applyProperty (AP {}) board = board+applyProperty (CA {}) board = board+applyProperty (FF {}) board = board+applyProperty (GM {}) board = board+applyProperty (ST variationMode) board =+  updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board+applyProperty (SZ {}) board = board++applyProperty (AN str) board =+  updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just $ fromSimpleText str })+                  board+applyProperty (BR str) board =+  updateBoardInfo (\info -> info { gameInfoBlackRank = Just $ fromSimpleText str })+                  board+applyProperty (BT str) board =+  updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just $ fromSimpleText str })+                  board+applyProperty (CP str) board =+  updateBoardInfo (\info -> info { gameInfoCopyright = Just $ fromSimpleText str })+                  board+applyProperty (DT str) board =+  updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just $ fromSimpleText str })+                  board+applyProperty (EV str) board =+  updateBoardInfo (\info -> info { gameInfoEvent = Just $ fromSimpleText str })+                  board+applyProperty (GC str) board =+  updateBoardInfo (\info -> info { gameInfoGameComment = Just $ fromSimpleText str })+                  board+applyProperty (GN str) board =+  updateBoardInfo (\info -> info { gameInfoGameName = Just $ fromSimpleText str })+                  board+applyProperty (ON str) board =+  updateBoardInfo (\info -> info { gameInfoOpeningComment = Just $ fromSimpleText str })+                  board+applyProperty (OT str) board =+  updateBoardInfo (\info -> info { gameInfoOvertime = Just $ fromSimpleText str })+                  board+applyProperty (PB str) board =+  updateBoardInfo (\info -> info { gameInfoBlackName = Just $ fromSimpleText str })+                  board+applyProperty (PC str) board =+  updateBoardInfo (\info -> info { gameInfoPlace = Just $ fromSimpleText str })+                  board+applyProperty (PW str) board =+  updateBoardInfo (\info -> info { gameInfoWhiteName = Just $ fromSimpleText str })+                  board+applyProperty (RE result) board =+  updateBoardInfo (\info -> info { gameInfoResult = Just result })+                  board+applyProperty (RO str) board =+  updateBoardInfo (\info -> info { gameInfoRound = Just $ fromSimpleText str })+                  board+applyProperty (RU ruleset) board =+  updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset })+                  board+applyProperty (SO str) board =+  updateBoardInfo (\info -> info { gameInfoSource = Just $ fromSimpleText str })+                  board+applyProperty (TM seconds) board =+  updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds })+                  board+applyProperty (US str) board =+  updateBoardInfo (\info -> info { gameInfoEntererName = Just $ fromSimpleText str })+                  board+applyProperty (WR str) board =+  updateBoardInfo (\info -> info { gameInfoWhiteRank = Just $ fromSimpleText str })+                  board+applyProperty (WT str) board =+  updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just $ fromSimpleText str })+                  board++applyProperty (VW coords) board =+  let coords' = expandCoordList coords+  in if null coords'+     then setBoardVisible True board+     else updateCoordStates (\state -> state { coordVisible = True }) coords' $+          setBoardVisible False board++applyProperty (UnknownProperty {}) board = board++applyProperties :: Node -> BoardState -> BoardState+applyProperties node board = foldr applyProperty board (nodeProperties node)++-- | Applies the transformation function to all of a board's coordinates+-- referred to by the 'CoordList'.+updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState+updateCoordStates fn coords board =+  board { boardCoordStates = foldr applyFn (boardCoordStates board) coords }+  where applyFn (x, y) = listUpdate (updateRow x) y+        updateRow = listUpdate fn++updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState+updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords)++-- | Updates properties of a 'BoardState' given that the player of the given+-- color has just made a move.  Increments the move number and updates the+-- player turn.+updateBoardForMove :: Color -> BoardState -> BoardState+updateBoardForMove movedPlayer board =+  board { boardMoveNumber = boardMoveNumber board + 1+        , boardPlayerTurn = cnot movedPlayer+        }++-- | A structure that configures how 'applyMove' should handle moves that are+-- normally illegal in Go.+data ApplyMoveParams = ApplyMoveParams { allowSuicide :: Bool+                                         -- ^ If false, suicide will cause 'applyMove' to return+                                         -- 'ApplyMoveSuicideError'.  If true, suicide will kill the+                                         -- friendly group and give points to the opponent.+                                       , allowOverwrite :: Bool+                                         -- ^ If false, playing on an occupied point will cause+                                         -- 'applyMove' to return 'ApplyMoveOverwriteError' with the+                                         -- color of the stone occupying the point.  If true,+                                         -- playing on an occupied point will overwrite the point+                                         -- (the previous stone vanishes), then capture rules are+                                         -- applied as normal.+                                       } deriving (Show)++-- | As an argument to 'applyMove', causes illegal moves to be treated as+-- errors.+standardGoMoveParams :: ApplyMoveParams+standardGoMoveParams = ApplyMoveParams { allowSuicide = False+                                       , allowOverwrite = False+                                       }++-- | As an argument to 'applyMove', causes illegal moves to be played+-- unconditionally.+playTheDarnMoveGoParams :: ApplyMoveParams+playTheDarnMoveGoParams = ApplyMoveParams { allowSuicide = True+                                          , allowOverwrite = True+                                          }++-- | The possible results from 'applyMove'.+data ApplyMoveResult = ApplyMoveOk BoardState+                       -- ^ The move was accepted; playing it resulted in the+                       -- given board without capture.+                     | ApplyMoveCapture BoardState Color Int+                       -- ^ The move was accepted; playing it resulted in the+                       -- given board with a capture.  The specified side gained+                       -- the number of points given.+                     | ApplyMoveSuicideError+                       -- ^ Playing the move would result in suicide, which is+                       -- forbidden.+                     | ApplyMoveOverwriteError Color+                       -- ^ There is already a stone of the specified color on+                       -- the target point, and overwriting is forbidden.++-- | If the 'ApplyMoveResult' represents a successful move, then the resulting+-- 'BoardState' is returned, otherwise, the default 'BoardState' given is+-- returned.+getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState+getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result++getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState+getApplyMoveResult' result = case result of+  ApplyMoveOk board -> Just board+  ApplyMoveCapture board color points -> Just $ case color of+    Black -> board { boardBlackCaptures = boardBlackCaptures board + points }+    White -> board { boardWhiteCaptures = boardWhiteCaptures board + points }+  ApplyMoveSuicideError -> Nothing+  ApplyMoveOverwriteError _ -> Nothing++-- | Internal data structure, only for move application code.  Represents a+-- group of stones.+data ApplyMoveGroup = ApplyMoveGroup { applyMoveGroupOrigin :: Coord+                                     , applyMoveGroupCoords :: [Coord]+                                     , applyMoveGroupLiberties :: Int+                                     } deriving (Show)++-- | Places a stone of a color at a point on a board, and runs move validation+-- and capturing logic according to the given parameters.  Returns whether the+-- move was successful, and the result if so.+applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult+applyMove params color xy board =+  let currentStone = coordStone $ boardCoordState xy board+  in case currentStone of+    Just color -> if allowOverwrite params+                  then moveResult+                  else ApplyMoveOverwriteError color+    Nothing -> moveResult+  where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color })+                                          [xy]+                                          board+        (boardWithCaptures, points) = foldr (maybeCapture $ cnot color)+                                            (boardWithMove, 0)+                                            (adjacentPoints boardWithMove xy)+        playedGroup = computeGroup boardWithCaptures xy+        moveResult+          | applyMoveGroupLiberties playedGroup == 0 =+            if points /= 0+            then error "Cannot commit suicide and capture at the same time."+            else if allowSuicide params+                 then let (boardWithSuicide, suicidePoints) =+                            applyMoveCapture (boardWithCaptures, 0) playedGroup+                      in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints+                 else ApplyMoveSuicideError+          | points /= 0 = ApplyMoveCapture boardWithCaptures color points+          | otherwise = ApplyMoveOk boardWithCaptures++-- | Capture if there is a liberty-less group of a color at a point on+-- a board.  Removes captured stones from the board and accumulates+-- points for captured stones.+maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int)+maybeCapture color xy result@(board, _) =+  if coordStone (boardCoordState xy board) /= Just color+  then result+  else let group = computeGroup board xy+       in if applyMoveGroupLiberties group /= 0+          then result+          else applyMoveCapture result group++computeGroup :: BoardState -> Coord -> ApplyMoveGroup+computeGroup board xy =+  if isNothing (coordStone $ boardCoordState xy board)+  then error "computeGroup called on an empty point."+  else let groupCoords = bucketFill board xy+       in ApplyMoveGroup { applyMoveGroupOrigin = xy+                         , applyMoveGroupCoords = groupCoords+                         , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords+                         }++applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)+applyMoveCapture (board, points) group =+  (updateCoordStates (\state -> state { coordStone = Nothing })+                     (applyMoveGroupCoords group)+                     board,+   points + length (applyMoveGroupCoords group))++-- | Returns a list of the four coordinates that are adjacent to the+-- given coordinate on the board, excluding coordinates that are out+-- of bounds.+adjacentPoints :: BoardState -> Coord -> [Coord]+adjacentPoints board (x, y) = execWriter $ do+  when (x > 0) $ tell [(x - 1, y)]+  when (y > 0) $ tell [(x, y - 1)]+  when (x < boardWidth board - 1) $ tell [(x + 1, y)]+  when (y < boardHeight board - 1) $ tell [(x, y + 1)]++-- | Takes a list of coordinates that comprise a group (e.g. a list+-- returned from 'bucketFill') and returns the number of liberties the+-- group has.  Does no error checking to ensure that the list refers+-- to a single or maximal group.+getLibertiesOfGroup :: BoardState -> [Coord] -> Int+getLibertiesOfGroup board groupCoords =+  length $ nub $ concatMap findLiberties groupCoords+  where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board)+                                  (adjacentPoints board xy)++-- | Expands a single coordinate on a board into a list of all the+-- coordinates connected to it by some continuous path of stones of+-- the same color (or empty spaces).+bucketFill :: BoardState -> Coord -> [Coord]+bucketFill board xy0 = bucketFill' Set.empty [xy0]+  where bucketFill' known [] = Set.toList known+        bucketFill' known (xy:xys) =+          if Set.member xy known+          then bucketFill' known xys+          else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board)+                                (adjacentPoints board xy)+               in bucketFill' (Set.insert xy known) (new ++ xys)+        stone0 = coordStone $ boardCoordState xy0 board++-- | Returns whether it is legal to place a stone of the given color at a point+-- on a board.  Accepts out-of-bound coordinates and returns false.+isValidMove :: BoardState -> Color -> Coord -> Bool+-- TODO Should out-of-bound coordinates be accepted?+isValidMove board color coord@(x, y) =+  let w = boardWidth board+      h = boardHeight board+  in x >= 0 && y >= 0 && x < w && y < h &&+     isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board)++-- | Returns whether it is legal for the current player to place a stone at a+-- point on a board.  Accepts out-of-bound coordinates and returns false.+isCurrentValidMove :: BoardState -> Coord -> Bool+isCurrentValidMove board = isValidMove board (boardPlayerTurn board)++-- | A pointer to a node in a game tree that also holds information+-- about the current state of the game at that node.+data Cursor = Cursor { cursorParent :: Maybe Cursor+                       -- ^ The cursor for the node above this cursor's node in+                       -- the game tree.  The node of the parent cursor is the+                       -- parent of the cursor's node.+                       --+                       -- This is @Nothing@ iff the cursor's node has no parent.+                     , cursorChildIndex :: Int+                       -- ^ The index of this cursor's node in its parent's+                       -- child list.  When the cursor's node has no parent,+                       -- the value in this field is not specified.+                     , cursorNode :: Node+                       -- ^ The game tree node about which the cursor stores+                       -- information.+                     , cursorBoard :: BoardState+                       -- ^ The complete board state for the current node.+                     } deriving (Show) -- TODO Better Show Cursor instance.++-- | Returns a cursor for a root node.+rootCursor :: Node -> Cursor+rootCursor node =+  Cursor { cursorParent = Nothing+         , cursorChildIndex = -1+         , cursorNode = node+         , cursorBoard = rootBoardState node+         }++cursorRoot :: Cursor -> Cursor+cursorRoot cursor = case cursorParent cursor of+  Nothing -> cursor+  Just parent -> cursorRoot parent++cursorChild :: Cursor -> Int -> Cursor+cursorChild cursor index =+  Cursor { cursorParent = Just cursor+         , cursorChildIndex = index+         , cursorNode = child+         , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor+         }+  -- TODO Better handling or messaging for out-of-bounds:+  where child = (!! index) $ nodeChildren $ cursorNode cursor++cursorChildren :: Cursor -> [Cursor]+cursorChildren cursor =+  let board = boardChild $ cursorBoard cursor+  in map (\(index, child) -> Cursor { cursorParent = Just cursor+                                    , cursorChildIndex = index+                                    , cursorNode = child+                                    , cursorBoard = applyProperties child board+                                    })+     $ zip [0..]+     $ nodeChildren+     $ cursorNode cursor++cursorChildCount :: Cursor -> Int+cursorChildCount = length . nodeChildren . cursorNode++cursorChildPlayingAt :: Coord -> Cursor -> Maybe Cursor+cursorChildPlayingAt coord cursor =+  let children = cursorChildren cursor+      color = boardPlayerTurn $ cursorBoard cursor+      hasMove = elem $ colorToMove color coord+  in find (hasMove . nodeProperties . cursorNode) children++-- | This is simply @'nodeProperties' . 'cursorNode'@.+cursorProperties :: Cursor -> [Property]+cursorProperties = nodeProperties . cursorNode++cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor+cursorModifyNode fn cursor =+  let node' = fn $ cursorNode cursor+  in case cursorParent cursor of+    Nothing -> rootCursor node'+    Just parentCursor ->+      let index = cursorChildIndex cursor+          parentCursor' = cursorModifyNode+                          (\parentNode ->+                            parentNode { nodeChildren = listUpdate (const node')+                                                        index+                                                        (nodeChildren parentNode)+                                       })+                          parentCursor+      in cursorChild parentCursor' index++-- | Returns the variations to display for a cursor.  The returned list contains+-- the location and color of 'B' and 'W' properties in variation nodes.+-- Variation nodes are either children of the current node, or siblings of the+-- current node, depending on the variation mode source.+cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)]+cursorVariations source cursor =+  case source of+    ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor+    ShowCurrentVariations ->+      case cursorParent cursor of+        Nothing -> []+        Just parent -> collectPlays $ listDeleteIndex (cursorChildIndex cursor) $+                       nodeChildren $ cursorNode parent+  where collectPlays :: [Node] -> [(Coord, Color)]+        collectPlays = concatMap collectPlays'+        collectPlays' = concatMap collectPlays'' . nodeProperties+        collectPlays'' prop = case prop of+          B (Just xy) -> [(xy, Black)]+          W (Just xy) -> [(xy, White)]+          _ -> []++colorToMove :: Color -> Coord -> Property+colorToMove color coord =+  case color of+    Black -> B $ Just coord+    White -> W $ Just coord
+ src/Game/Goatee/Sgf/Monad.hs view
@@ -0,0 +1,690 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | A monad for working with game trees.+module Game.Goatee.Sgf.Monad (+  -- * The Go monad+  GoT, GoM,+  runGoT, runGo,+  evalGoT, evalGo,+  execGoT, execGo,+  getCursor, getCoordState,+  -- * Navigation+  Step(..), goUp, goDown, goToRoot, goToGameInfoNode,+  -- * Remembering positions+  pushPosition, popPosition, dropPosition,+  -- * Properties+  getProperties,+  modifyProperties,+  getProperty,+  getPropertyValue,+  putProperty,+  deleteProperty,+  modifyProperty,+  modifyPropertyValue,+  modifyPropertyString,+  modifyPropertyCoords,+  modifyGameInfo,+  modifyVariationMode,+  getMark,+  modifyMark,+  -- * Children+  addChild,+  -- * Event handling+  Event, on, fire,+  -- * Events+  childAddedEvent, ChildAddedHandler,+  gameInfoChangedEvent, GameInfoChangedHandler,+  navigationEvent, NavigationHandler,+  propertiesModifiedEvent, PropertiesModifiedHandler,+  variationModeChangedEvent, VariationModeChangedHandler,+  ) where++import Control.Applicative ((<$>), Applicative ((<*>), pure))+import Control.Monad (ap, liftM, when)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)+import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer)+import qualified Control.Monad.State as State+import Control.Monad.State (StateT)+import Data.List (delete, find, mapAccumL, nub)+import Data.Maybe (fromMaybe, isJust, isNothing)+import Game.Goatee.Common+import Game.Goatee.Sgf.Board+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Tree hiding (addChild)+import Game.Goatee.Sgf.Types++-- | The internal state of a Go monad transformer.  @go@ is the type of+-- Go monad or transformer (instance of 'GoMonad').+data GoState go = GoState { stateCursor :: Cursor+                            -- ^ The current position in the game tree.+                          , statePathStack :: PathStack+                            -- ^ The current path stack.++                          -- Event handlers.+                          , stateChildAddedHandlers :: [ChildAddedHandler go]+                            -- ^ Handlers for 'childAddedEvent'.+                          , stateGameInfoChangedHandlers :: [GameInfoChangedHandler go]+                            -- ^ Handlers for 'gameInfoChangedEvent'.+                          , stateNavigationHandlers :: [NavigationHandler go]+                            -- ^ Handlers for 'navigationEvent'.+                          , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go]+                            -- ^ Handlers for 'propertiesModifiedEvent'.+                          , stateVariationModeChangedHandlers :: [VariationModeChangedHandler go]+                            -- ^ Handlers for 'variationModeChangedEvent'.+                          }++-- | A path stack is a record of previous places visited in a game tree.  It is+-- encoded a list of paths (steps) to each previous memorized position.+--+-- The positions saved in calls to 'pushPosition' correspond to entries in the+-- outer list here, with the first sublist representing the last call.  The+-- sublist contains the steps in order that will trace the path back to the+-- saved position.+type PathStack = [[Step]]++-- | A simplified constructor function for 'GoState'.+initialState :: Cursor -> GoState m+initialState cursor = GoState { stateCursor = cursor+                              , statePathStack = []+                              , stateChildAddedHandlers = []+                              , stateGameInfoChangedHandlers = []+                              , stateNavigationHandlers = []+                              , statePropertiesModifiedHandlers = []+                              , stateVariationModeChangedHandlers = []+                              }++-- | A single step along a game tree.  Either up or down.+data Step = GoUp Int+            -- ^ Represents a step up from a child with the given index.+          | GoDown Int+            -- ^ Represents a step down to the child with the given index.+          deriving (Eq, Show)++-- | Reverses a step, such that taking a step then it's reverse will leave you+-- where you started.+reverseStep :: Step -> Step+reverseStep step = case step of+  GoUp index -> GoDown index+  GoDown index -> GoUp index++-- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'.+takeStep :: Step -> Cursor -> Cursor+takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $+                           cursorParent cursor+takeStep (GoDown index) cursor = cursorChild cursor index++-- | Internal function.  Takes a 'Step' in the Go monad.  Updates the path stack+-- accordingly.+takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m ()+takeStepM step = case step of+  GoUp _ -> goUp'+  GoDown index -> goDown' index++-- | A monad (transformer) for navigating and mutating 'Cursor's, and+-- remembering previous locations.  See 'GoT' and 'GoM'.+--+-- The monad supports handlers for events raised during actions it takes, such+-- as navigating through the tree and modifying nodes.+class Monad go => MonadGo go where+  -- | Returns the current cursor.+  getCursor :: go Cursor++  -- | Returns the 'CoordState' at the given point.+  getCoordState :: Coord -> go CoordState+  getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor++  -- | Navigates up the tree.  It must be valid to do so, otherwise 'fail' is+  -- called.  Fires a 'navigationEvent' after moving.+  goUp :: go ()++  -- | Navigates down the tree to the child with the given index.  The child+  -- must exist.  Fires a 'navigationEvent' after moving.+  goDown :: Int -> go ()++  -- | Navigates up to the root of the tree.  Fires 'navigationEvent's for each+  -- step.+  goToRoot :: go ()++  -- | Navigates up the tree to the node containing game info properties, if+  -- any.  Returns true if a game info node was found.+  goToGameInfoNode :: Bool+                      -- ^ When no node with game info is found, then if false,+                      -- return to the original node, otherwise finish at the+                      -- root node.+                   -> go Bool++  -- | Pushes the current location in the game tree onto an internal position+  -- stack, such that 'popPosition' is capable of navigating back to the same+  -- position, even if the game tree has been modified (though the old position+  -- must still exist in the tree to return to it).+  pushPosition :: go ()++  -- | Returns to the last position pushed onto the internal position stack via+  -- 'pushPosition'.  This action must be balanced by a 'pushPosition'.+  popPosition :: go ()++  -- | Drops the last position pushed onto the internal stack by 'pushPosition'+  -- off of the stack.  This action must be balanced by a 'pushPosition'.+  dropPosition :: go ()++  -- | Returns the set of properties on the current node.+  getProperties :: go [Property]+  getProperties = liftM cursorProperties getCursor++  -- | Modifies the set of properties on the current node.+  --+  -- The given function must end on the same node on which it started.+  modifyProperties :: ([Property] -> go [Property]) -> go ()++  -- | Searches for a property on the current node, returning it if found.+  getProperty :: Descriptor d => d -> go (Maybe Property)++  -- | Searches for a valued property on the current node, returning its value+  -- if found.+  getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v)+  getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor++  -- | Sets a property on the current node, replacing an existing property with+  -- the same name, if one exists.+  putProperty :: Property -> go ()+  putProperty property = modifyProperty (propertyInfo property) $ const $ Just property++  -- | Deletes a property from the current node, if it's set.+  --+  -- Note that although a 'Property' is a 'Descriptor', giving a valued+  -- @Property@ here will not cause deletion to match on the value of the+  -- property.  That is, the following code will result in 'Nothing', because+  -- the deletion only cares about the name of the property.+  --+  -- > do putProperty $ PL Black+  -- >    deleteProperty $ PL White+  -- >    getPropertyValue propertyPL+  deleteProperty :: Descriptor d => d -> go ()+  deleteProperty descriptor = modifyProperty descriptor $ const Nothing++  -- | Calls the given function to modify the state of the given property+  -- (descriptor) on the current node.  'Nothing' represents the property not+  -- existing on the node, and a 'Just' marks the property's presence.  This+  -- function does not do any validation to check that the resulting tree state+  -- is valid.+  modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go ()++  -- | Calls the given function to modify the state of the given valued property+  -- (descriptor) on the current node.  'Nothing' represents the property not+  -- existing on the node, and a 'Just' with the property's value marks the+  -- property's presence.  This function does not do any validation to check+  -- that the resulting tree state is valid.+  modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go ()+  modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old ->+    propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old)++  -- | Mutates the string-valued property attached to the current node according+  -- to the given function.  The input string will be empty if the current node+  -- either has the property with an empty value, or doesn't have the property.+  -- Returning an empty string removes the property from the node, if it was+  -- set.+  modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go ()+  modifyPropertyString descriptor fn =+    modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of+      "" -> Nothing+      str -> let sgf = stringToSgf str+                 -- Because stringToSgf might do processing, we have to check+                 -- the conversion back to a string for emptiness.+             in if null $ sgfToString sgf then Nothing else Just sgf++  -- | Mutates the 'CoordList'-valued property attached to the current node+  -- according to the given function.  Conversion between @CoordList@ and+  -- @[Coord]@ is performed automatically.  The input list will be empty if the+  -- current node either has the property with an empty value, or doesn't have+  -- the property.  Returning an empty list removes the property from the node,+  -- if it was set.+  --+  -- Importantly, this might not be specific enough for properties such as 'DD'+  -- and 'VW' where a present, empty list has different semantics from the+  -- property not being present.  In that case, 'modifyPropertyValue' is better.+  modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go ()+  modifyPropertyCoords descriptor fn =+    modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of+      [] -> Nothing+      coords -> Just $ buildCoordList coords++  -- | Mutates the game info for the current path, returning the new info.  If+  -- the current node or one of its ancestors has game info properties, then+  -- that node is modified.  Otherwise, properties are inserted on the root+  -- node.+  modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo++  -- | Sets the game's 'VariationMode' via the 'ST' property on the root node,+  -- then fires a 'variationModeChangedEvent' if the variation mode has changed.+  modifyVariationMode :: (VariationMode -> VariationMode) -> go ()++  -- | Returns the 'Mark' at a point on the current node.+  getMark :: Coord -> go (Maybe Mark)+  getMark = liftM coordMark . getCoordState++  -- | Calls the given function to modify the presence of a 'Mark' on the+  -- current node.+  modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go ()+  modifyMark fn coord = do+    maybeOldMark <- getMark coord+    case (maybeOldMark, fn maybeOldMark) of+      (Just oldMark, Nothing) -> remove oldMark+      (Nothing, Just newMark) -> add newMark+      (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark+      (Just _, Just _) -> return ()+      (Nothing, Nothing) -> return ()+    where remove mark = modifyPropertyCoords (markProperty mark) (delete coord)+          add mark = modifyPropertyCoords (markProperty mark) (coord:)++  -- | Adds a child node to the current node at the given index, shifting all+  -- existing children at and after the index to the right.  The index must in+  -- the range @[0, numberOfChildren]@.  Fires a 'childAddedEvent' after the+  -- child is added.+  addChild :: Int -> Node -> go ()++  -- | Registers a new event handler for a given event type.+  on :: Event go h -> h -> go ()++-- | The regular monad transformer for 'MonadGo'.+newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a }++-- | The regular monad for 'MonadGo'.+type GoM = GoT Identity++instance Monad m => Functor (GoT m) where+  fmap = liftM++instance Monad m => Applicative (GoT m) where+  pure = return+  (<*>) = ap++instance Monad m => Monad (GoT m) where+  return x = GoT $ return x+  m >>= f = GoT $ goState . f =<< goState m+  fail = lift . fail++instance MonadTrans GoT where+  lift = GoT . lift++instance MonadIO m => MonadIO (GoT m) where+  liftIO = lift . liftIO++instance MonadWriter w m => MonadWriter w (GoT m) where+  writer = lift . writer+  tell = lift . tell+  listen = GoT . listen . goState+  pass = GoT . pass . goState++-- | Executes a Go monad transformer on a cursor, returning in the underlying+-- monad a tuple that contains the resulting value and the final cursor.+runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor)+runGoT go cursor = do+  (value, state) <- State.runStateT (goState go) (initialState cursor)+  return (value, stateCursor state)++-- | Executes a Go monad transformer on a cursor, returning in the underlying+-- monad the value in the transformer.+evalGoT :: Monad m => GoT m a -> Cursor -> m a+evalGoT go cursor = liftM fst $ runGoT go cursor++-- | Executes a Go monad transformer on a cursor, returning in the underlying+-- monad the final cursor.+execGoT :: Monad m => GoT m a -> Cursor -> m Cursor+execGoT go cursor = liftM snd $ runGoT go cursor++-- | Runs a Go monad on a cursor.  See 'runGoT'.+runGo :: GoM a -> Cursor -> (a, Cursor)+runGo go = runIdentity . runGoT go++-- | Runs a Go monad on a cursor and returns the value in the monad.+evalGo :: GoM a -> Cursor -> a+evalGo m cursor = fst $ runGo m cursor++-- | Runs a Go monad on a cursor and returns the final cursor.+execGo :: GoM a -> Cursor -> Cursor+execGo m cursor = snd $ runGo m cursor++getState :: Monad m => GoT m (GoState (GoT m))+getState = GoT State.get++putState :: Monad m => GoState (GoT m) -> GoT m ()+putState = GoT . State.put++modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()+modifyState = GoT . State.modify++instance Monad m => MonadGo (GoT m) where+  getCursor = liftM stateCursor getState++  goUp = do+    index <- liftM cursorChildIndex getCursor+    goUp' $ \pathStack -> case pathStack of+      [] -> pathStack+      path:paths -> (GoDown index:path):paths++  goDown index = goDown' index $ \pathStack -> case pathStack of+    [] -> pathStack+    path:paths -> (GoUp index:path):paths++  goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp++  goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode+    where findGameInfoNode = do+            cursor <- getCursor+            if hasGameInfo cursor+              then dropPosition >> return True+              else if isNothing $ cursorParent cursor+                   then do if goToRootIfNotFound then dropPosition else popPosition+                           return False+                   else goUp >> findGameInfoNode+          hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor++  pushPosition = modifyState $ \state ->+    state { statePathStack = []:statePathStack state }++  popPosition = do+    getPathStack >>= \stack -> when (null stack) $+      fail "popPosition: No position to pop from the stack."++    -- Drop each step in the top list of the path stack one at a time, until the+    -- top list is empty.+    whileM' (do path:_ <- getPathStack+                return $ if null path then Nothing else Just $ head path) $+      flip takeStepM $ \((_:steps):paths) -> steps:paths++    -- Finally, drop the empty top of the path stack.+    modifyState $ \state -> case statePathStack state of+      []:rest -> state { statePathStack = rest }+      _ -> error "popPosition: Internal failure, top of path stack is not empty."++  dropPosition = do+    state <- getState+    -- If there are >=2 positions on the path stack, then we can't simply drop+    -- the moves that will return us to the top-of-stack position, because they+    -- may still be needed to return to the second-on-stack position by a+    -- following popPosition.+    case statePathStack state of+      x:y:xs -> putState $ state { statePathStack = (x ++ y):xs }+      _:[] -> putState $ state { statePathStack = [] }+      [] -> fail "dropPosition: No position to drop from the stack."++  modifyProperties fn = do+    oldCursor <- getCursor+    let oldProperties = cursorProperties oldCursor+    newProperties <- fn oldProperties+    modifyState $ \state ->+      state { stateCursor = cursorModifyNode+                            (\node -> node { nodeProperties = newProperties })+                            oldCursor+            }+    fire propertiesModifiedEvent (\f -> f oldProperties newProperties)++    -- The current game info changes when modifying game info properties on the+    -- current node.  I think comparing game info properties should be faster+    -- than comparing 'GameInfo's.+    let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType)+        oldGameInfo = filterToGameInfo oldProperties+        newGameInfo = filterToGameInfo newProperties+    when (newGameInfo /= oldGameInfo) $ do+      newCursor <- getCursor+      fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor)+                                         (boardGameInfo $ cursorBoard newCursor))++  getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties++  modifyProperty descriptor fn = do+    cursor <- getCursor+    let node = cursorNode cursor+        old = findProperty descriptor node+        new = fn old+    when (maybe False (not . propertyPredicate descriptor) new) $+      fail $ "modifyProperty: May not change property type: " +++      show old ++ " -> " ++ show new ++ "."+    case (old, new) of+      (Just _, Nothing) -> modifyProperties $ return . remove descriptor+      (Nothing, Just value') -> modifyProperties $ return . add value'+      (Just value, Just value') | value /= value' ->+        modifyProperties $ return . add value' . remove descriptor+      _ -> return ()+    where remove descriptor = filter (not . propertyPredicate descriptor)+          add value = (value:)++  modifyGameInfo fn = do+    cursor <- getCursor+    let info = boardGameInfo $ cursorBoard cursor+        info' = fn info+    when (gameInfoRootInfo info /= gameInfoRootInfo info') $+      fail "Illegal modification of root info in modifyGameInfo."+    pushPosition+    goToGameInfoNode True+    modifyProperties $ \props ->+      return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props+    popPosition+    return info'++  modifyVariationMode fn = do+    pushPosition+    goToRoot+    modifyPropertyValue propertyST $ \maybeOld ->+      -- If the new variation mode is equal to the old effective variation mode+      -- (effective applying the default if the property isn't present), then+      -- leave the property unchanged.  Otherwise, apply the new variation mode,+      -- deleting the property if the default variation mode is selected.  We+      -- don't delete the property if @maybeOld == Just new == Just+      -- defaultVariationMode@, because we don't want to trigger dirtyness+      -- unnecessarily.+      let old = fromMaybe defaultVariationMode maybeOld+          new = fn old+      in if new == old+         then maybeOld+         else if new == defaultVariationMode+              then Nothing+              else Just new+    popPosition++  addChild index node = do+    cursor <- getCursor+    let childCount = cursorChildCount cursor+    when (index < 0 || index > childCount) $ fail $+      "Monad.addChild: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]."+    let cursor' = cursorModifyNode (addChildAt index node) cursor+    modifyState $ \state ->+      state { stateCursor = cursor'+            , statePathStack = updatePathStackCurrentNode+                               (\step -> case step of+                                   GoUp n -> GoUp $ if n < index then n else n + 1+                                   down@(GoDown _) -> down)+                               (\step -> case step of+                                   up@(GoUp _) -> up+                                   GoDown n -> GoDown $ if n < index then n else n + 1)+                               cursor'+                               (statePathStack state)+            }+    fire childAddedEvent (\f -> f index (cursorChild cursor' index))++  on event handler = modifyState $ addHandler event handler++-- | Takes a step up the game tree, updates the path stack according to the+-- given function, then fires navigation and game info changed events as+-- appropriate.+goUp' :: Monad m => (PathStack -> PathStack) -> GoT m ()+goUp' pathStackFn = do+  state@(GoState { stateCursor = cursor+                 , statePathStack = pathStack+                 }) <- getState+  case cursorParent cursor of+    Nothing -> fail $ "goUp': Can't go up from a root cursor: " ++ show cursor+    Just parent -> do+      let index = cursorChildIndex cursor+      putState state { stateCursor = parent+                     , statePathStack = pathStackFn pathStack+                     }+      fire navigationEvent ($ GoUp index)++      -- The current game info changes when navigating up from a node that has+      -- game info properties.+      when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $+        fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)+                                           (boardGameInfo $ cursorBoard parent))++-- | Takes a step down the game tree, updates the path stack according to the+-- given function, then fires navigation and game info changed events as+-- appropriate.+goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m ()+goDown' index pathStackFn = do+  state@(GoState { stateCursor = cursor+                 , statePathStack = pathStack+                 }) <- getState+  case drop index $ cursorChildren cursor of+    [] -> fail $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor+    child:_ -> do+      putState state { stateCursor = child+                     , statePathStack = pathStackFn pathStack+                     }+      fire navigationEvent ($ GoDown index)++      -- The current game info changes when navigating down to a node that has+      -- game info properties.+      when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $+        fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)+                                           (boardGameInfo $ cursorBoard child))++-- | Returns the current path stack.+getPathStack :: Monad m => GoT m PathStack+getPathStack = liftM statePathStack getState++-- | Maps over a path stack, updating with the given functions all steps that+-- enter and leave the cursor's current node.+updatePathStackCurrentNode :: (Step -> Step)+                           -> (Step -> Step)+                           -> Cursor+                           -> PathStack+                           -> PathStack+updatePathStackCurrentNode _ _ _ [] = []+updatePathStackCurrentNode onEnter onExit cursor0 paths =+  snd $ mapAccumL updatePath (cursor0, []) paths+  where updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [Step])+        updatePath = mapAccumL updateStep+        updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), Step)+        updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step)+        updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step =+          let pathToInitial' = if stepToInitial == step+                               then restToInitial+                               else reverseStep step:pathToInitial+          in ((takeStep step cursor, pathToInitial'),+              if null pathToInitial' then onEnter step else step)++-- | Fires all of the handlers for the given event, using the given function to+-- create a Go action from each of the handlers (normally themselves functions+-- that create Go actions, if they're not just Go actions directly, depending on+-- the event).+fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()+fire event handlerGenerator = do+  state <- getState+  mapM_ handlerGenerator $ eventStateGetter event state++-- | A type of event in the Go monad transformer that can be handled by+-- executing an action.  @go@ is the type of the type of the Go+-- monad/transformer.  @h@ is the type of monad or monadic function which will+-- be used by Go actions that can trigger the event.  For example, a navigation+-- event is characterized by a 'Step' that cannot easily be recovered from the+-- regular monad state, and comparing before-and-after states would be a pain.+-- So @h@ for navigation events is @'Step' -> go ()@; a handler takes a 'Step'+-- and returns a Go action to run as a result.+data Event go h = Event { eventName :: String+                        , eventStateGetter :: GoState go -> [h]+                        , eventStateSetter :: [h] -> GoState go -> GoState go+                        }++instance Show (Event go h) where+  show = eventName++addHandler :: Event go h -> h -> GoState go -> GoState go+addHandler event handler state =+  eventStateSetter event (eventStateGetter event state ++ [handler]) state++-- | An event corresponding to a child node being added to the current node.+childAddedEvent :: Event go (ChildAddedHandler go)+childAddedEvent = Event {+  eventName = "childAddedEvent"+  , eventStateGetter = stateChildAddedHandlers+  , eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers }+  }++-- | A handler for 'childAddedEvent's.+type ChildAddedHandler go = Int -> Cursor -> go ()++-- | An event that is fired when the current game info changes, either by+-- navigating past a node with game info properties, or by modifying the current+-- game info properties.+gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)+gameInfoChangedEvent = Event {+  eventName = "gameInfoChangedEvent"+  , eventStateGetter = stateGameInfoChangedHandlers+  , eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers }+  }++-- | A handler for 'gameInfoChangedEvent's.  It is called with the old game info+-- then the new game info.+type GameInfoChangedHandler go = GameInfo -> GameInfo -> go ()++-- | An event that is fired when a single step up or down in a game tree is+-- made.+navigationEvent :: Event go (NavigationHandler go)+navigationEvent = Event {+  eventName = "navigationEvent"+  , eventStateGetter = stateNavigationHandlers+  , eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers }+  }++-- | A handler for 'navigationEvent's.+--+-- A navigation handler may navigate further, but beware infinite recursion.  A+-- navigation handler must end on the same node on which it started.+type NavigationHandler go = Step -> go ()++-- | An event corresponding to a modification to the properties list of the+-- current node.+propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)+propertiesModifiedEvent = Event {+  eventName = "propertiesModifiedEvent"+  , eventStateGetter = statePropertiesModifiedHandlers+  , eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers }+  }++-- | A handler for 'propertiesModifiedEvent's.  It is called with the old+-- property list then the new property list.+type PropertiesModifiedHandler go = [Property] -> [Property] -> go ()++-- | An event corresponding to a change in the active 'VariationMode'.  This can+-- happen when modifying the 'ST' property, and also when navigating between+-- collections (as they have different root nodes).+variationModeChangedEvent :: Event go (VariationModeChangedHandler go)+variationModeChangedEvent = Event {+  eventName = "variationModeChangedEvent"+  , eventStateGetter = stateVariationModeChangedHandlers+  , eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers }+  }+-- TODO Test that this is fired when moving between root nodes in a collection.+-- For now, since we don't support multiple trees in a collection, we don't need+-- to worry about checking for active variation mode change on navigation.++-- | A handler for 'variationModeChangedEvent's.  It is called with the old+-- variation mode then the new variation mode.+type VariationModeChangedHandler go = VariationMode -> VariationMode -> go ()
+ src/Game/Goatee/Sgf/Parser.hs view
@@ -0,0 +1,113 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | A parser for reading SGF files.+module Game.Goatee.Sgf.Parser (+  parseString,+  parseFile,+  ) where++import Control.Applicative ((<*), (*>))+import Data.Maybe (fromMaybe)+import Game.Goatee.Common+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Tree+import Game.Goatee.Sgf.Types+import Text.ParserCombinators.Parsec (+  (<?>), Parser, char, eof, many, many1, parse, spaces, upper,+  )++-- | Parses a string in SGF format.  Returns an error string if parsing fails.+parseString :: String -> Either String Collection+parseString str = case parse collection "<collection>" str of+  Left err -> Left $ show err+  Right (Collection roots) -> onLeft concatErrors $+                              onRight Collection $+                              andEithers $+                              map processRoot roots+  where processRoot :: Node -> Either String Node+        processRoot = checkFormatVersion . ttToPass++        -- Ensures that we are parsing an SGF version that we understand.+        -- TODO Try to proceed, if it makes sense.+        checkFormatVersion :: Node -> Either String Node+        checkFormatVersion root =+          let version = case findProperty propertyFF root of+                Nothing -> defaultFormatVersion+                Just (FF x) -> x+                x -> error $ "Expected FF or nothing, received " ++ show x ++ "."+          in if version `elem` supportedFormatVersions+             then Right root+             else Left $+                  "Unsupported SGF version " ++ show version ++ ".  Only versions " +++                  show supportedFormatVersions ++ " are supported."++        -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19.+        -- Convert any passes from this format to B[] and W[] in a root node and+        -- its descendents.+        ttToPass :: Node -> Node+        ttToPass root =+          let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $+                                findProperty propertySZ root+          in if width <= 19 && height <= 19+             then ttToPass' width height root+             else root++        -- Convert a node and its descendents.+        ttToPass' width height node =+          node { nodeProperties = map ttToPass'' $ nodeProperties node+               , nodeChildren = map (ttToPass' width height) $ nodeChildren node+               }++        -- Convert a property.+        ttToPass'' prop = case prop of+          B (Just (19, 19)) -> B Nothing+          W (Just (19, 19)) -> W Nothing+          _ -> prop++        concatErrors errs = "The following errors occurred while parsing:" +++                            concatMap ("\n-> " ++) errs++-- | Parses a file in SGF format.  Returns an error string if parsing fails.+parseFile :: String -> IO (Either String Collection)+parseFile = fmap parseString . readFile++collection :: Parser Collection+collection = fmap Collection (spaces *> many (gameTree <* spaces) <* eof)+             <?> "collection"++gameTree :: Parser Node+gameTree = do+  char '('+  nodes <- spaces *> many1 (node <* spaces) <?> "sequence"+  subtrees <- many (gameTree <* spaces) <?> "subtrees"+  char ')'+  let (sequence, [final]) = splitAt (length nodes - 1) nodes+  return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] })+                 (final { nodeChildren = subtrees })+                 sequence++node :: Parser Node+node = fmap (\props -> emptyNode { nodeProperties = props })+       (char ';' *> spaces *> many (property <* spaces)+        <?> "node")++property :: Parser Property+property = do+  name <- many1 upper+  spaces+  propertyValueParser $ descriptorForName name
+ src/Game/Goatee/Sgf/Property.hs view
@@ -0,0 +1,27 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Structures and functions for working with SGF node properties.+module Game.Goatee.Sgf.Property (+  module Game.Goatee.Sgf.Property.Base,+  module Game.Goatee.Sgf.Property.Info,+  PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty,+  ) where++import Game.Goatee.Sgf.Property.Base+import Game.Goatee.Sgf.Property.Info+import Game.Goatee.Sgf.Property.Value
+ src/Game/Goatee/Sgf/Property/Base.hs view
@@ -0,0 +1,314 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Core property-related data types, and some Template Haskell declarations+-- for defining property metadata.+--+-- Import "Game.Goatee.Sgf.Property" rather than importing this module.+module Game.Goatee.Sgf.Property.Base (+  -- * Properties+  Property (..),+  -- * Property metadata+  PropertyType (..),+  Descriptor (..),+  SomeDescriptor (..),+  ValuedDescriptor (..),+  PropertyInfo,+  ValuedPropertyInfo (ValuedPropertyInfo),+  -- * Property declaration+  defProperty, defValuedProperty,+  ) where++import Control.Applicative ((<$))+import Game.Goatee.Sgf.Property.Value (PropertyValueType(..), nonePvt)+import Game.Goatee.Sgf.Renderer+import Game.Goatee.Sgf.Types+import Language.Haskell.TH (+  Info (DataConI), DecsQ, Name, Type (AppT),+  appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName,+  normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP,+  )+import Text.ParserCombinators.Parsec (Parser)++-- | An SGF property that gives a node meaning.+data Property =+  -- Move properties.+    B (Maybe Coord)      -- ^ Black move (nothing iff pass).+  | KO                   -- ^ Execute move unconditionally (even if illegal).+  | MN Integer           -- ^ Assign move number.+  | W (Maybe Coord)      -- ^ White move (nothing iff pass).++  -- Setup properties.+  | AB CoordList         -- ^ Assign black stones.+  | AE CoordList         -- ^ Assign empty stones.+  | AW CoordList         -- ^ Assign white stones.+  | PL Color             -- ^ Player to play.++  -- Node annotation properties.+  | C Text               -- ^ Comment.+  | DM DoubleValue       -- ^ Even position.+  | GB DoubleValue       -- ^ Good for black.+  | GW DoubleValue       -- ^ Good for white.+  | HO DoubleValue       -- ^ Hotspot.+  | N SimpleText         -- ^ Node name.+  | UC DoubleValue       -- ^ Unclear position.+  | V RealValue          -- ^ Node value.++  -- Move annotation properties.+  | BM DoubleValue       -- ^ Bad move.+  | DO                   -- ^ Doubtful move.+  | IT                   -- ^ Interesting move.+  | TE DoubleValue       -- ^ Tesuji.++  -- Markup properties.+  | AR ArrowList         -- ^ Arrows.+  | CR CoordList         -- ^ Mark points with circles.+  | DD CoordList         -- ^ Dim points.+  | LB LabelList         -- ^ Label points with text.+  | LN LineList          -- ^ Lines.+  | MA CoordList         -- ^ Mark points with 'X's.+  | SL CoordList         -- ^ Mark points as selected.+  | SQ CoordList         -- ^ Mark points with squares.+  | TR CoordList         -- ^ Mark points with trianges.++  -- Root properties.+  | AP SimpleText SimpleText -- ^ Application info.+  | CA SimpleText        -- ^ Charset for SimpleText and Text.+  | FF Int               -- ^ File format version.+  | GM Int               -- ^ Game (must be 1 = Go).+  | ST VariationMode     -- ^ Variation display format.+  | SZ Int Int           -- ^ Board size, columns then rows.++  -- Game info properties.+  | AN SimpleText        -- ^ Name of annotator.+  | BR SimpleText        -- ^ Rank of black player.+  | BT SimpleText        -- ^ Name of black team.+  | CP SimpleText        -- ^ Copyright info.+  | DT SimpleText        -- ^ Dates played.+  | EV SimpleText        -- ^ Event name.+  | GC SimpleText        -- ^ Game comment, or background, or summary.+  | GN SimpleText        -- ^ Game name.+  | ON SimpleText        -- ^ Information about the opening.+  | OT SimpleText        -- ^ The method used for overtime.+  | PB SimpleText        -- ^ Name of black player.+  | PC SimpleText        -- ^ Where the game was played.+  | PW SimpleText        -- ^ Name of white player.+  | RE GameResult        -- ^ Result of the game.+  | RO SimpleText        -- ^ Round info.+  | RU Ruleset           -- ^ Ruleset used.+  | SO SimpleText        -- ^ Source of the game.+  | TM RealValue         -- ^ Time limit, in seconds.+  | US SimpleText        -- ^ Name of user or program who entered the game.+  | WR SimpleText        -- ^ Rank of white player.+  | WT SimpleText        -- ^ Name of white team.++  -- Miscellaneous properties.+  | VW CoordList         -- ^ Set viewing region.++  | UnknownProperty String UnknownPropertyValue++  -- TODO Game info, timing, and miscellaneous properties.+  -- Also in functions below.+  deriving (Eq, Show)++-- | The property types that SGF uses to group properties.+data PropertyType = MoveProperty     -- ^ Cannot mix with setup nodes.+                  | SetupProperty    -- ^ Cannot mix with move nodes.+                  | RootProperty     -- ^ May only appear in root nodes.+                  | GameInfoProperty -- ^ At most one on any path.+                  | GeneralProperty  -- ^ May appear anywhere in the game tree.+                  deriving (Eq, Show)++-- | A class for types that contain metadata about a 'Property'.+class Descriptor a where+  -- | Returns the name of the property, as used in SGF files.+  propertyName :: a -> String++  -- | Returns the type of the property, as specified by the SGF spec.+  propertyType :: a -> PropertyType++  -- | Returns whether the value of the given property is inherited from the+  -- lowest ancestor specifying the property, when the property is not set on a+  -- node itself.+  propertyInherited :: a -> Bool++  -- | Returns whether the given property has the type of a descriptor.+  propertyPredicate :: a -> Property -> Bool++  -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property+  -- that takes a point).+  propertyValueParser :: a -> Parser Property++  -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders+  -- to @"[ab]"@).+  propertyValueRenderer :: a -> Property -> Render ()++  -- | A renderer for displaying property values in a UI.  Displays the value in+  -- a human-readable format.+  propertyValueRendererPretty :: a -> Property -> Render ()++data SomeDescriptor = forall a. Descriptor a => SomeDescriptor a++instance Descriptor SomeDescriptor where+  propertyName (SomeDescriptor d) = propertyName d+  propertyType (SomeDescriptor d) = propertyType d+  propertyInherited (SomeDescriptor d) = propertyInherited d+  propertyPredicate (SomeDescriptor d) = propertyPredicate d+  propertyValueParser (SomeDescriptor d) = propertyValueParser d+  propertyValueRenderer (SomeDescriptor d) = propertyValueRenderer d+  propertyValueRendererPretty (SomeDescriptor d) = propertyValueRendererPretty d++-- | A class for 'Descriptor's of 'Property's that also contain values.+class (Descriptor a, Eq v) => ValuedDescriptor a v | a -> v where+  -- | Extracts the value from a property of the given type.  Behaviour is+  -- undefined if the property is not of the given type.+  propertyValue :: a -> Property -> v++  -- | Builds a property from a given value.+  propertyBuilder :: a -> v -> Property++-- | Metadata for a property that does not contain a value.  Corresponds to a+-- single nullary data constructor of 'Property'.+data PropertyInfo = PropertyInfo {+  propertyInfoName :: String+  -- ^ The SGF textual name for the property.+  , propertyInfoInstance :: Property+    -- ^ The single instance of the property.+  , propertyInfoType :: PropertyType+    -- ^ The SGF property type.+  , propertyInfoInherited :: Bool+    -- ^ Whether the property is inherited.+  }++instance Descriptor PropertyInfo where+  propertyName = propertyInfoName+  propertyType = propertyInfoType+  propertyInherited = propertyInfoInherited+  propertyPredicate = (==) . propertyInfoInstance+  propertyValueParser descriptor = propertyInfoInstance descriptor <$ pvtParser nonePvt+  propertyValueRenderer _ _ = pvtRenderer nonePvt ()+  propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt ()++-- | Metadata for a property that contains a value.  Corresponds to a single+-- unary data constructor of 'Property'.+data ValuedPropertyInfo v = ValuedPropertyInfo {+  valuedPropertyInfoName :: String+  -- ^ The SGF textual name for the property (also the name of the data+  -- constructor).+  , valuedPropertyInfoType :: PropertyType+    -- ^ The SGF property type.+  , valuedPropertyInfoInherited :: Bool+    -- ^ Whether the property is inherited.+  , valuedPropertyInfoPredicate :: Property -> Bool+    -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo'+    -- applies.+  , valuedPropertyInfoValueType :: PropertyValueType v+    -- ^ Metadata about the type of the property's value.+  , valuedPropertyInfoValue :: Property -> v+    -- ^ A function that extracts values from properties to which this+    -- 'ValuedPropertyInfo' applies.  It is invalid to call this function with a+    -- different type of property.+  , valuedPropertyInfoBuilder :: v -> Property+    -- ^ A function that builds a property containing a value.+  }++instance Descriptor (ValuedPropertyInfo v) where+  propertyName = valuedPropertyInfoName+  propertyType = valuedPropertyInfoType+  propertyInherited = valuedPropertyInfoInherited+  propertyPredicate = valuedPropertyInfoPredicate+  propertyValueParser descriptor =+    fmap (valuedPropertyInfoBuilder descriptor) $+    pvtParser $+    valuedPropertyInfoValueType descriptor+  propertyValueRenderer descriptor property =+    pvtRenderer (valuedPropertyInfoValueType descriptor) $+    valuedPropertyInfoValue descriptor property+  propertyValueRendererPretty descriptor property =+    pvtRendererPretty (valuedPropertyInfoValueType descriptor) $+    valuedPropertyInfoValue descriptor property++instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where+  propertyValue = valuedPropertyInfoValue+  propertyBuilder = valuedPropertyInfoBuilder++-- | Template Haskell function to declare a property that does not contain a+-- value.+--+-- > $(defProperty "KO" 'MoveProperty False)+--+-- This example declares a @propertyKO :: 'PropertyInfo'@ that is a+-- 'MoveProperty' and is not inherited.+defProperty :: String+               -- ^ The SGF textual name of the property.+            -> Name+               -- ^ The name of the 'PropertyType'.+            -> Bool+               -- ^ Whether the property is inherited.+            -> DecsQ+defProperty name propType inherited = do+  let propName = mkName name+      varName = mkName $ "property" ++ name+  foo <- newName "foo"+  sequence [+    sigD varName $ conT $ mkName "PropertyInfo",+    valD (varP varName)+         (normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |])+         []+    ]++-- | Template Haskell function to declare a property that contains a value.+--+-- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter)+--+-- This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@+-- that is a 'MoveProperty' and is not inherited.  The value type is+-- automatically inferred.+defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ+defValuedProperty name propType inherited valueType = do+  let propName = mkName name+      varName = mkName $ "property" ++ name+  foo <- newName "foo"+  bar <- newName "bar"+  DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName+  sequence [+    sigD varName $ appT (conT ''ValuedPropertyInfo) $ return haskellValueType,+    valD (varP varName)+         (normalB [| ValuedPropertyInfo+                     name+                     $(conE propType)+                     inherited+                     $(lam1E (varP foo) $ caseE (varE foo)+                       [match (recP propName [])+                              (normalB $ conE $ mkName "True")+                              [],+                        match wildP (normalB $ conE $ mkName "False") []])+                     $(varE valueType)+                     $(lam1E (varP foo) $ caseE (varE foo)+                       [match (conP propName [varP bar]) (normalB $ varE bar) [],+                        match wildP+                              (normalB+                               [| error $ "Property value getter for " ++ $(stringE name) +++                                  " applied to " ++ show $(varE foo) ++ "." |])+                              []])+                     $(lam1E (varP foo) $ appE (conE propName) (varE foo))+                   |])+         []+    ]
+ src/Game/Goatee/Sgf/Property/Info.hs view
@@ -0,0 +1,288 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Property metadata declarations.+--+-- Import "Game.Goatee.Sgf.Property" rather than importing this module.+module Game.Goatee.Sgf.Property.Info where++import Control.Arrow ((&&&))+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Game.Goatee.Sgf.Property.Base+import Game.Goatee.Sgf.Property.Value+import Game.Goatee.Sgf.Types++-- Move properties.+$(defValuedProperty "B" 'MoveProperty False 'movePvt)+$(defProperty "KO" 'MoveProperty False)+$(defValuedProperty "MN" 'MoveProperty False 'integralPvt)+$(defValuedProperty "W" 'MoveProperty False 'movePvt)++-- Setup properties.+$(defValuedProperty "AB" 'SetupProperty False 'coordListPvt)+$(defValuedProperty "AE" 'SetupProperty False 'coordListPvt)+$(defValuedProperty "AW" 'SetupProperty False 'coordListPvt)+$(defValuedProperty "PL" 'SetupProperty False 'colorPvt)++-- Node annotation properties.+$(defValuedProperty "C" 'GeneralProperty False 'textPvt)+$(defValuedProperty "DM" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "GB" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "GW" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "HO" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "N" 'GeneralProperty False 'simpleTextPvt)+$(defValuedProperty "UC" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "V" 'GeneralProperty False 'realPvt)++-- Move annotation properties.+$(defValuedProperty "BM" 'MoveProperty False 'doublePvt)+$(defProperty "DO" 'MoveProperty False)+$(defProperty "IT" 'MoveProperty False)+$(defValuedProperty "TE" 'MoveProperty False 'doublePvt)++-- Markup properties.+$(defValuedProperty "AR" 'GeneralProperty False 'coordPairListPvt)+$(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt)+$(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt)+$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt)+$(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "TR" 'GeneralProperty False 'coordListPvt)++-- Root properties.+propertyAP :: ValuedPropertyInfo (SimpleText, SimpleText)+propertyAP = ValuedPropertyInfo "AP" RootProperty False+             (\x -> case x of { AP {} -> True; _ -> False })+             simpleTextPairPvt+             (\(AP x y) -> (x, y))+             (uncurry AP)+$(defValuedProperty "CA" 'RootProperty False 'simpleTextPvt)+$(defValuedProperty "FF" 'RootProperty False 'integralPvt)  -- TODO Add parser validation.+$(defValuedProperty "GM" 'RootProperty False 'integralPvt)  -- TODO Add parser validation.+$(defValuedProperty "ST" 'RootProperty False 'variationModePvt)+propertySZ :: ValuedPropertyInfo (Int, Int)+propertySZ = ValuedPropertyInfo "SZ" RootProperty False+             (\x -> case x of { SZ {} -> True; _ -> False })+             sizePvt+             (\(SZ x y) -> (x, y))+             (uncurry SZ)++-- Game info properties.+$(defValuedProperty "AN" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "BR" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "BT" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "CP" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "DT" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "EV" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "GC" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "GN" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "ON" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "OT" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "PB" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "PC" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "PW" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "RE" 'GameInfoProperty False 'gameResultPvt)+$(defValuedProperty "RO" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "RU" 'GameInfoProperty False 'rulesetPvt)+$(defValuedProperty "SO" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "TM" 'GameInfoProperty False 'realPvt)+$(defValuedProperty "US" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "WR" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "WT" 'GameInfoProperty False 'simpleTextPvt)++-- Miscellaneous properties.+$(defValuedProperty "VW" 'GeneralProperty True 'coordElistPvt)++propertyUnknown :: String -> ValuedPropertyInfo UnknownPropertyValue+propertyUnknown name =+  ValuedPropertyInfo name GeneralProperty False+  (\x -> case x of+      UnknownProperty name' _ | name' == name -> True+      _ -> False)+  unknownPropertyPvt+  (\(UnknownProperty _ value) -> value)+  (UnknownProperty name)++allDescriptors :: [SomeDescriptor]+allDescriptors = [+  SomeDescriptor propertyB+  , SomeDescriptor propertyKO+  , SomeDescriptor propertyMN+  , SomeDescriptor propertyW++  , SomeDescriptor propertyAB+  , SomeDescriptor propertyAE+  , SomeDescriptor propertyAW+  , SomeDescriptor propertyPL++  , SomeDescriptor propertyC+  , SomeDescriptor propertyDM+  , SomeDescriptor propertyGB+  , SomeDescriptor propertyGW+  , SomeDescriptor propertyHO+  , SomeDescriptor propertyN+  , SomeDescriptor propertyUC+  , SomeDescriptor propertyV++  , SomeDescriptor propertyBM+  , SomeDescriptor propertyDO+  , SomeDescriptor propertyIT+  , SomeDescriptor propertyTE++  , SomeDescriptor propertyAR+  , SomeDescriptor propertyCR+  , SomeDescriptor propertyDD+  , SomeDescriptor propertyLB+  , SomeDescriptor propertyLN+  , SomeDescriptor propertyMA+  , SomeDescriptor propertySL+  , SomeDescriptor propertySQ+  , SomeDescriptor propertyTR++  , SomeDescriptor propertyAP+  , SomeDescriptor propertyCA+  , SomeDescriptor propertyFF+  , SomeDescriptor propertyGM+  , SomeDescriptor propertyST+  , SomeDescriptor propertySZ++  , SomeDescriptor propertyAN+  , SomeDescriptor propertyBR+  , SomeDescriptor propertyBT+  , SomeDescriptor propertyCP+  , SomeDescriptor propertyDT+  , SomeDescriptor propertyEV+  , SomeDescriptor propertyGC+  , SomeDescriptor propertyGN+  , SomeDescriptor propertyON+  , SomeDescriptor propertyOT+  , SomeDescriptor propertyPB+  , SomeDescriptor propertyPC+  , SomeDescriptor propertyPW+  , SomeDescriptor propertyRE+  , SomeDescriptor propertyRO+  , SomeDescriptor propertyRU+  , SomeDescriptor propertySO+  , SomeDescriptor propertyTM+  , SomeDescriptor propertyUS+  , SomeDescriptor propertyWR+  , SomeDescriptor propertyWT++  , SomeDescriptor propertyVW+  ]++propertyInfo :: Property -> SomeDescriptor+propertyInfo property = case property of+  B {} -> SomeDescriptor propertyB+  KO {} -> SomeDescriptor propertyKO+  MN {} -> SomeDescriptor propertyMN+  W {} -> SomeDescriptor propertyW++  AB {} -> SomeDescriptor propertyAB+  AE {} -> SomeDescriptor propertyAE+  AW {} -> SomeDescriptor propertyAW+  PL {} -> SomeDescriptor propertyPL++  C {} -> SomeDescriptor propertyC+  DM {} -> SomeDescriptor propertyDM+  GB {} -> SomeDescriptor propertyGB+  GW {} -> SomeDescriptor propertyGW+  HO {} -> SomeDescriptor propertyHO+  N {} -> SomeDescriptor propertyN+  UC {} -> SomeDescriptor propertyUC+  V {} -> SomeDescriptor propertyV++  BM {} -> SomeDescriptor propertyBM+  DO {} -> SomeDescriptor propertyDO+  IT {} -> SomeDescriptor propertyIT+  TE {} -> SomeDescriptor propertyTE++  AR {} -> SomeDescriptor propertyAR+  CR {} -> SomeDescriptor propertyCR+  DD {} -> SomeDescriptor propertyDD+  LB {} -> SomeDescriptor propertyLB+  LN {} -> SomeDescriptor propertyLN+  MA {} -> SomeDescriptor propertyMA+  SL {} -> SomeDescriptor propertySL+  SQ {} -> SomeDescriptor propertySQ+  TR {} -> SomeDescriptor propertyTR++  AP {} -> SomeDescriptor propertyAP+  CA {} -> SomeDescriptor propertyCA+  FF {} -> SomeDescriptor propertyFF+  GM {} -> SomeDescriptor propertyGM+  ST {} -> SomeDescriptor propertyST+  SZ {} -> SomeDescriptor propertySZ++  AN {} -> SomeDescriptor propertyAN+  BR {} -> SomeDescriptor propertyBR+  BT {} -> SomeDescriptor propertyBT+  CP {} -> SomeDescriptor propertyCP+  DT {} -> SomeDescriptor propertyDT+  EV {} -> SomeDescriptor propertyEV+  GC {} -> SomeDescriptor propertyGC+  GN {} -> SomeDescriptor propertyGN+  ON {} -> SomeDescriptor propertyON+  OT {} -> SomeDescriptor propertyOT+  PB {} -> SomeDescriptor propertyPB+  PC {} -> SomeDescriptor propertyPC+  PW {} -> SomeDescriptor propertyPW+  RE {} -> SomeDescriptor propertyRE+  RO {} -> SomeDescriptor propertyRO+  RU {} -> SomeDescriptor propertyRU+  SO {} -> SomeDescriptor propertySO+  TM {} -> SomeDescriptor propertyTM+  US {} -> SomeDescriptor propertyUS+  WR {} -> SomeDescriptor propertyWR+  WT {} -> SomeDescriptor propertyWT++  VW {} -> SomeDescriptor propertyVW++  UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name++instance Descriptor Property where+  propertyName = propertyName . propertyInfo+  propertyType = propertyType . propertyInfo+  propertyInherited = propertyInherited . propertyInfo+  propertyPredicate = propertyPredicate . propertyInfo+  propertyValueParser = propertyValueParser . propertyInfo+  propertyValueRenderer = propertyValueRenderer . propertyInfo+  propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo++descriptorsByName :: Map String SomeDescriptor+descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors++descriptorForName :: String -> SomeDescriptor+descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name++descriptorForName' :: String -> Maybe SomeDescriptor+descriptorForName' = flip Map.lookup descriptorsByName++-- | Returns the descriptor for a mark.+markProperty :: Mark -> ValuedPropertyInfo CoordList+markProperty MarkCircle = propertyCR+markProperty MarkSelected = propertySL+markProperty MarkSquare = propertySQ+markProperty MarkTriangle = propertyTR+markProperty MarkX = propertyMA
+ src/Game/Goatee/Sgf/Property/Parser.hs view
@@ -0,0 +1,275 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Parsers of property values.+--+-- Import "Game.Goatee.Sgf.Property" rather than importing this module.+module Game.Goatee.Sgf.Property.Parser (+  colorParser,+  coordElistParser,+  coordListParser,+  coordPairListParser,+  doubleParser,+  gameResultParser,+  labelListParser,+  moveParser,+  noneParser,+  integralParser,+  realParser,+  rulesetParser,+  simpleTextPairParser,+  simpleTextParser,+  sizeParser,+  textParser,+  unknownPropertyParser,+  variationModeParser,+  -- * Exposed for testing+  compose,+  line,+  simpleText,+  text,+  ) where++import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>))+import Control.Monad (when)+import Data.Char (isUpper, ord)+import Data.Maybe (catMaybes)+import Data.Monoid (Monoid, mappend, mconcat, mempty)+import Game.Goatee.Sgf.Types+import Text.ParserCombinators.Parsec (+  (<?>), (<|>), Parser,+  anyChar, char, choice, digit, eof, many, many1,+  noneOf, oneOf, option, parse, space, spaces, string,+  try, unexpected,+  )++{-# ANN module "HLint: ignore Reduce duplication" #-}++-- Internal parser builders not corresponding to any particular value type.++-- | A wrapper around 'CoordList' with a 'Monoid' instance used for parsing.+-- The monoid does simple concatenation of the single and rectangle lists, so it+-- is not appropriate for @CoordList@ proper, as it doesn't do duplicate removal+-- between two @CoordList@s.+newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList }++instance Monoid CoordListMonoid where+  mempty = CoordListMonoid emptyCoordList++  mappend (CoordListMonoid x) (CoordListMonoid y) =+    CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y)+                              (coordListRects x ++ coordListRects y)++single :: Parser a -> Parser a+single valueParser = char '[' *> valueParser <* char ']'++compose :: Parser a -> Parser b -> Parser (a, b)+compose first second = do+  x <- first+  char ':'+  y <- second+  return (x, y)++line :: Parser Int+line = toLine <$> line' <?> "line"+  where line' = oneOf $ ['a'..'z'] ++ ['A'..'Z']+        toLine c = if isUpper c+                   then ord c - ord 'A' + 26+                   else ord c - ord 'a'++listOf :: Parser a -> Parser [a]+listOf valueParser = many1 (single valueParser <* spaces)++number :: Parser (String, Bool)+number = do+  sign <- "-" <$ char '-' <|>+          "" <$ char '+' <|>+          return ""+  digits <- many1 digit+  return (sign ++ digits, not $ null sign)++-- Public parsers.++colorParser :: Parser Color+colorParser = single color <?> "color"++color :: Parser Color+color = choice [Black <$ char 'B',+                White <$ char 'W']++coord :: Parser Coord+coord = (,) <$> line <*> line++coordElistParser :: Parser CoordList+coordElistParser =+  try (emptyCoordList <$ string "[]") <|>+  coordListParser <?>+  "list of points or empty"++coordListParser :: Parser CoordList+coordListParser =+  runCoordListMonoid . mconcat . map CoordListMonoid <$> listOf coordListEntry <?>+  "list of points"+  where coordListEntry = do x0 <- line+                            y0 <- line+                            choice [do char ':'+                                       x1 <- line+                                       y1 <- line+                                       return $ coordR ((x0, y0), (x1, y1)),+                                    return $ coord1 (x0, y0)]+        coordR rect = coords' [] [rect]++coordPairListParser :: Parser [(Coord, Coord)]+coordPairListParser = listOf coordPair <?> "list of point pairs"+  where coordPair = do+          x0 <- line+          y0 <- line+          char ':'+          x1 <- line+          y1 <- line+          return ((x0, y0), (x1, y1))++doubleParser :: Parser DoubleValue+doubleParser =+  single (Double1 <$ char '1' <|>+          Double2 <$ char '2') <?>+  "double"++gameResultParser :: Parser GameResult+gameResultParser = single (parseGameResult <$> simpleText False) <?> "game result"+  where parseGameResult text = case fromSimpleText text of+          "0" -> GameResultDraw+          "Draw" -> GameResultDraw+          "Void" -> GameResultVoid+          "?" -> GameResultUnknown+          rawText -> case parse gameResultWin "<game result win>" rawText of+            Left _ -> GameResultOther text+            Right win -> win++gameResultWin :: Parser GameResult+gameResultWin = GameResultWin <$> color <* char '+' <*> winReason <* eof++winReason :: Parser WinReason+winReason =+  WinByScore <$> try real <|>+  WinByResignation <$ try (string "Resign") <|>+  WinByResignation <$ try (string "R") <|>+  WinByTime <$ try (string "Time") <|>+  WinByTime <$ try (string "T") <|>+  WinByForfeit <$ try (string "Forfeit") <|>+  WinByForfeit <$ try (string "F")++labelListParser :: Parser [(Coord, SimpleText)]+labelListParser =+  listOf (compose coord $ simpleText True) <?> "list of points and labels"++moveParser :: Parser (Maybe Coord)+moveParser =+  char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') <?>+  "move (point or pass)"++noneParser :: Parser ()+noneParser = () <$ string "[]" <?> "none"++-- This is what the SGF spec calls the Number type, i.e. a signed integer.+integralParser :: (Integral a, Read a) => Parser a+integralParser = single integral <?> "integer"++integral :: (Integral a, Read a) => Parser a+integral = read . fst <$> number++realParser :: Parser RealValue+realParser = single real <?> "real"++real :: Parser RealValue+real = do+  (whole, isNegative) <- number+  let wholePart = toRational (read whole :: Integer)+  -- Try to read a fractional part of the number.+  -- If we fail, just return the whole part.+  option wholePart $ try $ do+    fractionalStr <- char '.' *> many1 digit+    let fractionalPart = toRational (read fractionalStr) / 10 ^ length fractionalStr+    return $ (if isNegative then (-) else (+)) wholePart fractionalPart++rulesetParser :: Parser Ruleset+rulesetParser =+  single (toRuleset . fromSimpleText <$> simpleText False) <?> "ruleset"++simpleTextPairParser :: Parser (SimpleText, SimpleText)+simpleTextPairParser = single (compose composedText composedText) <?> "pair of simple texts"+  where composedText = simpleText True++-- | A parser for SGF SimpleText property values.+simpleTextParser :: Parser SimpleText+simpleTextParser = single (simpleText False) <?> "simple text"++simpleText :: Bool -> Parser SimpleText+simpleText isComposed = toSimpleText <$> text isComposed++sizeParser :: Parser (Int, Int)+sizeParser =+  (do char '['+      width <- integral+      height <- choice [width <$ char ']',+                        do char ':'+                           height <- integral+                           char ']'+                           -- TODO We should warn here rather than aborting.+                           when (width == height) $+                             fail $ show width ++ "x" ++ show height ++ " square board " +++                             " dimensions should be specified with a single number."+                           return height]+      when (width < 1 || width > boardSizeMax ||+            height < 1 || height > boardSizeMax) $+        fail $ show width ++ "x" ++ show height ++ " board dimensions are invalid.  " +++        "Each dimension must be between 1 and 52 inclusive."+      return (width, height)) <?>+  "board size (width or width:height)"++textParser :: Parser Text+textParser = single (toText <$> text False) <?> "text"++-- | A parser for SGF text property values.  Its argument should be true if the+-- text is inside of a composed property value, so @\':\'@ should terminate the+-- value in addition to @']'@.+text :: Bool -> Parser String+text isComposed = catMaybes <$> many textChar'+  where textChar' = textChar (if isComposed then ":]\\" else "]\\")++textChar :: String -> Parser (Maybe Char)+textChar specialChars =+  choice [Just <$> char '\n',+          Just ' ' <$ space,+          try (char '\\' *> (Nothing <$ char '\n' <|>+                             Just <$> anyChar)),+          Just <$> noneOf specialChars]++unknownPropertyParser :: Parser UnknownPropertyValue+unknownPropertyParser =+  single (toUnknownPropertyValue <$> text False) <?>+  "unknown property value"++variationModeParser :: Parser VariationMode+variationModeParser = single variationMode <?> "variation mode"++variationMode :: Parser VariationMode+variationMode = do+  value <- integral+  case toVariationMode value of+    Just mode -> return mode+    Nothing -> unexpected $ "variation mode " ++ show value
+ src/Game/Goatee/Sgf/Property/Renderer.hs view
@@ -0,0 +1,326 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Renderers of property values.+--+-- Import "Game.Goatee.Sgf.Property" rather than importing this module.+module Game.Goatee.Sgf.Property.Renderer (+  renderColorBracketed,+  renderColorPretty,+  renderCoordElistBracketed,+  renderCoordElistPretty,+  renderCoordListBracketed,+  renderCoordListPretty,+  renderCoordPairListBracketed,+  renderCoordPairListPretty,+  renderDoubleBracketed,+  renderDoublePretty,+  renderGameResultBracketed,+  renderGameResultPretty,+  renderIntegralBracketed,+  renderIntegralPretty,+  renderLabelListBracketed,+  renderLabelListPretty,+  renderMoveBracketed,+  renderMovePretty,+  renderNoneBracketed,+  renderNonePretty,+  renderRealBracketed,+  renderRealPretty,+  renderRulesetBracketed,+  renderRulesetPretty,+  renderSimpleTextBracketed,+  renderSimpleTextPairBracketed,+  renderSimpleTextPairPretty,+  renderSimpleTextPretty,+  renderSizeBracketed,+  renderSizePretty,+  renderTextBracketed,+  renderTextPretty,+  renderUnknownPropertyBracketed,+  renderUnknownPropertyPretty,+  renderVariationModeBracketed,+  renderVariationModePretty,+  ) where++import Control.Monad (forM_, when)+#if MIN_VERSION_base(4,6,0)+import Control.Monad.Except (throwError)+#else+import Control.Monad.Error (throwError)+#endif+import Control.Monad.Writer (tell)+import Data.Char (chr, ord)+import Data.List (intersperse)+import Game.Goatee.Sgf.Renderer+import Game.Goatee.Sgf.Types++{-# ANN module "HLint: ignore Use <$>" #-}++-- Internal renderers not corresponding to any particular value type.++bracketed :: Render () -> Render ()+bracketed x = tell "[" >> x >> tell "]"++renderLine :: Int -> Render ()+renderLine = rendererOf "line" $ \x ->+  if x >= 0 && x < 52+  then tell [chr $ x + (if x < 26 then ord 'a' else ord 'A' - 26)]+  else throwError $ "renderLine: Index not in [0, 52): " ++ show x++renderCoord :: Coord -> Render ()+renderCoord = rendererOf "coord" $ \(x, y) -> renderLine x >> renderLine y++renderCoordBracketed :: Coord -> Render ()+renderCoordBracketed = fmap bracketed renderCoord++renderCoordPretty :: Coord -> Render ()+renderCoordPretty = rendererOf "coord pretty" $ \(x, y) ->+  mapM_ tell ["(", show x, ", ", show y, ")"]++renderCoordPairPretty :: (Coord, Coord) -> Render ()+renderCoordPairPretty = rendererOf "coord pair pretty" $ \(a, b) -> do+  renderCoordPretty a+  tell "-"+  renderCoordPretty b++renderCoordPair :: (Coord, Coord) -> Render ()+renderCoordPair = rendererOf "coord pair" $ \(a, b) ->+  renderCoord a >> tell ":" >> renderCoord b++renderCoordPairBracketed :: (Coord, Coord) -> Render ()+renderCoordPairBracketed = fmap bracketed renderCoordPair++renderShowable :: Show a => a -> Render ()+renderShowable = tell . show++renderStringlike :: (Show a, Stringlike a) => Bool -> a -> Render ()+renderStringlike isComposed =+  rendererOf (if isComposed then "composed stringlike" else "stringlike") $ \str ->+  tell $ escape $ sgfToString str+  where escape [] = []+        escape (first:rest) | first `elem` specialChars = '\\':first:escape rest+                            | otherwise = first:escape rest+        -- TODO Deduplicate these characters with the parser:+        specialChars = if isComposed then ":]\\" else "]\\"++-- Note that unlike the serialized SGF version, we don't care about escaping+-- characters in composed strings.+renderStringlikePretty :: (Show a, Stringlike a) => a -> Render ()+renderStringlikePretty = rendererOf "stringlike pretty" $ tell . sgfToString++-- Public renderers.++renderColorBracketed :: Color -> Render ()+renderColorBracketed color = bracketed $ tell $ case color of+  Black -> "[B]"+  White -> "[W]"++renderColorPretty :: Color -> Render ()+renderColorPretty Black = tell "Black"+renderColorPretty White = tell "White"++renderCoordElistBracketed :: CoordList -> Render ()+renderCoordElistBracketed = rendererOf "coord elist bracketed" $ \list ->+  if null $ expandCoordList list+  then tell "[]"+  else renderCoordListNonempty list++renderCoordElistPretty :: CoordList -> Render ()+renderCoordElistPretty = rendererOf "coord elist pretty" $ \list ->+  if null $ expandCoordList list+  then tell "empty"+  else renderCoordListNonemptyPretty list++renderCoordListBracketed :: CoordList -> Render ()+renderCoordListBracketed = rendererOf "coord list bracketed" $ \list ->+  if null $ expandCoordList list+  then throwError "renderCoordListBracketed: Unexpected empty CoordList."+  else renderCoordListNonempty list++renderCoordListPretty :: CoordList -> Render ()+renderCoordListPretty = rendererOf "coord list pretty" $ \list ->+  if null $ expandCoordList list+  then throwError "renderCoordListPretty: Unexpected empty CoordList."+  else renderCoordListNonemptyPretty list++renderCoordListNonempty :: CoordList -> Render ()+renderCoordListNonempty = rendererOf "coord list nonempty" $ \list -> do+  mapM_ renderCoordPairBracketed $ coordListRects list+  mapM_ renderCoordBracketed $ coordListSingles list++renderCoordListNonemptyPretty :: CoordList -> Render ()+renderCoordListNonemptyPretty = rendererOf "coord list nonempty pretty" $ \list ->+  sequence_ $ intersperse (tell ", ") $+  map renderCoordPairPretty (coordListRects list) +++  map renderCoordPretty (coordListSingles list)++renderCoordPairListBracketed :: [(Coord, Coord)] -> Render ()+renderCoordPairListBracketed = rendererOf "coord pair list bracketed" $ \list ->+  if null list+  then throwError "renderCoordPairListBracketed: Unexpected empty list."+  else mapM_ renderCoordPairBracketed list++renderCoordPairListPretty :: [(Coord, Coord)] -> Render ()+renderCoordPairListPretty list =+  if null list+  then throwError "renderCoordPairListPretty: Unexpected empty list."+  else sequence_ $ intersperse (tell ", ") $ map renderCoordPairPretty list++renderDoubleBracketed :: DoubleValue -> Render ()+renderDoubleBracketed = fmap bracketed $ rendererOf "double" $ \double -> tell $ case double of+  Double1 -> "1"+  Double2 -> "2"++renderDoublePretty :: DoubleValue -> Render ()+renderDoublePretty = rendererOf "double pretty" $ tell . \double -> case double of+  Double1 -> "1"+  Double2 -> "2"++renderGameResultBracketed :: GameResult -> Render ()+renderGameResultBracketed = fmap bracketed $ rendererOf "game result" $ \result -> case result of+  GameResultWin color reason ->+    tell $+    (case color of { Black -> 'B'; White -> 'W' }) : '+' :+    (case reason of+        WinByScore diff -> show diff+        WinByResignation -> "R"+        WinByTime -> "T"+        WinByForfeit -> "F")+  GameResultDraw -> tell "0"+  GameResultVoid -> tell "Void"+  GameResultUnknown -> tell "?"+  GameResultOther text -> renderStringlike False text++renderGameResultPretty :: GameResult -> Render ()+renderGameResultPretty = rendererOf "game result pretty" $ \result -> case result of+  GameResultWin color reason ->+    tell $+    (case color of { Black -> 'B'; White -> 'W' }) : '+' :+    (case reason of+        WinByScore diff -> show diff+        WinByResignation -> "Resign"+        WinByTime -> "Time"+        WinByForfeit -> "Forfeit")+  GameResultDraw -> tell "Draw"+  GameResultVoid -> tell "Void"+  GameResultUnknown -> tell "Unknown"+  GameResultOther text -> renderStringlikePretty text++renderIntegralBracketed :: (Integral a, Show a) => a -> Render ()+renderIntegralBracketed = bracketed . rendererOf "integral" renderShowable++renderIntegralPretty :: (Integral a, Show a) => a -> Render ()+renderIntegralPretty = rendererOf "integral pretty" renderShowable++renderLabelListBracketed :: [(Coord, SimpleText)] -> Render ()+renderLabelListBracketed = rendererOf "label list" $ \list ->+  if null list+  then throwError "renderLabelListBracketed: Unexpected empty list."+  else forM_ list $ bracketed . \(coord, text) -> do+    renderCoord coord+    tell ":"+    renderStringlike True text++renderLabelListPretty :: [(Coord, SimpleText)] -> Render ()+renderLabelListPretty = rendererOf "label list pretty" $ \list ->+  if null list+  then throwError "renderLabelListPretty: Unexpected empty list."+  else sequence_ $ intersperse (tell ", ") $+       map (\(coord, text) -> do+               renderCoordPretty coord+               tell ":"+               renderStringlikePretty text)+       list++renderMoveBracketed :: Maybe Coord -> Render ()+renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed++renderMovePretty :: Maybe Coord -> Render ()+renderMovePretty = rendererOf "move pretty" $ maybe (tell "Pass") renderCoordPretty++renderNoneBracketed :: () -> Render ()+renderNoneBracketed = rendererOf "none bracketed" $ tell . const "[]"++renderNonePretty :: () -> Render ()+renderNonePretty = rendererOf "none pretty" $ tell . const ""++renderRealBracketed :: RealValue -> Render ()+renderRealBracketed = fmap bracketed $ rendererOf "real" $ renderShowable . fromRational++renderRealPretty :: RealValue -> Render ()+renderRealPretty = rendererOf "real pretty" renderShowable++renderRulesetBracketed :: Ruleset -> Render ()+renderRulesetBracketed = fmap bracketed $ rendererOf "ruleset" $ tell . fromRuleset++renderRulesetPretty :: Ruleset -> Render ()+renderRulesetPretty = rendererOf "ruleset pretty" $ tell . fromRuleset++renderSimpleTextPairBracketed :: (SimpleText, SimpleText) -> Render ()+renderSimpleTextPairBracketed = fmap bracketed $ rendererOf "simple text pair" $ \(a, b) -> do+  renderStringlike True a+  tell ":"+  renderStringlike True b++renderSimpleTextPairPretty :: (SimpleText, SimpleText) -> Render ()+renderSimpleTextPairPretty = fmap bracketed $ rendererOf "simple text pair pretty" $ \(a, b) -> do+  renderStringlike True a+  tell " "+  renderStringlike True b++renderSimpleTextBracketed :: SimpleText -> Render ()+renderSimpleTextBracketed = fmap bracketed $ rendererOf "simple text" $ renderStringlike False++renderSimpleTextPretty :: SimpleText -> Render ()+renderSimpleTextPretty = fmap bracketed $ rendererOf "simple text pretty" $ tell . fromSimpleText++renderSizeBracketed :: (Int, Int) -> Render ()+renderSizeBracketed = fmap bracketed $ rendererOf "size" $ \(x, y) -> do+  tell $ show x+  when (x /= y) $ tell $ ':' : show y++renderSizePretty :: (Int, Int) -> Render ()+renderSizePretty = rendererOf "size pretty" renderCoordPretty++renderTextBracketed :: Text -> Render ()+renderTextBracketed = fmap bracketed $ rendererOf "text" $ renderStringlike False++renderTextPretty :: Text -> Render ()+renderTextPretty = fmap bracketed $ rendererOf "text pretty" $ tell . fromText++renderUnknownPropertyBracketed :: UnknownPropertyValue -> Render ()+renderUnknownPropertyBracketed =+  fmap bracketed $ rendererOf "unknown property" $ renderStringlike False++renderUnknownPropertyPretty :: UnknownPropertyValue -> Render ()+renderUnknownPropertyPretty =+  rendererOf "unknown property pretty" $ tell . fromUnknownPropertyValue++renderVariationModeBracketed :: VariationMode -> Render ()+renderVariationModeBracketed =+  fmap bracketed $ rendererOf "variation mode" $ tell . show . fromVariationMode++renderVariationModePretty :: VariationMode -> Render ()+renderVariationModePretty = rendererOf "variation mode pretty" $ \(VariationMode source markup) ->+  tell $+  (case source of+      ShowChildVariations -> "Children"+      ShowCurrentVariations -> "Current") ++ " " +++  (if markup then "Shown" else "Hidden")
+ src/Game/Goatee/Sgf/Property/Value.hs view
@@ -0,0 +1,179 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Metadata about the types of property values.+--+-- Import "Game.Goatee.Sgf.Property" rather than importing this module.+module Game.Goatee.Sgf.Property.Value (+  PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty,+  colorPvt,+  coordElistPvt,+  coordListPvt,+  coordPairListPvt,+  doublePvt,+  gameResultPvt,+  integralPvt,+  labelListPvt,+  movePvt,+  nonePvt,+  realPvt,+  rulesetPvt,+  simpleTextPairPvt,+  simpleTextPvt,+  sizePvt,+  textPvt,+  unknownPropertyPvt,+  variationModePvt,+  ) where++import qualified Game.Goatee.Sgf.Property.Parser as P+import qualified Game.Goatee.Sgf.Property.Renderer as R+import Game.Goatee.Sgf.Renderer+import Game.Goatee.Sgf.Types+import Text.ParserCombinators.Parsec (Parser)++data PropertyValueType a = PropertyValueType {+  pvtParser :: Parser a+  , pvtRenderer :: a -> Render ()+  , pvtRendererPretty :: a -> Render ()+  }++colorPvt :: PropertyValueType Color+colorPvt = PropertyValueType {+  pvtParser = P.colorParser+  , pvtRenderer = R.renderColorBracketed+  , pvtRendererPretty = R.renderColorPretty+  }++coordElistPvt :: PropertyValueType CoordList+coordElistPvt = PropertyValueType {+  pvtParser = P.coordElistParser+  , pvtRenderer = R.renderCoordElistBracketed+  , pvtRendererPretty = R.renderCoordElistPretty+  }++coordListPvt :: PropertyValueType CoordList+coordListPvt = PropertyValueType {+  pvtParser = P.coordListParser+  , pvtRenderer = R.renderCoordListBracketed+  , pvtRendererPretty = R.renderCoordListPretty+  }++coordPairListPvt :: PropertyValueType [(Coord, Coord)]+coordPairListPvt = PropertyValueType {+  pvtParser = P.coordPairListParser+  , pvtRenderer = R.renderCoordPairListBracketed+  , pvtRendererPretty = R.renderCoordPairListPretty+  }++doublePvt :: PropertyValueType DoubleValue+doublePvt = PropertyValueType {+  pvtParser = P.doubleParser+  , pvtRenderer = R.renderDoubleBracketed+  , pvtRendererPretty = R.renderDoublePretty+  }++gameResultPvt :: PropertyValueType GameResult+gameResultPvt = PropertyValueType {+  pvtParser = P.gameResultParser+  , pvtRenderer = R.renderGameResultBracketed+  , pvtRendererPretty = R.renderGameResultPretty+  }++integralPvt :: (Integral a, Read a, Show a) => PropertyValueType a+integralPvt = PropertyValueType {+  pvtParser = P.integralParser+  , pvtRenderer = R.renderIntegralBracketed+  , pvtRendererPretty = R.renderIntegralPretty+  }++labelListPvt :: PropertyValueType [(Coord, SimpleText)]+labelListPvt = PropertyValueType {+  pvtParser = P.labelListParser+  , pvtRenderer = R.renderLabelListBracketed+  , pvtRendererPretty = R.renderLabelListPretty+  }++movePvt :: PropertyValueType (Maybe Coord)+movePvt = PropertyValueType {+  pvtParser = P.moveParser+  , pvtRenderer = R.renderMoveBracketed+  , pvtRendererPretty = R.renderMovePretty+  }++nonePvt :: PropertyValueType ()+nonePvt = PropertyValueType {+  pvtParser = P.noneParser+  , pvtRenderer = R.renderNoneBracketed+  , pvtRendererPretty = R.renderNonePretty+  }++realPvt :: PropertyValueType RealValue+realPvt = PropertyValueType {+  pvtParser = P.realParser+  , pvtRenderer = R.renderRealBracketed+  , pvtRendererPretty = R.renderRealPretty+  }++rulesetPvt :: PropertyValueType Ruleset+rulesetPvt = PropertyValueType {+  pvtParser = P.rulesetParser+  , pvtRenderer = R.renderRulesetBracketed+  , pvtRendererPretty = R.renderRulesetPretty+  }++simpleTextPairPvt :: PropertyValueType (SimpleText, SimpleText)+simpleTextPairPvt = PropertyValueType {+  pvtParser = P.simpleTextPairParser+  , pvtRenderer = R.renderSimpleTextPairBracketed+  , pvtRendererPretty = R.renderSimpleTextPairPretty+  }++simpleTextPvt :: PropertyValueType SimpleText+simpleTextPvt = PropertyValueType {+  pvtParser = P.simpleTextParser+  , pvtRenderer = R.renderSimpleTextBracketed+  , pvtRendererPretty = R.renderSimpleTextPretty+  }++sizePvt :: PropertyValueType (Int, Int)+sizePvt = PropertyValueType {+  pvtParser = P.sizeParser+  , pvtRenderer = R.renderSizeBracketed+  , pvtRendererPretty = R.renderSizePretty+  }++textPvt :: PropertyValueType Text+textPvt = PropertyValueType {+  pvtParser = P.textParser+  , pvtRenderer = R.renderTextBracketed+  , pvtRendererPretty = R.renderTextPretty+  }++unknownPropertyPvt :: PropertyValueType UnknownPropertyValue+unknownPropertyPvt = PropertyValueType {+  pvtParser = P.unknownPropertyParser+  , pvtRenderer = R.renderUnknownPropertyBracketed+  , pvtRendererPretty = R.renderUnknownPropertyPretty+  }++variationModePvt :: PropertyValueType VariationMode+variationModePvt = PropertyValueType {+  pvtParser = P.variationModeParser+  , pvtRenderer = R.renderVariationModeBracketed+  , pvtRendererPretty = R.renderVariationModePretty+  }
+ src/Game/Goatee/Sgf/Renderer.hs view
@@ -0,0 +1,56 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Common definitions for a renderer that supports failure.+module Game.Goatee.Sgf.Renderer (+  Render,+  runRender,+  rendererOf,+  ) where++#if MIN_VERSION_base(4,6,0)+import Control.Monad.Except (Except, catchError, runExcept, throwError)+#else+import Control.Monad.Error (catchError, throwError)+#endif+import Control.Monad.Writer (WriterT, execWriterT)++-- | A monad for accumulating string output with the possibility of failure.+#if MIN_VERSION_base(4,6,0)+type Render = WriterT String (Except String)+#else+type Render = WriterT String (Either String)+#endif++-- | Returns either the rendered result on the right, or a message describing a+-- failure on the left.+runRender :: Render a -> Either String String+#if MIN_VERSION_base(4,6,0)+runRender = runExcept . execWriterT+#else+runRender = execWriterT+#endif++-- | Wraps a renderer in an exception handler that, when the renderer or+-- something it calls fails, will add context about this renderer's invocation+-- to the failure message.+rendererOf :: Show a => String -> (a -> Render ()) -> a -> Render ()+rendererOf description renderer value = catchError (renderer value) $ \message ->+  throwError $+  message ++ "\n    while trying to render " ++ description ++ " from " ++ show value ++ "."
+ src/Game/Goatee/Sgf/Renderer/Tree.hs view
@@ -0,0 +1,56 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Functions for serializing SGF trees.+module Game.Goatee.Sgf.Renderer.Tree (+  renderCollection,+  ) where++import Control.Monad (forM_)+import Control.Monad.Writer (tell)+import Game.Goatee.Common+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Renderer+import Game.Goatee.Sgf.Tree++-- | Renders an SGF 'Collection' to a string.+renderCollection :: Collection -> Render ()+renderCollection collection = do+  mapM_ renderGameTree $ collectionTrees collection+  tell "\n"++-- | Recursively renders an SGF GameTree (as defined in the spec) rooted at the+-- given node.+renderGameTree :: Node -> Render ()+renderGameTree node = do+  tell "("+  doWhileM node+    (\node' -> do renderNode node'+                  case nodeChildren node' of+                    [] -> return $ Left Nothing+                    child:[] -> return $ Right child+                    children -> return $ Left $ Just children)+    >>= maybe (return ()) (mapM_ renderGameTree)+  tell ")"++-- | Renders a node and its properties without recurring to its children.+renderNode :: Node -> Render ()+renderNode node = do+  tell "\n;"+  forM_ (nodeProperties node) $ \property -> do+    tell $ propertyName property+    propertyValueRenderer property property
+ src/Game/Goatee/Sgf/Tree.hs view
@@ -0,0 +1,175 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | SGF data structures modelling the hierarchical game tree.+module Game.Goatee.Sgf.Tree (+  Collection(..), CollectionWithDeepEquality(..),+  Node(..), NodeWithDeepEquality(..),+  emptyNode, rootNode,+  findProperty, findProperty', findPropertyValue, findPropertyValue',+  addProperty, addChild, addChildAt,+  validateNode,+  ) where++import Control.Applicative ((<$>))+import Control.Monad (forM_, unless, when)+import Control.Monad.Writer (Writer, execWriter, tell)+import Data.Function (on)+import Data.List (find, groupBy, intercalate, nub, sortBy)+import Data.Version (showVersion)+import Game.Goatee.App (applicationName)+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Types+import Paths_goatee (version)++-- | An SGF collection of game trees.+data Collection = Collection { collectionTrees :: [Node]+                             } deriving (Show)++-- | See 'NodeWithDeepEquality'.+newtype CollectionWithDeepEquality = CollectionWithDeepEquality {+  collectionWithDeepEquality :: Collection+  } deriving (Show)++instance Eq CollectionWithDeepEquality where+  (==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality++-- | An SGF game tree node.  Unlike in the SGF spec, we represent a game tree+-- with nodes uniformly, rather than having the separation between sequences and+-- nodes.+data Node = Node { nodeProperties :: [Property]+                 , nodeChildren :: [Node]+                 } deriving (Show)++-- | A wrapper around 'Node' with an 'Eq' instance that considers two nodes+-- equal iff they contain the same properties (not necessarily in the same+-- order), and if they contain children (in the same order) whose nodes are+-- recursively equal.+--+-- This instance is not on 'Node' directly because it is not the only obvious+-- sense of equality (only comparing properties would be another one), and it's+-- also potentially expensive.+newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node }++instance Eq NodeWithDeepEquality where+  node1 == node2 =+    let n1 = nodeWithDeepEquality node1+        n2 = nodeWithDeepEquality node2+    in propertiesSorted n1 == propertiesSorted n2 &&+       deepChildren n1 == deepChildren n2+    where propertiesSorted = sortBy (compare `on` show) . nodeProperties+          deepChildren = map NodeWithDeepEquality . nodeChildren++-- | A node with no properties and no children.+emptyNode :: Node+emptyNode = Node { nodeProperties = [], nodeChildren = [] }++-- | Returns a fresh root 'Node' with 'AP' set to Goatee and optionally with a+-- board size set via 'SZ'.+rootNode :: Maybe (Int, Int) -> Node+rootNode maybeSize =+  let props = FF 4 :+              GM 1 :+              AP (toSimpleText applicationName)+                 (toSimpleText $ showVersion version) :+              maybe [] ((:[]) . uncurry SZ) maybeSize+  in Node { nodeProperties = props+          , nodeChildren = []+          }++-- | Searches for a matching property in a node's property list.+findProperty :: Descriptor a => a -> Node -> Maybe Property+findProperty descriptor node = findProperty' descriptor $ nodeProperties node++-- | Searches for a matching property in a property list.+findProperty' :: Descriptor a => a -> [Property] -> Maybe Property+findProperty' = find . propertyPredicate++-- | Retrieves the value of a property in a node's property list.+findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v+findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node++-- | Retrieves the value of a property in a property list.+findPropertyValue' :: ValuedDescriptor a v => a -> [Property] -> Maybe v+findPropertyValue' descriptor properties =+  propertyValue descriptor <$> findProperty' descriptor properties++-- | Appends a property to a node's property list.+addProperty :: Property -> Node -> Node+addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] }++-- | @addChild child parent@ appends a child node to a node's child list.+addChild :: Node -> Node -> Node+addChild child node = node { nodeChildren = nodeChildren node ++ [child] }++-- | @addChildAt index child parent@ inserts a child node into a node's child+-- list at the given index, shifting all nodes at or after the given index to+-- the right.  The index must be in the range @[0, numberOfChildren]@.+addChildAt :: Int -> Node -> Node -> Node+addChildAt index child node =+  let (before, after) = splitAt index $ nodeChildren node+  in node { nodeChildren = before ++ child:after }++-- | Returns a list of validation errors for the current node, an+-- empty list if no errors are detected.+validateNode :: Bool -> Bool -> Node -> [String]+validateNode isRoot _{-seenGameNode-} node = execWriter $ do+  let props = nodeProperties node+  let propTypes = nub $ map propertyType $ nodeProperties node++  -- Check for move and setup properties in a single node.+  when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $+    tell ["Node contains move and setup properties."]++  -- Check for root properties in non-root nodes.+  let rootProps = filter ((RootProperty ==) . propertyType) props+  when (not isRoot && not (null rootProps)) $+    tell $ map (\p -> "Root property found on non-root node: " +++                      show p ++ ".")+           rootProps++  -- TODO Check for game-info properties.++  -- Check for coordinates marked multiple times.+  validateNodeDuplicates props getMarkedCoords $ \group ->+    tell ["Coordinate " ++ show (fst $ head group) +++          " is specified multiple times in properties " +++          intercalate ", " (map snd group) ++ "."]++  -- TODO Validate recursively.++  where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR"+        getMarkedCoords (MA cs) = tagMarkedCoords cs "MA"+        getMarkedCoords (SL cs) = tagMarkedCoords cs "SL"+        getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ"+        getMarkedCoords (TR cs) = tagMarkedCoords cs "TR"+        getMarkedCoords _ = []++        tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs++validateNodeDuplicates :: (Eq v, Ord v)+                          => [Property]+                          -> (Property -> [(v, t)])+                          -> ([(v, t)] -> Writer [String] ())+                          -> Writer [String] ()+validateNodeDuplicates props getTaggedElts errAction =+  let groups = groupBy ((==) `on` fst) $+               sortBy (compare `on` fst) $+               concatMap getTaggedElts props+  in forM_ groups $ \group ->+       unless (null $ tail group) $+         errAction group
+ src/Game/Goatee/Sgf/Types.hs view
@@ -0,0 +1,389 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Constants and data types for property values used in SGF game trees.+module Game.Goatee.Sgf.Types (+  supportedFormatVersions, defaultFormatVersion, supportedGameTypes,+  boardSizeDefault, boardSizeMin, boardSizeMax,+  Coord, CoordList, coordListSingles, coordListRects, coord1, coords, coords',+  emptyCoordList, expandCoordList, buildCoordList,+  RealValue,+  Stringlike (..),+  Text, fromText, toText,+  SimpleText, fromSimpleText, toSimpleText,+  UnknownPropertyValue, fromUnknownPropertyValue, toUnknownPropertyValue,+  DoubleValue (..),+  Color (..), cnot,+  VariationMode (..), VariationModeSource (..), defaultVariationMode,+  toVariationMode, fromVariationMode,+  ArrowList, LineList, LabelList, Mark (..),+  GameResult (..),+  WinReason (..),+  Ruleset (..), RulesetType (..), fromRuleset, toRuleset,+  ) where++import Data.Char (isSpace)+import Data.Function (on)+import Data.List (delete, groupBy, partition, sort)++-- TODO Support FF versions 1-4.+supportedFormatVersions :: [Int]+supportedFormatVersions = [4]++-- | The default SGF version to use when @FF[]@ is not specified in a root node.+--+-- This value is actually INCORRECT: SGF defines it to be 1, but because we+-- don't support version 1 yet, for the sake of ignoring this issue (for now!)+-- in tests, we fix the default to be 4.+--+-- TODO Fix the default version to be 1 as SGF mandates.+defaultFormatVersion :: Int+defaultFormatVersion = 4++supportedGameTypes :: [Int]+supportedGameTypes = [1 {- Go -}]++-- | The default size of the board.  The FF[4] SGF spec says that the default Go+-- board is 19x19 square.+boardSizeDefault :: Int+boardSizeDefault = 19++-- | The minimum board size allowed by FF[4], 1.+boardSizeMin :: Int+boardSizeMin = 1++-- | The maximum board size allowed by FF[4], 52.+boardSizeMax :: Int+boardSizeMax = 52++-- | A coordinate on a Go board.  @(0, 0)@ refers to the upper-left corner of+-- the board.  The first component is the horizontal position; the second+-- component is the vertical position.+type Coord = (Int, Int)++-- | A structure for compact representation of a list of coordinates.  Contains+-- a list of individual points, as well as a list of rectangles of points+-- denoted by an ordered pair of the upper-left point and the lower-right point.+-- The union of the single points and points contained within rectangles make up+-- all of the points a @CoordList@ represents.  There is no rule saying that+-- adjacent points have to be grouped into rectangles; it's perfectly valid+-- (although possibly inefficient) to never use rectangles.+--+-- For any @CoordList@, all of the following hold:+--+-- 1. Any point may be specified at most once, either in the singles list or in+-- a single rectangle.+--+-- 2. For a rectangle @((x0,y0), (x1,y1))@, @x0 <= x1@ and @y0 <= y1@ and+-- @(x0,y0) /= (x1,y1)@ (otherwise the point belongs in the singles list).+data CoordList = CoordList {+  coordListSingles :: [Coord]+  -- ^ Returns the single points in a 'CoordList'.+  , coordListRects :: [(Coord, Coord)]+    -- ^ Returns the rectangles in a 'CoordList'.+  } deriving (Show)++-- | Equality is based on unordered, set equality of the underlying points.+instance Eq CoordList where+  (==) = (==) `on` sort . expandCoordList++-- | Constructs a 'CoordList' containing a single point.+coord1 :: Coord -> CoordList+coord1 xy = CoordList { coordListSingles = [xy]+                      , coordListRects = []+                      }++-- | Constructs a 'CoordList' containing the given single points.  For rectangle+-- detection, use 'buildCoordList'.+coords :: [Coord] -> CoordList+coords singles = CoordList { coordListSingles = singles+                           , coordListRects = []+                           }++-- | Constructs a 'CoordList' containing the given single points and rectangles.+coords' :: [Coord] -> [(Coord, Coord)] -> CoordList+coords' singles rects = CoordList { coordListSingles = singles+                                  , coordListRects = rects+                                  }++-- | A 'CoordList' that contains no points.+emptyCoordList :: CoordList+emptyCoordList = CoordList { coordListSingles = []+                           , coordListRects = []+                           }++-- | Converts a compact 'CoordList' to a list of coordinates.+expandCoordList :: CoordList -> [Coord]+expandCoordList cl = coordListSingles cl +++                     foldr (\r@((x0, y0), (x1, y1)) rest ->+                             if x0 > x1 || y0 > y1+                             then error ("Invalid coord. rectangle: " ++ show r)+                             else [(x, y) | x <- [x0..x1], y <- [y0..y1]] ++ rest)+                           []+                           (coordListRects cl)++-- | Constructs a 'CoordList' from a list of 'Coord's, doing some+-- not-completely-stupid rectangle detection.  The order of data in the result+-- is unspecified.+buildCoordList :: [Coord] -> CoordList+-- This algorithm doesn't generate the smallest result.  For the following+-- input:+--+-- F F T T+-- T T T T+-- T T F F+--+-- It will return [ca:da][ab:db][ac:bc] rather than the shorter [ca:db][ab:bc].+buildCoordList = toCoordList . generateRects 0 [] . buildTruePairs . toGrid+  where -- | Constructs a row-major grid of booleans where an coordinate is true+        -- iff it is in the given list.+        toGrid :: [Coord] -> [[Bool]]+        toGrid [] = []+        toGrid coords = let x1 = maximum $ map fst coords+                            y1 = maximum $ map snd coords+                        in [[(x,y) `elem` coords | x <- [0..x1]] | y <- [0..y1]]++        -- | For each row, converts a list of booleans into a list of pairs+        -- where each pair represents a consecutive run of true values.  The+        -- pair indicates the indices of the first and last boolean in each run.+        buildTruePairs :: [[Bool]] -> [[(Int, Int)]]+        buildTruePairs = map $+                         concatMap extractTrueGroups .+                         groupBy ((==) `on` snd) .+                         zip [0..]++        -- | Given a run of indexed booleans with the same boolean value within+        -- a row, returns @[(startIndex, endIndex)]@ if the value is true, and+        -- @[]@ if the value is false.+        extractTrueGroups :: [(Int, Bool)] -> [(Int, Int)]+        extractTrueGroups list@((start, True):_) = [(start, fst (last list))]+        extractTrueGroups _ = []++        -- | Converts the lists of true pairs for all rows into a list of+        -- @(Coord, Coord)@ rectangles.  We repeatedly grab the first span in+        -- the first row, and see how many leading rows contain that exact span.+        -- Then we build a (maybe multi-row) rectangle for the span, remove the+        -- span from all leading rows, and repeat.  When the first row becomes+        -- empty, we drop it and increment a counter that keeps track of our+        -- first row's y-position.+        generateRects :: Int -> [(Coord, Coord)] -> [[(Int, Int)]] -> [(Coord, Coord)]+        generateRects _ acc [] = acc+        generateRects topRowOffset acc ([]:rows) = generateRects (topRowOffset + 1) acc rows+        generateRects topRowOffset acc rows@((span:_):_) =+          let rowsWithSpan = matchRowsWithSpan span rows+              rowsWithSpanCount = length rowsWithSpan+          in generateRects topRowOffset+                           (((fst span, topRowOffset),+                             (snd span, topRowOffset + rowsWithSpanCount - 1)) : acc)+                           (rowsWithSpan ++ drop rowsWithSpanCount rows)++        -- | Determines how many leading rows contain the given span.  A list of+        -- all the matching rows is returned, with the span deleted from each.+        matchRowsWithSpan :: (Int, Int) -> [[(Int, Int)]] -> [[(Int, Int)]]+        matchRowsWithSpan span (row:rows)+          | span `elem` row = delete span row : matchRowsWithSpan span rows+          | otherwise = []+        matchRowsWithSpan _ [] = []++        -- | Builds a 'CoordList' from simple @(Coord, Coord)@ rectangles.+        toCoordList :: [(Coord, Coord)] -> CoordList+        toCoordList rects =+          let (singles, properRects) = partition (uncurry (==)) rects+          in coords' (map fst singles) properRects++-- | An SGF real value.+type RealValue = Rational++-- | A class for SGF data types that are coercable to and from strings.+--+-- The construction of an SGF value with 'stringToSgf' may process the input,+-- such that the resulting stringlike value does not represent the same string+-- as the input.  In other words, the following does *not* necessarily hold:+--+-- > sgfToString . stringToSgf = id   (does not necessarily hold!)+--+-- The following does hold, however:+--+-- > stringToSgf . sgfToString = id+class Stringlike a where+  -- | Extracts the string value from an SGF value.+  sgfToString :: a -> String++  -- | Creates an SGF value from a string value.+  stringToSgf :: String -> a++-- | An SGF text value.+newtype Text = Text { fromText :: String+                      -- ^ Converts an SGF 'Text' to a string.+                    }+             deriving (Eq, Show)++instance Stringlike Text where+  sgfToString = fromText+  stringToSgf = toText++-- | Converts a string to an SGF 'Text'.+toText :: String -> Text+toText = Text++-- | An SGF SimpleText value.+newtype SimpleText = SimpleText { fromSimpleText :: String+                                  -- ^ Converts an SGF 'SimpleText' to a string.+                                }+                   deriving (Eq, Show)++instance Stringlike SimpleText where+  sgfToString = fromSimpleText+  stringToSgf = toSimpleText++sanitizeSimpleText :: String -> String+sanitizeSimpleText = map (\c -> if isSpace c then ' ' else c)++-- | Converts a string to an SGF 'SimpleText', replacing all whitespaces+-- (including newlines) with spaces.+toSimpleText :: String -> SimpleText+toSimpleText = SimpleText . sanitizeSimpleText++-- | The value type for an 'UnknownProperty'.  Currently represented as a+-- string.+data UnknownPropertyValue = UnknownPropertyValue {+  fromUnknownPropertyValue :: String+  -- ^ Returns the string contained within the 'UnknownProperty' this value is+  -- from.+  } deriving (Eq, Show)++instance Stringlike UnknownPropertyValue where+  sgfToString = fromUnknownPropertyValue+  stringToSgf = toUnknownPropertyValue++-- | Constructs a value for a 'UnknownProperty'.+toUnknownPropertyValue :: String -> UnknownPropertyValue+toUnknownPropertyValue = UnknownPropertyValue++-- | An SGF double value: either 1 or 2, nothing else.+data DoubleValue = Double1+                 | Double2+                 deriving (Eq, Show)++-- | Stone color: black or white.+data Color = Black+           | White+           deriving (Eq, Show)++-- | Returns the logical negation of a stone color, yang for yin and+-- yin for yang.+cnot :: Color -> Color+cnot Black = White+cnot White = Black++-- | SGF flags that control how move variations are to be presented while+-- displaying the game.+data VariationMode = VariationMode {+  variationModeSource :: VariationModeSource+  -- ^ Which moves to display as variations.+  , variationModeBoardMarkup :: Bool+    -- ^ Whether to overlay variations on the board.+  } deriving (Eq, Show)++-- | An enumeration that describes which variations are shown.+data VariationModeSource =+  ShowChildVariations+  -- ^ Show children of the current move.+  | ShowCurrentVariations+    -- ^ Show alternatives to the current move.+  deriving (Bounded, Enum, Eq, Show)++-- | The default variation mode as defined by the SGF spec is @VariationMode+-- ShowChildVariations True@.+defaultVariationMode :: VariationMode+defaultVariationMode = VariationMode ShowChildVariations True++-- | Parses a numeric variation mode, returning nothing if the number is+-- invalid.+toVariationMode :: Int -> Maybe VariationMode+toVariationMode n = case n of+  0 -> Just $ VariationMode ShowChildVariations True+  1 -> Just $ VariationMode ShowCurrentVariations True+  2 -> Just $ VariationMode ShowChildVariations False+  3 -> Just $ VariationMode ShowCurrentVariations False+  _ -> Nothing++-- | Returns the integer value for a variation mode.+fromVariationMode :: VariationMode -> Int+fromVariationMode mode = case mode of+  VariationMode ShowChildVariations True -> 0+  VariationMode ShowCurrentVariations True -> 1+  VariationMode ShowChildVariations False -> 2+  VariationMode ShowCurrentVariations False -> 3++-- | A list of arrows, each specified as @(startCoord, endCoord)@.+type ArrowList = [(Coord, Coord)]++-- | A list of lines, each specified as @(startCoord, endCoord)@.+type LineList = [(Coord, Coord)]++-- | A list of labels, each specified with a string and a coordinate about which+-- to center the string.+type LabelList = [(Coord, SimpleText)]++-- | The markings that SGF supports annotating coordinates with.+data Mark = MarkCircle | MarkSquare | MarkTriangle | MarkX | MarkSelected+          deriving (Bounded, Enum, Eq, Show)++data GameResult = GameResultWin Color WinReason+                | GameResultDraw+                | GameResultVoid+                | GameResultUnknown+                | GameResultOther SimpleText+                deriving (Eq, Show)++data WinReason = WinByScore RealValue+               | WinByResignation+               | WinByTime+               | WinByForfeit+               deriving (Eq, Show)++-- | A ruleset used for a Go game.  Can be one of the rulesets defined by the+-- SGF specification, or a custom string.+data Ruleset = KnownRuleset RulesetType+             | UnknownRuleset String+             deriving (Eq, Show)++-- | The rulesets defined by the SGF specification, for use with 'Ruleset'.+data RulesetType = RulesetAga+                 | RulesetIng+                 | RulesetJapanese+                 | RulesetNewZealand+                 deriving (Bounded, Enum, Eq, Show)++-- | Returns the string representation for a ruleset.+fromRuleset :: Ruleset -> String+fromRuleset ruleset = case ruleset of+  KnownRuleset RulesetAga -> "AGA"+  KnownRuleset RulesetIng -> "Goe"+  KnownRuleset RulesetJapanese -> "Japanese"+  KnownRuleset RulesetNewZealand -> "NZ"+  UnknownRuleset str -> str++-- | Parses a string representation of a ruleset.+toRuleset :: String -> Ruleset+toRuleset str = case str of+  "AGA" -> KnownRuleset RulesetAga+  "Goe" -> KnownRuleset RulesetIng+  "Japanese" -> KnownRuleset RulesetJapanese+  "NZ" -> KnownRuleset RulesetNewZealand+  _ -> UnknownRuleset str
+ tests/Game/Goatee/CommonTest.hs view
@@ -0,0 +1,271 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.CommonTest (tests) where++import qualified Control.Monad.State as State+import Control.Monad.Identity (runIdentity)+import Control.Monad.State (StateT, get, put, runStateT)+import Control.Monad.Writer (execWriter, tell)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Monoid (mappend, mempty)+import Game.Goatee.Common+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), assertFailure)++{-# ANN module "HLint: ignore Use camelCase" #-}++tests = testGroup "Game.Goatee.Common" [+  listDeleteIndexTests,+  listReplaceTests,+  onLeftTests,+  onRightTests,+  andEithersTests,+  forTests,+  mapTupleTests,+  whenMaybeTests,+  condTests,+  if'Tests,+  andMTests,+  forIndexM_Tests,+  whileMTests,+  whileM'Tests,+  doWhileMTests,+  seqTests+  ]++listDeleteIndexTests = testGroup "listDeleteIndex" [+  testCase "deletes nothing from an empty list" $ do+    [] @=? listDeleteIndex (-1) ([] :: [()])+    [] @=? listDeleteIndex 0 ([] :: [()])+    [] @=? listDeleteIndex 1 ([] :: [()]),++  testCase "deletes the only item from a singleton list" $+    [] @=? listDeleteIndex 0 [()],++  testCase "deletes the head of a list" $+    [False] @=? listDeleteIndex 0 [True, False],++  testCase "deletes the tail of a list" $+    [Just 0, Nothing] @=? listDeleteIndex 2 [Just 0, Nothing, Just 1],++  testCase "deletes an inner item from a list" $+    [Just 0, Just 1] @=? listDeleteIndex 1 [Just 0, Nothing, Just 1],++  testCase "ignores a negative index" $ do+    [1, 2, 3] @=? listDeleteIndex (-1) [1, 2, 3]+    [1, 2, 3] @=? listDeleteIndex (-2) [1, 2, 3],++  testCase "ignores an index too large" $ do+    [1, 2, 3] @=? listDeleteIndex 3 [1, 2, 3]+    [1, 2, 3] @=? listDeleteIndex 4 [1, 2, 3]+  ]++listReplaceTests = testGroup "listReplace" [+  testCase "accepts an empty list" $+    [] @=? listReplace False True [],++  testCase "replaces the first element" $+    [100, 2, 3] @=? listReplace 1 100 [1, 2, 3],++  testCase "replaces the last element" $+    [1, 2, 300] @=? listReplace 3 300 [1, 2, 3],++  testCase "replaces an interior element" $+    [1, 200, 3] @=? listReplace 2 200 [1, 2, 3],++  testCase "replaces multiple elements" $ do+    [1, 0, 3, 4, 0, 0, 3] @=? listReplace 2 0 [1, 2, 3, 4, 2, 2, 3]+    replicate 10 True @=? listReplace False True (replicate 10 False)+  ]++onLeftTests = testGroup "onLeft" [+  testCase "changes a Left" $+    Left 10 @=? onLeft (* 2) (Left 5 :: Either Int ()),++  testCase "doesn't change a Right" $+    Right False @=? onLeft (* 2) (Right False)+  ]++onRightTests = testGroup "onRight" [+  testCase "doesn't change a Left" $+    Left False @=? onRight (* 2) (Left False),++  testCase "changes a Right" $+    Right 10 @=? onRight (* 2) (Right 5 :: Either () Int)+  ]++andEithersTests = testGroup "andEithers" [+  testCase "returns Right for an empty list" $+    Right [] @=? andEithers ([] :: [Either () ()]),++  testCase "returns Right when given all Rights" $ do+    Right [1] @=? andEithers [Right 1 :: Either () Int]+    Right [1, 2] @=? andEithers [Right 1, Right 2 :: Either () Int]+    Right [1, 2, 3] @=? andEithers [Right 1, Right 2, Right 3 :: Either () Int],++  testCase "returns Left when there is a single Left" $ do+    Left [1] @=? andEithers [Left 1 :: Either Int ()]+    Left [1] @=? andEithers [Left 1, Right 2]+    Left [2] @=? andEithers [Right 1, Left 2]+    Left [2] @=? andEithers [Right 1, Left 2, Right 3]+    Left [3] @=? andEithers [Right 1, Right 2, Left 3],++  testCase "returns Left when there are many Lefts" $ do+    Left [1, 2] @=? andEithers [Left 1, Left 2, Right 3]+    Left [1, 3] @=? andEithers [Left 1, Right 2, Left 3]+    Left [2, 3] @=? andEithers [Right 1, Left 2, Left 3]+    Left [1, 2, 3] @=? andEithers [Left 1, Left 2, Left 3 :: Either Int ()]+  ]++forTests = testGroup "for" [+  testCase "passes an empty list through" $+    ([] @=?) =<< sequence (for [] $ const $ assertFailure "Nope."),++  testCase "operates on each element of a list" $+    [2, 2, 4, 6, 10] @=? for [1, 1, 2, 3, 5] (* 2)+  ]++mapTupleTests = testGroup "mapTuple" [+  testCase "updates both values" $+    (9, 16) @=? mapTuple (^ 2) (3, 4)+  ]++whenMaybeTests = testGroup "whenMaybeTests" [+  testCase "doesn't invoke its function when given Nothing" $+    0 @=? State.execState (whenMaybe Nothing $ \x -> State.put (x * 2)) 0,++  testCase "invokes its function when given a Just" $+    6 @=? State.execState (whenMaybe (Just 3) $ \x -> State.put (x * 2)) 0+  ]++condTests = testGroup "cond" [+  testCase "accepts an empty list of cases" $+    True @=? cond True [],++  testCase "returns the default when all cases are false" $ do+    0 @=? cond 0 [(False, 1)]+    0 @=? cond 0 [(False, 1), (False, 2)]+    0 @=? cond 0 [(False, 1), (False, 2), (False, 3)],++  testCase "returns a single true case" $ do+    3 @=? cond 0 [(False, 1), (False, 2), (True, 3)]+    2 @=? cond 0 [(False, 1), (True, 2), (False, 3)]+    1 @=? cond 0 [(True, 1), (False, 2), (False, 3)],++  testCase "returns the first true case" $ do+    3 @=? cond 0 [(False, 1), (False, 2), (True, 3)]+    2 @=? cond 0 [(False, 1), (True, 2), (True, 3)]+    1 @=? cond 0 [(True, 1), (True, 2), (True, 3)]+  ]++if'Tests = testGroup "if'" [+  testCase "detects true" $ "yes" @=? if' "yes" "no" True,++  testCase "detects false" $ "no" @=? if' "yes" "no" False+  ]++andMTests = testGroup "andM" [+  testCase "empty list returns true" $ True @=? runIdentity (andM []),++  testCase "aborts after an immediate true" $ do+    ref <- newIORef 0+    result <- andM [addToRef ref 1 >> return False,+                    addToRef ref 2 >> return True]+    False @=? result+    (1 @=?) =<< readIORef ref,++  testCase "aborts on a false after trues" $ do+    ref <- newIORef 0+    result <- andM [addToRef ref 1 >> return True,+                    addToRef ref 2 >> return True,+                    addToRef ref 4 >> return False,+                    addToRef ref 8 >> return False,+                    addToRef ref 16 >> return False]+    False @=? result+    (7 @=?) =<< readIORef ref,++  testCase "executes all trues" $ do+    ref <- newIORef 0+    result <- andM [addToRef ref 1 >> return True,+                    addToRef ref 2 >> return True,+                    addToRef ref 4 >> return True,+                    addToRef ref 8 >> return True]+    True @=? result+    (15 @=?) =<< readIORef ref+  ]+  where addToRef ref num = modifyIORef ref (+ num)++forIndexM_Tests = testGroup "forIndexM_" [+  testCase "does nothing with an empty list" $+    "" @=? execWriter (forIndexM_ [] $ \_ _ -> tell "x"),++  testCase "iterates over all elements in order" $+    "(0,'a')(1,'b')(2,'c')" @=?+    execWriter (forIndexM_ "abc" $ \index value -> tell $ show (index, value))+  ]++whileMTests = testGroup "whileM" [+  testCase "never executes the body if the first test returns false" $+    "" @=? execWriter (whileM (return False) (tell "x")),++  testCase "executes repeatedly as expected" $+    let test = do n <- get+                  tell $ show n+                  if n > 0+                    then put (n - 1) >> return True+                    else return False+        body = tell "x"+    in "3x2x1x0" @=? execWriter (runStateT (whileM test body) 3)+  ]++whileM'Tests = testGroup "whileM'" [+  testCase "never executes the body if the first test returns Nothing" $+    "" @=? execWriter (whileM' (return Nothing) (const $ tell "x")),++  testCase "executes repeatedly as expected" $+    let test = get >>= \n -> return $ if n > 0 then Just n else Nothing+        body n = do tell $ show n+                    put (n - 1)+    in "321" @=? execWriter (runStateT (whileM' test body) 3)+  ]++doWhileMTests = testGroup "doWhileM" [+  testCase "executes a constantly-Left body once" $ do+    countVar <- newIORef 0+    result <- doWhileM () (const $ do modifyIORef countVar (+ 1)+                                      return $ Left "done")+    count <- readIORef countVar+    (1, "done") @=? (count, result),++  testCase "executes until a Left is returned" $+    execWriter (doWhileM 9 $ \n -> do+                   tell $ show n+                   return $ if n == 0 then Left () else Right $ n - 1)+    @=? "9876543210"+  ]++seqTests = testGroup "Seq" [+  testCase "mempty does nothing" $+    let Seq action = mempty+    in "" @=? execWriter action,++  testCase "mappend works" $+    let Seq action = Seq (tell "a") `mappend` Seq (tell "b")+    in "ab" @=? execWriter action+  ]
+ tests/Game/Goatee/Sgf/BoardTest.hs view
@@ -0,0 +1,195 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.BoardTest (tests) where++import Game.Goatee.Sgf.Board+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.TestInstances ()+import Game.Goatee.Sgf.TestUtils+import Game.Goatee.Sgf.Tree+import Game.Goatee.Sgf.Types+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), (@?=))++tests = testGroup "Game.Goatee.Sgf.Board" [+  boardCoordStateTests,+  moveNumberTests,+  markupPropertiesTests,+  visibilityPropertyTests,+  cursorModifyNodeTests,+  colorToMoveTests+  ]++boardCoordStateTests = testGroup "boardCoordState" [+  testCase "works for a 1x1 board" $ do+    let state = boardCoordState (0,0) $ rootBoardState $+                node [SZ 1 1, CR $ coord1 (0,0)]+    coordStone state @?= Nothing+    coordMark state @?= Just MarkCircle,++  testCase "works for a 2x2 board" $ do+    let board = rootBoardState $+                node [SZ 2 2, B $ Just (0,0), TR $ coord1 (0,0), MA $ coord1 (1,1)]+    coordStone (boardCoordState (0,0) board) @?= Just Black+    coordMark (boardCoordState (0,0) board) @?= Just MarkTriangle+    coordStone (boardCoordState (1,0) board) @?= Nothing+    coordMark (boardCoordState (1,0) board) @?= Nothing+    coordStone (boardCoordState (1,1) board) @?= Nothing+    coordMark (boardCoordState (1,1) board) @?= Just MarkX+  ]+++moveNumberTests = testGroup "move number" [+  testCase "starts at zero" $+    0 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [] $ node [B Nothing]),++  testCase "advances for nodes with moves" $ do+    1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [] $ node [B Nothing])+    1 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [B Nothing] $ node [])+    1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [B Nothing] $ node [])+    2 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $+                           node1 [B Nothing] $ node [W Nothing])+    2 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $+                           node1 [B Nothing] $ node1 [W Nothing] $ node [])+    3 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $+                           node1 [B Nothing] $ node1 [W Nothing] $ node [B Nothing]),++  testCase "doesn't advance for non-move nodes" $ do+    0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $+                           node1 [] $ node [])+    0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $+                           node1 [PL White] $ node [])+    0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $+                           node1 [AB $ coords [(0,0)]] $ node [])+    0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $+                           node1 [IT, TE Double2, GN $ toSimpleText "Title"] $ node [])+  ]++markupPropertiesTests = testGroup "markup properties" [+  testGroup "adds marks to a BoardState" [+    testCase "CR" $ Just MarkCircle @=? getMark 0 0 (rootCursor $ node [CR $ coords [(0,0)]]),+    testCase "MA" $ Just MarkX @=? getMark 0 0 (rootCursor $ node [MA $ coords [(0,0)]]),+    testCase "SL" $ Just MarkSelected @=? getMark 0 0 (rootCursor $ node [SL $ coords [(0,0)]]),+    testCase "SQ" $ Just MarkSquare @=? getMark 0 0 (rootCursor $ node [SQ $ coords [(0,0)]]),+    testCase "TR" $ Just MarkTriangle @=? getMark 0 0 (rootCursor $ node [TR $ coords [(0,0)]]),+    testCase "multiple at once" $ do+      let cursor = rootCursor $ node [SZ 2 2,+                                      CR $ coords [(0,0), (1,1)],+                                      TR $ coords [(1,0)]]+      [[Just MarkCircle, Just MarkTriangle],+       [Nothing, Just MarkCircle]]+        @=? map (map coordMark) (boardCoordStates $ cursorBoard cursor)+    ],++  testGroup "adds more complex annotations to a BoardState" [+    testCase "AR" $ [((0,0), (1,1))] @=? boardArrows (rootCoord $ node [AR [((0,0), (1,1))]]),+    testCase "LB" $ [((0,0), st "Hi")] @=? boardLabels (rootCoord $ node [LB [((0,0), st "Hi")]]),+    testCase "LN" $ [((0,0), (1,1))] @=? boardLines (rootCoord $ node [LN [((0,0), (1,1))]])+    ],++  testCase "clears annotations when moving to a child node" $ do+    let root = node1 [SZ 3 2,+                      CR $ coords [(0,0)],+                      MA $ coords [(1,0)],+                      SL $ coords [(2,0)],+                      SQ $ coords [(0,1)],+                      TR $ coords [(1,1)],+                      AR [((0,0), (2,1))],+                      LB [((2,1), st "Empty")],+                      LN [((1,1), (2,0))]] $+                 node []+        board = cursorBoard $ child 0 $ rootCursor root+    mapM_ (mapM_ ((Nothing @=?) . coordMark)) $ boardCoordStates board+    [] @=? boardArrows board+    [] @=? boardLines board+    [] @=? boardLabels board+  ]+  where rootCoord = cursorBoard . rootCursor+        st = toSimpleText++        getMark :: Int -> Int -> Cursor -> Maybe Mark+        getMark x y cursor = coordMark $ boardCoordStates (cursorBoard cursor) !! y !! x++visibilityPropertyTests = testGroup "visibility properties" [+  testCase "boards start with all points undimmed" $+    replicate 9 (replicate 9 False) @=?+    map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]),++  testCase "DD selectively dims points" $+    let root = node [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]]+    in [[True, True, False, True, False],+        [True, True, False, False, False]] @=?+       map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor root),++  testCase "dimming is inherited" $+    let root = node1 [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] $ node []+    in [[True, True, False, True, False],+        [True, True, False, False, False]] @=?+       map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root),++  testCase "DD[] clears dimming" $+    let root = node1 [SZ 2 1, DD $ coords [(0,0)]] $ node [DD $ coords []]+    in [[False, False]] @=?+       map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root),++  testCase "boards start with all points visible" $+    replicate 9 (replicate 9 True) @=?+    map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]),++  testCase "VW selectively makes points visible" $+    let root = node [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]]+    in [[False, True, True, True, True],+        [True, False, True, True, True]] @=?+       map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor root),++  testCase "visibility is inherited" $+    let root = node1 [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] $ node []+    in [[False, True, True, True, True],+        [True, False, True, True, True]] @=?+       map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root),++  testCase "VW[] clears dimming" $+    let root = node1 [SZ 2 1, VW $ coords [(0,0)]] $ node [VW $ coords []]+    in [[True, True]] @=?+       map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root)+  ]++cursorModifyNodeTests = testGroup "cursorModifyNode" [+  testCase "updates the BoardState" $+    let cursor = child 0 $ rootCursor $+                 node1 [SZ 3 1, B $ Just (0,0)] $+                 node [W $ Just (1,0)]+        modifyProperty prop = case prop of+          W (Just (1,0)) -> W $ Just (2,0)+          _ -> prop+        modifyNode node = node { nodeProperties = map modifyProperty $ nodeProperties node }+        result = cursorModifyNode modifyNode cursor+    in map (map coordStone) (boardCoordStates $ cursorBoard result) @?=+       [[Just Black, Nothing, Just White]]+  ]++colorToMoveTests = testGroup "colorToMove" [+  testCase "creates Black moves" $ do+    B (Just (3,2)) @=? colorToMove Black (3,2)+    B (Just (0,0)) @=? colorToMove Black (0,0),++  testCase "creates White moves" $ do+    W (Just (18,18)) @=? colorToMove White (18,18)+    W (Just (15,16)) @=? colorToMove White (15,16)+  ]
+ tests/Game/Goatee/Sgf/MonadTest.hs view
@@ -0,0 +1,736 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.MonadTest (tests) where++import Control.Applicative ((<$>))+import Control.Arrow ((&&&))+import Control.Monad (forM_, liftM, replicateM_, void)+import Control.Monad.Writer (Writer, execWriter, runWriter, tell)+import Data.List (unfoldr)+import Data.Maybe (fromJust, maybeToList)+import Game.Goatee.Sgf.Board+import Game.Goatee.Sgf.Monad+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.TestInstances ()+import Game.Goatee.Sgf.TestUtils+import Game.Goatee.Sgf.Types+import Game.Goatee.Test.Common+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), (@?=))++{-# ANN module "HLint: ignore Reduce duplication" #-}++type LoggedGoM = GoT (Writer [String])++runLoggedGo :: LoggedGoM a -> Cursor -> (a, Cursor, [String])+runLoggedGo go cursor =+  let ((value, cursor'), log) = runWriter $ runGoT go cursor+  in (value, cursor', log)++tests = testGroup "Game.Goatee.Sgf.Monad" [+  monadTests,+  navigationTests,+  positionStackTests,+  propertiesTests,+  getPropertyTests,+  getPropertyValueTests,+  putPropertyTests,+  deletePropertyTests,+  modifyPropertyTests,+  modifyPropertyValueTests,+  modifyPropertyStringTests,+  modifyPropertyCoordsTests,+  modifyGameInfoTests,+  modifyVariationModeTests,+  getMarkTests,+  modifyMarkTests,+  addChildTests,+  gameInfoChangedTests+  ]++monadTests = testGroup "monad properties" [+  testCase "returns a value it's given" $+    let cursor = rootCursor $ node []+        (value, cursor') = runGo (return 3) cursor+    in (value, cursorNode cursor') @?= (3, cursorNode cursor),++  testCase "getCursor works" $ do+    let cursor = rootCursor nodeA+        nodeA = node1 [SZ 3 3, B $ Just (0,0)] nodeB+        nodeB = node1 [W $ Just (1,1)] nodeC+        nodeC = node [B $ Just (2,2)]+    nodeA @=? evalGo (liftM cursorNode getCursor) cursor+    nodeB @=? evalGo (goDown 0 >> liftM cursorNode getCursor) cursor+    nodeC @=? evalGo (goDown 0 >> goDown 0 >> liftM cursorNode getCursor) cursor,++  testCase "getCoordState works" $ do+    let cursor = child 0 $ child 0 $ rootCursor $+                 node1 [SZ 2 2, B $ Just (0,0)] $+                 node1 [W $ Just (1,0), TR $ coord1 (0,0)] $+                 node [B $ Just (0,1), CR $ coord1 (1,0)]+        action = mapM getCoordState [(0,0), (1,0), (0,1), (1,1)]+        states = evalGo action cursor+    map coordStone states @?= [Just Black, Just White, Just Black, Nothing]+    map coordMark states @?= [Nothing, Just MarkCircle, Nothing, Nothing]+  ]++navigationTests = testGroup "navigation" [+  testCase "navigates down a tree" $+    let cursor = rootCursor $+                 node1 [B $ Just (0,0)] $+                 node' [W $ Just (1,1)] [node [B $ Just (2,2)],+                                         node [B Nothing]]+        action = goDown 0 >> goDown 1+        (_, cursor') = runGo action cursor+    in cursorProperties cursor' @?= [B Nothing],++  testCase "navigates up a tree" $+    let cursor = child 1 $ child 0 $ rootCursor $+                 node1 [B $ Just (0,0)] $+                 node' [W $ Just (1,1)] [node [B $ Just (2,2)],+                                         node [B Nothing]]+        action = goUp >> goUp+        (_, cursor') = runGo action cursor+    in cursorProperties cursor' @?= [B $ Just (0,0)],++  testCase "invokes handlers when navigating" $+    let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing]+        action = do on navigationEvent $ \step -> case step of+                      GoUp index -> tell ["Up " ++ show index]+                      _ -> return ()+                    on navigationEvent $ \step -> case step of+                      GoDown index -> tell ["Down " ++ show index]+                      _ -> return ()+                    goDown 0+                    goUp+        (_, _, log) = runLoggedGo action cursor+    in log @?= ["Down 0", "Up 0"],++  testCase "navigates to the root of a tree, invoking handlers" $ do+    let cursor = child 0 $ child 0 $ rootCursor $+                 node1 [B $ Just (0,0)] $+                 node1 [W $ Just (1,1)] $+                 node [B $ Just (2,2)]+        action = do on navigationEvent $ \step -> tell [show step]+                    goToRoot+        (_, cursor', log) = runLoggedGo action cursor+    cursorProperties cursor' @?= [B $ Just (0,0)]+    log @?= ["GoUp 0", "GoUp 0"],++  testGroup "goToGameInfoNode" [+    testCase "can navigate up to find game info" $+      let props = [PB (toSimpleText ""), B Nothing]+          cursor = child 0 $ rootCursor $ node1 props $ node [W Nothing]+          action = void $ goToGameInfoNode False+      in cursorProperties (execGo action cursor) @?= props,++    testCase "can find game info at the current node" $+      let props = [PB (toSimpleText ""), W Nothing]+          cursor = child 0 $ rootCursor $ node1 [B Nothing] $ node props+          action = void $ goToGameInfoNode False+      in cursorProperties (execGo action cursor) @?= props,++    testCase "doesn't find game info from a subnode" $+      let cursor = child 0 $ rootCursor $+                   node1 [B $ Just (0,0)] $+                   node1 [W $ Just (1,1)] $+                   node [PB (toSimpleText ""), B Nothing]+          action = void $ goToGameInfoNode False+      in cursorProperties (execGo action cursor) @?= [W $ Just (1,1)],++    testCase "can return to the initial node when no game info is found" $+      let cursor = child 0 $ child 0 $ rootCursor $+                   node1 [B $ Just (0,0)] $+                   node1 [W $ Just (1,1)] $+                   node [B $ Just (2,2)]+          action = void $ goToGameInfoNode False+      in cursorProperties (execGo action cursor) @?= [B $ Just (2,2)],++    testCase "can finish at the root node when no game info is found" $+      let cursor = child 0 $ child 0 $ rootCursor $+                   node1 [B $ Just (0,0)] $+                   node1 [W $ Just (1,1)] $+                   node [B $ Just (2,2)]+          action = void $ goToGameInfoNode True+      in cursorProperties (execGo action cursor) @?= [B $ Just (0,0)]+    ]+  ]++positionStackTests = testGroup "position stack" [+  testCase "should push, pop, and drop with no navigation" $ do+    let cursor = rootCursor $ node []+        actions = [pushPosition >> popPosition,+                   pushPosition >> pushPosition >> popPosition >> popPosition,+                   pushPosition >> dropPosition,+                   pushPosition >> pushPosition >> dropPosition >> popPosition,+                   pushPosition >> pushPosition >> popPosition >> dropPosition]+    forM_ actions $ \action -> cursorProperties (execGo action cursor) @?= [],++  testCase "should backtrack up and down the tree" $ do+    let cursor = child 0 $ child 1 $ rootCursor $+                 node' [B $ Just (0,0)]+                       [node1 [W $ Just (1,1)] $ node [B $ Just (2,2)],+                        node1 [W Nothing] $ node [B Nothing]]+        action = pushPosition >> goUp >> goUp >> goDown 0 >> goDown 0+    cursorProperties (execGo (action >> popPosition) cursor) @?= [B Nothing]+    cursorProperties (execGo (action >> dropPosition) cursor) @?= [B $ Just (2,2)],++  testCase "should pop multiple stacks" $ do+    let cursor = child 0 $ child 0 commonCursor+        action = do navigate+                    log >> popPosition+                    log >> popPosition+                    log+    execWriter (runGoT action cursor) @?=+      ["B (2,2)", "B (3,3)", "B (5,5)", "B (3,3)", "B (2,2)"],++  testCase "should drop then pop" $ do+    let cursor = child 0 $ child 0 commonCursor+        action = do navigate+                    log >> dropPosition+                    log >> popPosition+                    log+    execWriter (runGoT action cursor) @?=+      ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (2,2)"],++  testCase "should drop twice" $ do+    let cursor = child 0 $ child 0 commonCursor+        action = do navigate+                    log >> dropPosition+                    log >> dropPosition+                    log+    execWriter (runGoT action cursor) @?=+      ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (5,5)"],++  testCase "should fire navigation handlers while popping" $ do+    let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing]+        action = do pushPosition+                    goDown 0+                    goUp+                    on navigationEvent $ \step -> tell [step]+                    popPosition+    execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0]+  ]+  where commonCursor = rootCursor $+                       node' [B $ Just (0,0)]+                             [node' [W $ Just (1,1)]+                                    [node [B $ Just (2,2)],+                                     node [B $ Just (3,3)]],+                              node1 [W $ Just (4,4)] $ node [B $ Just (5,5)]]+        log = getCursor >>= \cursor -> case cursorProperties cursor of+          [B (Just x)] -> tell ["B " ++ show x]+          [W (Just x)] -> tell ["W " ++ show x]+          xs -> error $ "Unexpected properties: " ++ show xs+        navigate = do log >> pushPosition+                      goUp >> goDown 1+                      log >> pushPosition+                      goUp >> goUp >> goDown 1 >> goDown 0++propertiesTests = testGroup "properties" [+  testGroup "getProperties" [+    testCase "returns an empty list" $+      let cursor = rootCursor $ node []+      in evalGo getProperties cursor @?= [],++    testCase "returns a non-empty list" $+      let properties = [PB $ toSimpleText "Foo", B Nothing]+          cursor = rootCursor $ node properties+      in evalGo getProperties cursor @?= properties+    ],++  testGroup "modifyProperties" [+    testCase "adds properties" $+      let cursor = rootCursor $ node [FF 1]+          action = do modifyProperties $ \props -> return $ props ++ [B Nothing, W Nothing]+                      getProperties+      in evalGo action cursor @?= [FF 1, B Nothing, W Nothing],++    testCase "removes properties" $+      let cursor = rootCursor $ node [W Nothing, FF 1, B Nothing]+          action = do modifyProperties $ \props -> return $ filter (not . isMoveProperty) props+                      getProperties+      in evalGo action cursor @?= [FF 1],++    testCase "fires a properties modified event" $+      let cursor = rootCursor $ node [FF 1]+          action = do on propertiesModifiedEvent $ \old new -> tell [(old, new)]+                      modifyProperties $ const $ return [FF 2]+          log = execWriter (runGoT action cursor)+      in log @?= [([FF 1], [FF 2])]+    ]+  ]+  where isMoveProperty prop = case prop of+          B _ -> True+          W _ -> True+          _ -> False++getPropertyTests = testGroup "getProperty" [+  testCase "doesn't find an unset property" $ do+    Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [])+    Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [B Nothing]),++  testCase "finds a set property" $ do+    Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing])+    Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing, DO])+    Just DO @=? evalGo (getProperty propertyDO) (rootCursor $ node [B Nothing, DO])+  ]++getPropertyValueTests = testGroup "getPropertyValue" [+  testCase "doesn't find an unset property" $ do+    Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [])+    Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [B Nothing]),++  testCase "finds a set property" $ do+    Just Nothing @=? evalGo (getPropertyValue propertyB) (rootCursor $ node [B Nothing])+    Just (Just (0,0)) @=?+      evalGo (getPropertyValue propertyB) (rootCursor $ node [B $ Just (0,0), TE Double1])+    Just Double1 @=?+      evalGo (getPropertyValue propertyTE) (rootCursor $ node [B $ Just (0,0), TE Double1])+  ]++putPropertyTests = testGroup "putProperty" [+  testCase "adds an unset property" $ do+    [IT] @=? cursorProperties (execGo (putProperty IT) $ rootCursor $ node [])+    [DO, IT] @=?+      sortProperties (cursorProperties (execGo (putProperty IT) $ rootCursor $ node [DO])),++  testCase "replaces an existing property" $+    [TE Double2] @=?+    cursorProperties (execGo (putProperty $ TE Double2) (rootCursor $ node [TE Double1]))+  ]++deletePropertyTests = testGroup "deleteProperty" [+  testCase "does nothing when the property isn't set" $ do+    [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [])+    [B Nothing] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [B Nothing]),++  testCase "removes a property" $ do+    [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [DO])+    -- This is documented behaviour for deleteProperty, the fact that it doesn't+    -- matter what the property value is:+    [DO] @=? cursorProperties+      (execGo (deleteProperty $ B $ Just (0,0)) $ rootCursor $ node [DO, B Nothing])+  ]++modifyPropertyTests = testGroup "modifyProperty" [+  testCase "adds a property to an empty node" $+    let cursor = rootCursor $ node []+        action = modifyProperty propertyIT (\Nothing -> Just IT)+    in cursorProperties (execGo action cursor) @?= [IT],++  testCase "adds a property to a non-empty node" $+    let cursor = rootCursor $ node [KO]+        action = modifyProperty propertyIT (\Nothing -> Just IT)+    in sortProperties (cursorProperties $ execGo action cursor) @?= [IT, KO],++  testCase "removes a property" $ do+    let cursor = rootCursor $ node [IT, KO]+        cursor' = execGo (modifyProperty propertyKO $ \(Just KO) -> Nothing) cursor+        cursor'' = execGo (modifyProperty propertyIT $ \(Just IT) -> Nothing) cursor'+    cursorProperties cursor' @?= [IT]+    cursorProperties cursor'' @?= [],++  testCase "updates a property" $ do+    let cursor = rootCursor $ node [B $ Just (0,0), BM Double2]+        action = modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Just $ B $ Just (1,1)+        cursor' = execGo action cursor+        action' = modifyProperty propertyBM $ \(Just (BM Double2)) -> Just $ BM Double1+        cursor'' = execGo action' cursor'+    sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2]+    sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1],++  testCase "fires an event when modifying a property" $ do+    let cursor = rootCursor $ node [B $ Just (0,0)]+        action = do on propertiesModifiedEvent $ \[B (Just (0,0))] [] -> tell [0]+                    modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Nothing+        (cursor', log) = runWriter (execGoT action cursor)+    [0] @=? log+    [] @=? cursorProperties cursor',++  testCase "modifying but not actually changing a property doesn't fire an event" $ do+    let cursor = rootCursor $ node [B $ Just (0,0)]+        action = do on propertiesModifiedEvent $ \_ _ -> tell ["Event fired."]+                    modifyProperty propertyB $ \p@(Just (B {})) -> p+        (cursor', log) = runWriter (execGoT action cursor)+    [B $ Just (0,0)] @=? cursorProperties cursor'+    [] @=? log+  ]++modifyPropertyValueTests = testGroup "modifyPropertyValue" [+  testCase "adds a property to an empty node" $+    let cursor = rootCursor $ node []+        action = modifyPropertyValue propertyPL (\Nothing -> Just Black)+    in cursorProperties (execGo action cursor) @?= [PL Black],++  testCase "adds a property to a non-empty node" $+    let cursor = rootCursor $ node [KO]+        action = modifyPropertyValue propertyPL (\Nothing -> Just White)+    in sortProperties (cursorProperties $ execGo action cursor) @?= [KO, PL White],++  testCase "removes a property" $ do+    let cursor = rootCursor $ node [B Nothing, TE Double2]+        cursor' = execGo (modifyPropertyValue propertyTE $ \(Just Double2) -> Nothing) cursor+        cursor'' = execGo (modifyPropertyValue propertyB $ \(Just Nothing) -> Nothing) cursor'+    cursorProperties cursor' @?= [B Nothing]+    cursorProperties cursor'' @?= [],++  testCase "updates a property" $ do+    let cursor = rootCursor $ node [B $ Just (0,0), BM Double2]+        action = modifyPropertyValue propertyB $ \(Just (Just (0,0))) -> Just $ Just (1,1)+        cursor' = execGo action cursor+        action' = modifyPropertyValue propertyBM $ \(Just Double2) -> Just Double1+        cursor'' = execGo action' cursor'+    sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2]+    sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1]+  ]++modifyPropertyStringTests =+  testGroup "modifyPropertyString"+  -- Test a Text property and a SimpleText property.+  (assumptions ++ genTests "comment" propertyC ++ genTests "game name" propertyGN)+  where assumptions = let _ = C $ toText ""+                          _ = GN $ toSimpleText ""+                      in []+        genTests name property = [+          testCase ("adds a " ++ name) $+            let cursor = rootCursor $ node []+                action = modifyPropertyString property (++ "Hello.")+            in cursorProperties (execGo action cursor) @?=+               [propertyBuilder property $ stringToSgf "Hello."],++          testCase ("removes a " ++ name) $+            let cursor = rootCursor $ node [propertyBuilder property $ stringToSgf "Hello."]+                action = modifyPropertyString property $ \value -> case value of+                  "Hello." -> ""+                  other -> error $ "Got: " ++ other+            in cursorProperties (execGo action cursor) @?= [],++          testCase ("updates a " ++ name) $+            let cursor = child 0 $ rootCursor $+                         node1 [propertyBuilder property $ stringToSgf "one"] $+                         node [propertyBuilder property $ stringToSgf "two"]+                action = modifyPropertyString property $ \value -> case value of+                  "two" -> "three"+                  other -> error $ "Got: " ++ other+                cursor' = execGo action cursor+            in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?=+               ([propertyBuilder property $ stringToSgf "three"],+                [propertyBuilder property $ stringToSgf "one"]),++          testCase "leaves a non-existant comment" $+            let result = execGo (modifyPropertyString property id) $ rootCursor $ node []+            in cursorProperties result @?= []+          ]++modifyPropertyCoordsTests = testGroup "modifyPropertyCoords" [+  testCase "adds a property where there was none" $+    let cursor = rootCursor $ node []+        action = modifyPropertyCoords propertySL $ \[] -> [(0,0), (1,1)]+    in [SL $ coords [(0,0), (1,1)]] @=? cursorProperties (execGo action cursor),++  testCase "removes a property where there was one" $+    let cursor = rootCursor $ node [TR $ coord1 (5,5)]+        action = modifyPropertyCoords propertyTR $ \[(5,5)] -> []+    in [] @=? cursorProperties (execGo action cursor),++  testCase "modifies an existing property" $+    let cursor = rootCursor $ node [CR $ coord1 (3,4)]+        action = modifyPropertyCoords propertyCR $ \[(3,4)] -> [(2,2)]+    in [CR $ coord1 (2,2)] @=? cursorProperties (execGo action cursor),++  testCase "doesn't affect other properties" $+    let cursor = rootCursor $ node [SQ $ coord1 (0,0), MA $ coord1 (1,1)]+        action = modifyPropertyCoords propertyMA $ \[(1,1)] -> [(2,2)]+    in [MA $ coord1 (2,2), SQ $ coord1 (0,0)] @=?+       sortProperties (cursorProperties $ execGo action cursor)+  ]++modifyGameInfoTests = testGroup "modifyGameInfo" [+  testGroup "creates info on the root node, starting with none" [+     testCase "starting from the root node" $+       let cursor = rootCursor $ node []+           action = modifyGameInfo (\info -> info { gameInfoGameName = Just "Orange" })+       in cursorProperties (execGo action cursor) @?= [GN $ toSimpleText "Orange"],++     testCase "starting from a non-root node" $+       let cursor = child 0 $ rootCursor $ node1 [] $ node [B Nothing]+           action = modifyGameInfo (\info -> info { gameInfoGameName = Just "Orange" })+           cursor' = execGo action cursor+       in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?=+          ([B Nothing], [GN $ toSimpleText "Orange"])+     ],++  testGroup "modifies existing info on the root" [+    testCase "starting from the root node" $+      let cursor = rootCursor $ node [GN $ toSimpleText "Orange"]+          action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing+                                                 , gameInfoBlackName = Just "Peanut butter"+                                                 })+      in cursorProperties (execGo action cursor) @?= [PB $ toSimpleText "Peanut butter"],++    testCase "starting from a non-root node" $+      let cursor = child 0 $ rootCursor $ node1 [GN $ toSimpleText "Orange"] $ node [B Nothing]+          action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing+                                                 , gameInfoBlackName = Just "Peanut butter"+                                                 })+          cursor' = execGo action cursor+      in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?=+         ([B Nothing], [PB $ toSimpleText "Peanut butter"])+    ],++  testCase "moves game info from a non-root node to the root" $+    let cursor = child 0 $ child 0 $ child 0 $ rootCursor $+                 node1 [SZ 19 19] $+                 node1 [B $ Just (0,0), GN $ toSimpleText "Orange"] $+                 node1 [W $ Just (1,1)] $+                 node [B $ Just (2,2)]+        action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing })+        cursor' = execGo action cursor+        action' = modifyGameInfo (\info -> info { gameInfoBlackName = Just "Peanut butter" })+        cursor'' = execGo action' cursor'+        -- unfoldr :: (Maybe Cursor -> Maybe ([Property], Maybe Cursor))+        --         -> Maybe Cursor+        --         -> [[Property]]+        properties = unfoldr (fmap $ cursorProperties &&& cursorParent)+                             (Just cursor'')+    in map sortProperties properties @?=+       [[B $ Just (2,2)],+        [W $ Just (1,1)],+        [B $ Just (0,0)],+        [PB $ toSimpleText "Peanut butter", SZ 19 19]]+  ]++modifyVariationModeTests = testGroup "modifyVariationMode" [+  testCase "testing modes are not default" $ do+    defaultVariationMode @/=? mode+    defaultVariationMode @/=? mode2,++  testCase "modifies when at a root node" $+    node1 [ST mode] (node []) @=?+    cursorNode (execGo setMode $ rootCursor $ node1 [] $ node []),++  testCase "modifies when at a non-root node" $+    node1 [ST mode] (node []) @=?+    cursorNode (cursorRoot $ execGo setMode $ child 0 $ rootCursor $ node1 [] $ node []),++  testCase "leaves an unset ST unset" $+    assertST Nothing Nothing $ const defaultVariationMode,++  testCase "leaves a default ST alone" $+    assertST (Just defaultVariationMode) (Just defaultVariationMode) $ const defaultVariationMode,++  testCase "leaves an existing ST alone" $+    assertST (Just mode) (Just mode) $ const mode,++  testCase "adds an ST property" $+    assertST (Just mode) Nothing $ const mode,++  testCase "removes an ST property when setting to default" $+    assertST Nothing (Just mode) $ const defaultVariationMode,++  testCase "modifies an existing ST property" $+    assertST (Just mode2) (Just mode) $ const mode2+  ]+  where mode = VariationMode ShowCurrentVariations True+        mode2 = VariationMode ShowChildVariations False+        setMode = modifyVariationMode $ const mode+        assertST maybeExpectedST maybeInitialST fn =+          node (ST <$> maybeToList maybeExpectedST) @=?+          cursorNode (execGo (modifyVariationMode fn) $+                      rootCursor $ node $ ST <$> maybeToList maybeInitialST)++getMarkTests = testGroup "getMark" [+  testCase "returns Nothing for no mark" $ do+    Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [])+    Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [W $ Just (0,0)]),++  testCase "returns Just when a mark is present" $ do+    Just MarkSquare @=? evalGo (getMark (1,2)) (rootCursor $ node [SQ $ coord1 (1,2)])+    Just MarkTriangle @=? evalGo (getMark (1,1)) (rootCursor $ node [B $ Just (1,1),+                                                                     TR $ coord1 (1,1),+                                                                     SQ $ coord1 (1,2)]),++  testCase "matches all marks" $ forM_ [minBound..maxBound] $ \mark ->+    Just mark @=?+    evalGo (getMark (0,0))+           (rootCursor $ node [propertyBuilder (markProperty mark) $ coord1 (0,0)])+  ]++modifyMarkTests = testGroup "modifyMark" [+  testCase "creates a mark where there was none" $+    let cursor = rootCursor $ node []+        action = do modifyMark (\Nothing -> Just MarkX) (0,0)+                    getMark (0,0)+    in Just MarkX @=? evalGo action cursor,++  testCase "removes an existing mark" $+    let cursor = rootCursor $ node [CR $ coord1 (0,0)]+        action = do modifyMark (\(Just MarkCircle) -> Nothing) (0,0)+                    getMark (0,0)+    in Nothing @=? evalGo action cursor,++  testCase "replaces an existing mark" $+    let cursor = rootCursor $ node [CR $ coord1 (0,0)]+        action = do modifyMark (\(Just MarkCircle) -> Just MarkX) (0,0)+                    getMark (0,0)+    in Just MarkX @=? evalGo action cursor,++  testCase "adds on to an existing mark property" $+    let cursor = rootCursor $ node [MA $ coord1 (0,0)]+        action = do modifyMark (\Nothing -> Just MarkX) (1,0)+                    mapM getMark [(0,0), (1,0)]+    in [Just MarkX, Just MarkX] @=? evalGo action cursor,++  testCase "removes from an existing mark property" $+    let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]]+        action = do modifyMark (\(Just MarkX) -> Nothing) (1,0)+                    modifyMark (\(Just MarkX) -> Nothing) (0,1)+                    mapM getMark [(0,0), (1,0), (0,1)]+    in [Just MarkX, Nothing, Nothing] @=? evalGo action cursor,++  testCase "removes and adds at the same time" $+    let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]]+        action = do modifyMark (\(Just MarkX) -> Just MarkSquare) (0,0)+                    modifyMark (\(Just MarkX) -> Nothing) (0,1)+                    mapM getMark [(0,0), (1,0), (0,1)]+    in [Just MarkSquare, Just MarkX, Nothing] @=? evalGo action cursor+  ]++addChildTests = testGroup "addChild" [+  testCase "adds an only child" $+    cursorNode (execGo (addChild 0 $ node [B Nothing]) (rootCursor $ node []))+    @?= node' [] [node [B Nothing]],++  testCase "adds a first child" $+    cursorNode (execGo (addChild 0 $ node [B $ Just (0,0)])+                       (rootCursor $ node' [] [node [B $ Just (1,1)]]))+    @?= node' [] [node [B $ Just (0,0)],+                  node [B $ Just (1,1)]],++  testCase "adds a middle child" $+    cursorNode (execGo (addChild 1 $ node [B $ Just (1,1)])+                       (rootCursor $ node' [] [node [B $ Just (0,0)],+                                               node [B $ Just (2,2)]]))+    @?= node' [] [node [B $ Just (0,0)],+                  node [B $ Just (1,1)],+                  node [B $ Just (2,2)]],++  testCase "adds a last child" $+    cursorNode (execGo (addChild 2 $ node [B $ Just (2,2)])+                       (rootCursor $ node' [] [node [B $ Just (0,0)],+                                               node [B $ Just (1,1)]]))+    @?= node' [] [node [B $ Just (0,0)],+                  node [B $ Just (1,1)],+                  node [B $ Just (2,2)]],++  testGroup "path stack correctness" [+    testCase "basic case just not needing updating" $+      let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]]+          action = do pushPosition+                      goUp+                      addChild 1 $ node [W $ Just (0,0)]+                      popPosition+      in cursorNode (execGo action cursor) @?= node [W Nothing],++    testCase "basic case just needing updating" $+      let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]]+          action = do pushPosition+                      goUp+                      addChild 0 $ node [W $ Just (0,0)]+                      popPosition+      in cursorNode (execGo action cursor) @?= node [W Nothing],++    testCase "basic case definitely needing updating" $+      let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)],+                                                   node [W $ Just (1,1)]]+          action = do goDown 1+                      pushPosition+                      goUp+                      addChild 0 $ node [W Nothing]+                      popPosition+      in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)],++    testCase "multiple paths to update" $+      let at y x = B $ Just (y,x)+          level0Node = node' [at 0 0] $ map level1Node [0..1]+          level1Node i = node' [at 1 i] $ map level2Node [0..2]+          level2Node i = node' [at 2 i] $ map level3Node [0..3]+          level3Node i = node [at 3 i]+          action = do goDown 1 >> goDown 2 >> goDown 3+                      pushPosition+                      replicateM_ 4 goUp+                      goDown 1 >> goDown 2 >> goDown 2 >> goUp >> goDown 1+                      addChild 0 $ node' [] [node []]+                      goDown 0 >> goDown 0+                      goToRoot+                      popPosition+      in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)],++    testCase "updates paths with GoUp correctly" $+      let cursor = rootCursor $ node1 [B $ Just (0,0)] $ node [W $ Just (1,1)]+          action = do pushPosition+                      goDown 0+                      goUp+                      addChild 0 $ node [B $ Just (2,2)]+                      on navigationEvent $ \step -> tell [step]+                      popPosition+          (_, log) = runWriter (runGoT action cursor)+      in log @?= [GoDown 1, GoUp 1]+    ]+  ]++gameInfoChangedTests = testGroup "gameInfoChangedEvent" [+  testCase "fires when navigating down" $+    let cursor = rootCursor $+                 node1 [B $ Just (0,0)] $+                 node [W $ Just (0,0), GN $ toSimpleText "Foo"]+        action = do on gameInfoChangedEvent onInfo+                    goDown 0+    in execWriter (runGoT action cursor) @?= [(Nothing, Just "Foo")],++  testCase "fires when navigating up" $+    let cursor = child 0 $ rootCursor $+                 node1 [B $ Just (0,0)] $+                 node [W $ Just (0,0), GN $ toSimpleText "Foo"]+        action = do on gameInfoChangedEvent onInfo+                    goUp+    in execWriter (runGoT action cursor) @?= [(Just "Foo", Nothing)],++  testCase "fires from within popPosition" $+    let cursor = rootCursor $+                 node1 [B $ Just (0,0)] $+                 node [W $ Just (0,0), GN $ toSimpleText "Foo"]+        action = do pushPosition+                    goDown 0+                    goUp+                    on gameInfoChangedEvent onInfo+                    popPosition+    in execWriter (runGoT action cursor) @?=+       [(Nothing, Just "Foo"), (Just "Foo", Nothing)],++  testCase "fires when modifying properties" $+    let cursor = rootCursor $ node []+        action = do on gameInfoChangedEvent onInfo+                    modifyProperties $ const $ return [GN $ toSimpleText "Foo"]+                    modifyProperties $ const $ return [GN $ toSimpleText "Bar"]+                    modifyProperties $ const $ return []+    in execWriter (runGoT action cursor) @?=+       [(Nothing, Just "Foo"), (Just "Foo", Just "Bar"), (Just "Bar", Nothing)]+  ]+  where onInfo old new = tell [(gameInfoGameName old, gameInfoGameName new)]
+ tests/Game/Goatee/Sgf/ParserTest.hs view
@@ -0,0 +1,242 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.ParserTest (tests) where++import Control.Monad (forM_)+import Game.Goatee.Sgf.ParserTestUtils+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.TestInstances ()+import Game.Goatee.Sgf.TestUtils+import Game.Goatee.Sgf.Tree+import Game.Goatee.Sgf.Types+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++tests = testGroup "Game.Goatee.Sgf.Parser" [+  baseCaseTests,+  whitespaceTests,+  passConversionTests,+  movePropertyTests,+  setupPropertyTests,+  nodeAnnotationPropertyTests,+  moveAnnotationPropertyTests,+  rootPropertyTests+  ]++baseCaseTests = testGroup "base cases" [+  testCase "works with the trivial collection" $+    parseOrFail "(;)" (@?= emptyNode),++  testCase "works with only a size property" $ do+    parseOrFail "(;SZ[1])" (@?= root 1 1 [] [])+    parseOrFail "(;SZ[9])" (@?= root 9 9 [] [])+  ]++whitespaceTests = testGroup "whitespace handling" [+  testCase "parses with no extra whitespace" $+    parseOrFail "(;SZ[4];AB[aa][bb]AW[cc];W[dd])"+    (@?= root 4 4 [] [node1 [AB $ coords [(0,0), (1,1)], AW $ coords [(2,2)]] $+                      node [W $ Just (3,3)]]),++  testCase "parses with spaces between nodes" $+    parseOrFail "(;SZ[1] ;B[])" (@?= root 1 1 [] [node [B Nothing]]),++  testCase "parses with spaces between properties" $+    parseOrFail "(;SZ[1] AB[aa])" (@?= root 1 1 [AB $ coords [(0,0)]] []),++  testCase "parses with spaces between a property's name and value" $+    parseOrFail "(;SZ [1])" (@?= root 1 1 [] []),++  testCase "parses with spaces between property values" $+    parseOrFail "(;SZ[2]AB[aa] [bb])" (@?= root 2 2 [AB $ coords [(0,0), (1,1)]] []),++  testCase "parses with spaces between many elements" $+    parseOrFail " ( ; SZ [4] ; AB [aa:ad] [bb] AW [cc] ; W [dd] ; B [] ) "+    (@?= root 4 4 [] [node1 [AB $ coords' [(1,1)] [((0,0), (0,3))],+                             AW $ coords [(2,2)]] $+                      node1 [W $ Just (3,3)] $+                      node [B Nothing]])++  -- TODO Test handling of whitespace between an unknown property name and+  -- [value].+  ]++passConversionTests = testGroup "B[tt]/W[tt] pass conversion" [+  testCase "converts B[tt] for a board sizes <=19x19" $ do+    parseOrFail "(;SZ[1];B[tt])" (@?= root 1 1 [] [node [B Nothing]])+    parseOrFail "(;SZ[9];B[tt])" (@?= root 9 9 [] [node [B Nothing]])+    parseOrFail "(;SZ[19];B[tt])" (@?= root 19 19 [] [node [B Nothing]]),++  testCase "converts W[tt] for a board sizes <=19x19" $ do+    parseOrFail "(;SZ[1];W[tt])" (@?= root 1 1 [] [node [W Nothing]])+    parseOrFail "(;SZ[9];W[tt])" (@?= root 9 9 [] [node [W Nothing]])+    parseOrFail "(;SZ[19];W[tt])" (@?= root 19 19 [] [node [W Nothing]]),++  testCase "doesn't convert B[tt] for a board sizes >19x19" $ do+    parseOrFail "(;SZ[20];B[tt])" (@?= root 20 20 [] [node [B $ Just (19, 19)]])+    parseOrFail "(;SZ[21];B[tt])" (@?= root 21 21 [] [node [B $ Just (19, 19)]]),++  testCase "doesn't convert W[tt] for a board sizes >19x19" $ do+    parseOrFail "(;SZ[20];W[tt])" (@?= root 20 20 [] [node [W $ Just (19, 19)]])+    parseOrFail "(;SZ[21];W[tt])" (@?= root 21 21 [] [node [W $ Just (19, 19)]]),++  testCase "doesn't convert non-move properties" $ do+    -- TODO These should error, rather than parsing fine.+    parseOrFail "(;SZ[9];AB[tt])" (@?= root 9 9 [] [node [AB $ coords [(19, 19)]]])+    parseOrFail "(;SZ[9];TR[tt])" (@?= root 9 9 [] [node [TR $ coords [(19, 19)]]])+  ]++movePropertyTests = testGroup "move properties" [+  testGroup "B" [+    testCase "parses moves" $ do+      parseOrFail "(;B[aa])" (@?= node [B $ Just (0, 0)])+      parseOrFail "(;B[cp])" (@?= node [B $ Just (2, 15)]),+    testCase "parses passes" $+      parseOrFail "(;B[])" (@?= node [B Nothing])+    ],+  testCase "KO parses" $+    parseOrFail "(;KO[])" (@?= node [KO]),+  -- TODO Test MN (assert positive).+  testGroup "W" [+    testCase "parses moves" $ do+      parseOrFail "(;W[aa])" (@?= node [W $ Just (0, 0)])+      parseOrFail "(;W[cp])" (@?= node [W $ Just (2, 15)]),+    testCase "parses passes" $+      parseOrFail "(;W[])" (@?= node [W Nothing])+    ]+  ]++setupPropertyTests = testGroup "setup properties" [+  testCase "AB parses" $ do+    parseOrFail "(;AB[ab])" (@?= node [AB $ coords [(0, 1)]])+    parseOrFail "(;AB[ab][cd:ef])" (@?= node [AB $ coords' [(0, 1)] [((2, 3), (4, 5))]]),+  testCase "AE parses" $ do+    parseOrFail "(;AE[ae])" (@?= node [AE $ coords [(0, 4)]])+    parseOrFail "(;AE[ae][ff:gg])" (@?= node [AE $ coords' [(0, 4)] [((5, 5), (6, 6))]]),+  testCase "AW parses" $ do+    parseOrFail "(;AW[aw])" (@?= node [AW $ coords [(0, 22)]])+    parseOrFail "(;AW[aw][xy:yz])" (@?= node [AW $ coords' [(0, 22)] [((23, 24), (24, 25))]]),+  testCase "PL parses" $ do+    parseOrFail "(;PL[B])" (@?= node [PL Black])+    parseOrFail "(;PL[W])" (@?= node [PL White])+  ]++nodeAnnotationPropertyTests = testGroup "node annotation properties" [+  testCase "C parses" $+    parseOrFail "(;C[Me [30k\\]: What is White doing??\\\n\n:(])"+      (@?= node [C $ toText "Me [30k]: What is White doing??\n:("]),+  testCase "DM parses" $ do+    parseOrFail "(;DM[1])" (@?= node [DM Double1])+    parseOrFail "(;DM[2])" (@?= node [DM Double2]),+  testCase "GB parses" $ do+    parseOrFail "(;GB[1])" (@?= node [GB Double1])+    parseOrFail "(;GB[2])" (@?= node [GB Double2]),+  testCase "GW parses" $ do+    parseOrFail "(;GW[1])" (@?= node [GW Double1])+    parseOrFail "(;GW[2])" (@?= node [GW Double2]),+  testCase "HO parses" $ do+    parseOrFail "(;HO[1])" (@?= node [HO Double1])+    parseOrFail "(;HO[2])" (@?= node [HO Double2]),+  testCase "N parses" $+    parseOrFail "(;N[The best\\\n\nmove])" (@?= node [N $ toSimpleText "The best move"]),+  testCase "UC parses" $ do+    parseOrFail "(;UC[1])" (@?= node [UC Double1])+    parseOrFail "(;UC[2])" (@?= node [UC Double2]),+  testCase "V parses" $ do+    parseOrFail "(;V[-34.5])" (@?= node [V (-34.5)])+    parseOrFail "(;V[50])" (@?= node [V 50])+  ]++moveAnnotationPropertyTests = testGroup "move annotation properties" [+  testCase "BM parses" $ do+    parseOrFail "(;BM[1])" (@?= node [BM Double1])+    parseOrFail "(;BM[2])" (@?= node [BM Double2]),+  testCase "DO parses" $+    parseOrFail "(;DO[])" (@?= node [DO]),+  testCase "IT parses" $+    parseOrFail "(;IT[])" (@?= node [IT]),+  testCase "TE parses" $ do+    parseOrFail "(;TE[1])" (@?= node [TE Double1])+    parseOrFail "(;TE[2])" (@?= node [TE Double2])+  ]++-- TODO Test markup properties.++rootPropertyTests = testGroup "root properties" [+  testCase "AP parses" $+    parseOrFail "(;AP[GoGoGo:1.2.3])"+    (@?= node [AP (toSimpleText "GoGoGo") (toSimpleText "1.2.3")]),+  testCase "CA parses" $ do+    parseOrFail "(;CA[UTF-8])" (@?= node [CA $ toSimpleText "UTF-8"])+    parseOrFail "(;CA[ISO-8859-1])" (@?= node [CA $ toSimpleText "ISO-8859-1"]),+  testGroup "FF" [+    testCase "accepts version 4" $+      parseOrFail "(;FF[4])" (@?= node [FF 4]),+    testCase "rejects versions 1-3" $ do+      parseAndFail "(;FF[1])"+      parseAndFail "(;FF[2])"+      parseAndFail "(;FF[3])"+    ],+  testGroup "GM" [+    testCase "parses 1 (Go)" $+      parseOrFail "(;GM[1])" (@?= node [GM 1]),+    testCase "rejects unsupported games" $+      forM_ [2..16] $ \x -> parseAndFail $ "(;GM[" ++ show x ++ "]"+    ],+  testGroup "ST" [+    testCase "parses valid variation modes" $ do+      parseOrFail "(;ST[0])" (@?= node [ST $ VariationMode ShowChildVariations True])+      parseOrFail "(;ST[1])" (@?= node [ST $ VariationMode ShowCurrentVariations True])+      parseOrFail "(;ST[2])" (@?= node [ST $ VariationMode ShowChildVariations False])+      parseOrFail "(;ST[3])" (@?= node [ST $ VariationMode ShowCurrentVariations False]),+    testCase "rejects invalid variation modes" $+      forM_ [4..10] $ \x -> parseAndFail $ "(;ST[" ++ show x ++ "]"+    ],+  testGroup "SZ" [+    testCase "parses square boards" $+      forM_ [1..52] $ \x ->+        parseOrFail ("(;SZ[" ++ show x ++ "])") (@?= node [SZ x x]),+    testCase "parses nonsquare boards" $ do+      parseOrFail "(;SZ[1:2])" (@?= node [SZ 1 2])+      parseOrFail "(;SZ[1:9])" (@?= node [SZ 1 9])+      parseOrFail "(;SZ[1:19])" (@?= node [SZ 1 19])+      parseOrFail "(;SZ[2:1])" (@?= node [SZ 2 1])+      parseOrFail "(;SZ[9:1])" (@?= node [SZ 9 1])+      parseOrFail "(;SZ[19:1])" (@?= node [SZ 19 1])+      parseOrFail "(;SZ[19:52])" (@?= node [SZ 19 52])+      parseOrFail "(;SZ[10:16])" (@?= node [SZ 10 16]),+    testCase "rejects invalid sizes" $ do+      -- Boards must have length at least 1...+      parseAndFail "(;SZ[0])"+      parseAndFail "(;SZ[-1])"+      -- ...and at most 52.+      parseAndFail "(;SZ[53])"+      parseAndFail "(;SZ[54])"+      parseAndFail "(;SZ[0:19])"+      parseAndFail "(;SZ[19:0])"+      parseAndFail "(;SZ[9:53])"+      parseAndFail "(;SZ[53:9])",+    -- This is specified by the SGF spec:+    testCase "rejects square boards defined with two numbers" $ do+      parseAndFail "(;SZ[1:1])"+      parseAndFail "(;SZ[19:19])"+    ]+  ]++-- TODO Test the test of the properties.
+ tests/Game/Goatee/Sgf/ParserTestUtils.hs view
@@ -0,0 +1,63 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.ParserTestUtils (+  parseOrFail,+  parseAndFail,+  assertParse,+  assertNoParse,+  ) where++import Control.Applicative ((<*))+import Game.Goatee.Sgf.Parser+import Game.Goatee.Sgf.Tree+import Test.HUnit (assertFailure)+import Text.ParserCombinators.Parsec (Parser, eof, parse)++-- Parses a string as a complete SGF document.  On success, executes the+-- continuation function with the result.  Otherwise, causes an assertion+-- failure.+parseOrFail :: String -> (Node -> IO ()) -> IO ()+parseOrFail input cont = case parseString input of+  Left error -> assertFailure $ "Failed to parse SGF: " ++ error+  Right (Collection roots) -> case roots of+    root:[] -> cont root+    _ -> assertFailure $ "Expected a single root node, got: " ++ show roots++-- Parses a string as a complete SGF document and expects failure.+parseAndFail :: String -> IO ()+parseAndFail input = case parseString input of+  Left _ -> return ()+  Right result -> assertFailure $ "Expected " ++ show input +++                  " not to parse.  Parsed to " ++ show result ++ "."++-- Parses a string using the given parser and expects the parser to consume the+-- entire input.  On success, executes the continuation function with the+-- result.  Otherwise, causes an assertion failure.+assertParse :: Parser a -> String -> (a -> IO ()) -> IO ()+assertParse parser input cont = case parse (parser <* eof) "<assertParse>" input of+  Left error -> assertFailure $ "Failed to parse: " ++ show error+  Right result -> cont result++-- Tries to parse a string using the given parser.  If the parse succeeds then+-- this function causes an assertion failure, otherwise this function succeeds.+assertNoParse :: Show a => Parser a -> String -> IO ()+assertNoParse parser input = case parse (parser <* eof) "<assertNoParse>" input of+  Left _ -> return ()+  Right result -> assertFailure $+                  "Expected " ++ show input ++ " not to parse.  " +++                  "Parsed to " ++ show result ++ "."
+ tests/Game/Goatee/Sgf/Property/ParserTest.hs view
@@ -0,0 +1,391 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.Property.ParserTest (tests) where++import Control.Applicative ((<$>))+import Control.Monad (forM_)+import Data.Maybe (catMaybes)+import Game.Goatee.Common+import Game.Goatee.Sgf.ParserTestUtils+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Property.Parser+import Game.Goatee.Sgf.TestInstances ()+import Game.Goatee.Sgf.TestUtils+import Game.Goatee.Sgf.Types+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))+import Text.ParserCombinators.Parsec (Parser)++tests = testGroup "Game.Goatee.Sgf.Property.ParserTest" [+  -- Tests for public parsers.+  parserColorTests,+  parserDoubleTests,+  parserGameResultTests,+  parserIntegralTests,+  parserMoveTests,+  parserRealTests,+  parserRulesetTests,+  parserSizeTests,+  parserVariationModeTests,+  -- Tests for private parsers.+  lineTests,+  simpleTextTests,+  simpleTextComposedTests,+  textTests,+  textComposedTests,+  -- Miscellaneous tests.+  propertyValueArityTests+  ]++parserColorTests = testGroup "colorParser" [+  testCase "parses B" $ assertParse colorParser "[B]" (@?= Black),+  testCase "parses W" $ assertParse colorParser "[W]" (@?= White)+  ]++parserDoubleTests = testGroup "doubleParser" [+  testCase "parses 1" $ assertParse doubleParser "[1]" (@?= Double1),+  testCase "parses 2" $ assertParse doubleParser "[2]" (@?= Double2)+  ]++parserGameResultTests = testGroup "gameResultParser" [+  testCase "draw" $ do+    assertParse gameResultParser "[0]" (@?= GameResultDraw)+    assertParse gameResultParser "[Draw]" (@?= GameResultDraw),++  testCase "void" $+    assertParse gameResultParser "[Void]" (@?= GameResultVoid),++  testCase "unknown" $+    assertParse gameResultParser "[?]" (@?= GameResultUnknown),++  testCase "Black wins by points" $ do+    assertParse gameResultParser "[B+0.5]" (@?= GameResultWin Black (WinByScore 0.5))+    assertParse gameResultParser "[B+11]" (@?= GameResultWin Black (WinByScore 11))+    assertParse gameResultParser "[B+354.5]" (@?= GameResultWin Black (WinByScore 354.5)),++  testCase "Black wins by resignation" $ do+    assertParse gameResultParser "[B+R]" (@?= GameResultWin Black WinByResignation)+    assertParse gameResultParser "[B+Resign]" (@?= GameResultWin Black WinByResignation),++  testCase "Black wins on time" $ do+    assertParse gameResultParser "[B+T]" (@?= GameResultWin Black WinByTime)+    assertParse gameResultParser "[B+Time]" (@?= GameResultWin Black WinByTime),++  testCase "Black wins by forfeit" $ do+    assertParse gameResultParser "[B+F]" (@?= GameResultWin Black WinByForfeit)+    assertParse gameResultParser "[B+Forfeit]" (@?= GameResultWin Black WinByForfeit),++  testCase "White wins by points" $ do+    assertParse gameResultParser "[W+0.5]" (@?= GameResultWin White (WinByScore 0.5))+    assertParse gameResultParser "[W+11]" (@?= GameResultWin White (WinByScore 11))+    assertParse gameResultParser "[W+354.5]" (@?= GameResultWin White (WinByScore 354.5)),++  testCase "White wins by resignation" $ do+    assertParse gameResultParser "[W+R]" (@?= GameResultWin White WinByResignation)+    assertParse gameResultParser "[W+Resign]" (@?= GameResultWin White WinByResignation),++  testCase "White wins on time" $ do+    assertParse gameResultParser "[W+T]" (@?= GameResultWin White WinByTime)+    assertParse gameResultParser "[W+Time]" (@?= GameResultWin White WinByTime),++  testCase "White wins by forfeit" $ do+    assertParse gameResultParser "[W+F]" (@?= GameResultWin White WinByForfeit)+    assertParse gameResultParser "[W+Forfeit]" (@?= GameResultWin White WinByForfeit),++  testCase "custom game results" $ do+    assertParseToOther ""+    assertParseToOther "Everyone wins."+    assertParseToOther "W+Nuclear tesuji"+    assertParseToOther "B+Flamingo"+  ]+  where assertParseToOther input =+          assertParse gameResultParser ('[' : input ++ "]")+          (@?= GameResultOther (toSimpleText input))++parserIntegralTests = testGroup "integralParser" $ integerTestsFor integralParser++parserMoveTests = testGroup "moveParser" $ coordTestsFor moveParser Just ++ [+  testCase "parses an empty move as a pass" $ assertParse moveParser "[]" (@?= Nothing)+  ]++parserRealTests = testGroup "realParser" $ integerTestsFor realParser ++ [+  testCase "parses a decimal zero" $ assertParse realParser "[0.0]" (@?= 0),++  testCase "parses fractional positive numbers" $ do+    assertParse realParser "[0.5]" (@?= (1/2))+    assertParse realParser "[0.00125]" (@?= (1/800))+    assertParse realParser "[3.14]" (@?= (314/100))+    assertParse realParser "[10.0]" (@?= 10),++  testCase "parses fractional negative numbers" $ do+    assertParse realParser "[-0.5]" (@?= (-1/2))+    assertParse realParser "[-0.00125]" (@?= (-1/800))+    assertParse realParser "[-3.14]" (@?= (-314/100))+    assertParse realParser "[-10.0]" (@?= (-10))+  ]++parserRulesetTests = testGroup "rulesetParser" [+  testCase "parses known rules" $ do+    assertParse rulesetParser "[AGA]" (@?= KnownRuleset RulesetAga)+    assertParse rulesetParser "[Goe]" (@?= KnownRuleset RulesetIng)+    assertParse rulesetParser "[Japanese]" (@?= KnownRuleset RulesetJapanese)+    assertParse rulesetParser "[NZ]" (@?= KnownRuleset RulesetNewZealand),++  testCase "parses unknown rules" $ do+    assertParse rulesetParser "[Foo]" (@?= UnknownRuleset "Foo")+    assertParse rulesetParser "[First capture]" (@?= UnknownRuleset "First capture")+  ]++parserSizeTests = testGroup "size" [+  testCase "parses square boards" $ do+    assertParse sizeParser "[1]" (@?= (1, 1))+    assertParse sizeParser "[4]" (@?= (4, 4))+    assertParse sizeParser "[9]" (@?= (9, 9))+    assertParse sizeParser "[19]" (@?= (19, 19))+    assertParse sizeParser "[52]" (@?= (52, 52)),++  testCase "parses rectangular boards" $ do+    assertParse sizeParser "[1:2]" (@?= (1, 2))+    assertParse sizeParser "[9:5]" (@?= (9, 5))+    assertParse sizeParser "[19:9]" (@?= (19, 9)),++  testCase "rejects boards of non-positive size" $ do+    assertNoParse sizeParser "[0]"+    assertNoParse sizeParser "[-1]"+    assertNoParse sizeParser "[0:5]"+    assertNoParse sizeParser "[5:0]"+    assertNoParse sizeParser "[0:-2]",++  testCase "rejects square boards given in rectangular format" $ do+    assertNoParse sizeParser "[1:1]"+    assertNoParse sizeParser "[13:13]"+  ]++parserVariationModeTests = testGroup "variationModeParser" [+  testCase "mode 0" $+    assertParse variationModeParser "[0]" (@?= VariationMode ShowChildVariations True),++  testCase "mode 1" $+    assertParse variationModeParser "[1]" (@?= VariationMode ShowCurrentVariations True),++  testCase "mode 2" $+    assertParse variationModeParser "[2]" (@?= VariationMode ShowChildVariations False),++  testCase "mode 3" $+    assertParse variationModeParser "[3]" (@?= VariationMode ShowCurrentVariations False)+  ]++lineTests = testGroup "line" [+  testCase "parses all valid values" $ do+     let cases = zip (['a'..'z'] ++ ['A'..'Z']) [0..]+     forM_ cases $ \(char, expected) ->+       assertParse line [char] (@?= expected)+  ]++simpleTextTests = testGroup "simpleText" $+  textTestsFor simpleText fromSimpleText False +++  textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText False)++simpleTextComposedTests = testGroup "simpleText composed" $+  textTestsFor simpleText fromSimpleText True +++  textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText True)++textTests = testGroup "text" $+  textTestsFor text id False +++  textUnescapedNewlinePreservingTests (text False)++textComposedTests = testGroup "text composed" $+  textTestsFor text id True +++  textUnescapedNewlinePreservingTests (text True)++propertyValueArityTests = testGroup "property value arities" [+  testGroup "single values (single)" [+    testCase "accepts a property that requires a single number" $+      parseOrFail "(;SZ[1])" (@?= node [SZ 1 1]),++    testCase "accepts a property that requires a single point" $+      parseOrFail "(;B[dd])" (@?= node [B $ Just (3, 3)])+    ],++  testGroup "lists (listOf)" [+    testCase "doesn't accept an empty list" $+      parseAndFail "(;AR[])",++    testCase "accepts a single value" $+      parseOrFail "(;AR[aa:bb])" (@?= node [AR [((0, 0), (1, 1))]]),++    testCase "accepts two values" $+      parseOrFail "(;AR[aa:bb][cc:de])" (@?= node [AR [((0, 0), (1, 1)),+                                                       ((2, 2), (3, 4))]])+    ],++  testGroup "point lists (listOfPoint)" [+    testCase "doesn't accept an empty list" $+      parseAndFail "(;AB[])",++    testCase "accepts a single point" $+      parseOrFail "(;AB[aa])" (@?= node [AB $ coords [(0, 0)]]),++    testCase "accepts two points" $+      parseOrFail "(;AB[aa][bb])" (@?= node [AB $ coords [(0, 0), (1, 1)]]),++    testCase "accepts a rectangle" $+      parseOrFail "(;AB[aa:bb])" (@?= node [AB $ coords' [] [((0, 0), (1, 1))]]),++    testCase "accepts two rectangles" $+      parseOrFail "(;AB[aa:bb][cd:de])" (@?= node [AB $ coords' [] [((0, 0), (1, 1)),+                                                                    ((2, 3), (3, 4))]])+    ],++  testGroup "point elists (elistOfPoint)" [+    testCase "accepts an empty list" $+      parseOrFail "(;VW[])" (@?= node [VW $ coords []]),++    testCase "accepts single points" $+      parseOrFail "(;VW[aa][bb])" (@?= node [VW $ coords [(0, 0), (1, 1)]]),++    testCase "accepts a rectangle" $+      parseOrFail "(;VW[aa:bb])" (@?= node [VW $ coords' [] [((0, 0), (1, 1))]]),++    testCase "accepts two rectangles" $+      parseOrFail "(;VW[aa:bb][cc:dd])" (@?= node [VW $ coords' [] [((0, 0), (1, 1)),+                                                                    ((2, 2), (3, 3))]])+    ]++  -- TODO Test that invalid rectangles such as cd:dc fail to parse (or rather,+  -- get corrected with a warning).+  ]++integerTestsFor :: (Eq a, Num a, Show a) => Parser a -> [Test]+integerTestsFor parser = [+  testCase "parses 0" $ do+    assertParse parser "[0]" (@?= 0)+    assertParse parser "[+0]" (@?= 0)+    assertParse parser "[-0]" (@?= 0),++  testCase "parses positive integers" $ do+    assertParse parser "[1]" (@?= 1)+    assertParse parser "[20]" (@?= 20)+    assertParse parser "[4294967296]" (@?= (2 ^ 32))+    assertParse parser "[18446744073709551616]" (@?= (2 ^ 64)),++  testCase "parses positive integers with the plus sign" $ do+    assertParse parser "[+1]" (@?= 1)+    assertParse parser "[+20]" (@?= 20)+    assertParse parser "[+4294967296]" (@?= (2 ^ 32))+    assertParse parser "[+18446744073709551616]" (@?= (2 ^ 64)),++  testCase "parses negative integers" $ do+    assertParse parser "[-1]" (@?= (-1))+    assertParse parser "[-20]" (@?= (-20))+    assertParse parser "[-4294967296]" (@?= (- (2 ^ 32)))+    assertParse parser "[-18446744073709551616]" (@?= (- (2 ^ 64)))+  ]++coordTestsFor :: (Eq a, Show a) => Parser a -> (Coord -> a) -> [Test]+coordTestsFor parser f = [+  testCase "parses boundary points" $ do+    assertParse parser "[aa]" (@?= f (0, 0))+    assertParse parser "[zz]" (@?= f (25, 25))+    assertParse parser "[AA]" (@?= f (26, 26))+    assertParse parser "[ZZ]" (@?= f (51, 51)),++  testCase "parses coordinate order correctly" $ do+    assertParse parser "[ab]" (@?= f (0, 1))+    assertParse parser "[ba]" (@?= f (1, 0)),++  testCase "doesn't parse a partial point" $+    assertNoParse parser "[a]"+  ]++textTestsFor :: (Bool -> Parser a) -> (a -> String) -> Bool -> [Test]+textTestsFor makeParser toString testComposed =+  let rawParser = makeParser testComposed+      parser = toString <$> rawParser+      composedParser = mapTuple toString <$> compose rawParser rawParser+  in catMaybes [+    Just $ testCase "parses an empty string" $+      assertParse parser "" (@?= ""),++    Just $ testCase "parses a short string" $+      assertParse parser "Hello, world." (@?= "Hello, world."),++    Just $ testCase "preserves leading and trailing whitespace" $+      assertParse parser " \tHi. \t" (@?= "  Hi.  "),++    Just $ testCase "parses escaped backslashes" $ do+      assertParse parser "\\\\" (@?= "\\")+      assertParse parser "\\\\\\\\" (@?= "\\\\")+      assertNoParse parser "\\"+      assertNoParse parser "\\\\\\",++    Just $ testCase "parses escaped ']'s" $ do+      assertParse parser "\\]" (@?= "]")+      assertParse parser "\\]\\\\\\]" (@?= "]\\]"),++    Just $ if testComposed+           then testCase "parses escaped ':'s" $ do+             assertParse parser "\\:" (@?= ":")+             assertParse parser "\\:\\\\\\:" (@?= ":\\:")+             assertNoParse parser ":"+           else testCase "parses unescaped ':'s" $ do+             assertParse parser ":" (@?= ":")+             assertParse parser "::" (@?= "::")+             -- An escaped colon should parse just the same.+             assertParse parser "\\:" (@?= ":"),++    if not testComposed+      then Nothing+      else Just $ testCase "supports composed values" $ do+        assertParse composedParser ":" (@?= ("", ""))+        assertParse composedParser "a:" (@?= ("a", ""))+        assertParse composedParser ":z" (@?= ("", "z"))+        assertParse composedParser "a:z" (@?= ("a", "z"))+        assertParse composedParser "a\\\\:z" (@?= ("a\\", "z"))+        assertParse composedParser "a\\:b:y\\:z" (@?= ("a:b", "y:z"))+        assertNoParse composedParser "",++    -- Tests non-newline whitespace replacement.  Newline handling is+    -- specific to individual parsers.+    Just $ testCase "replaces whitespace with spaces" $+      assertParse parser "\t\r\f\v" (@?= "    "),++    Just $ testCase "removes escaped newlines" $ do+      assertParse parser "\\\n" (@?= "")+      assertParse parser "foo\\\nbar" (@?= "foobar")+      assertParse parser "foo \\\n bar" (@?= "foo  bar")+    ]++textUnescapedNewlinePreservingTests :: Parser String -> [Test]+textUnescapedNewlinePreservingTests parser = [+  testCase "preserves unescaped newlines" $ do+    assertParse parser "\n" (@?= "\n")+    assertParse parser "\n\n" (@?= "\n\n")+    assertParse parser "foo\nbar" (@?= "foo\nbar")+    assertParse parser "foo \n bar" (@?= "foo \n bar")+  ]++textUnescapedNewlineConvertingTests :: Parser String -> [Test]+textUnescapedNewlineConvertingTests parser = [+  testCase "converts unescaped newlines to spaces" $ do+    assertParse parser "\n" (@?= " ")+    assertParse parser "\n\n" (@?= "  ")+    assertParse parser "foo\nbar" (@?= "foo bar")+    assertParse parser "foo \n bar" (@?= "foo   bar")+  ]
+ tests/Game/Goatee/Sgf/PropertyTest.hs view
@@ -0,0 +1,74 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.PropertyTest (tests) where++import qualified Data.Set as Set+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Types+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))++tests = testGroup "Game.Goatee.Sgf.Property" [+  propertyMetadataTests,+  markPropertyTests+  ]++propertyMetadataTests = testGroup "property metadata" [+  testCase "game info properties" $ gameInfoProperties @=? filterTo GameInfoProperty allProperties,+  testCase "general properties" $ generalProperties @=? filterTo GeneralProperty allProperties,+  testCase "move properties" $ moveProperties @=? filterTo MoveProperty allProperties,+  testCase "root properties" $ rootProperties @=? filterTo RootProperty allProperties,+  testCase "setup properties" $ setupProperties @=? filterTo SetupProperty allProperties,++  testCase "inherited properties" $ [DD cl] @=? filter propertyInherited allProperties+  ]+  where filterTo propType = filter ((propType ==) . propertyType)+        moveProperties = [-- Move properties.+                          B Nothing, KO, MN 1, W Nothing,+                          -- Move annotation properties.+                          BM db, DO, IT, TE db]+        setupProperties = [-- Setup properties.+                           AB cl, AE cl, AW cl, PL Black]+        generalProperties = [-- Node annotation properties.+                             C tx, DM db, GB db, GW db, HO db, N st, UC db, V rv,+                             -- Markup properties.+                             AR [], CR cl, DD cl, LB [], LN [], MA cl, SL cl, SQ cl, TR cl,+                             -- Guess this fits here.+                             UnknownProperty "" (toUnknownPropertyValue "")]+        rootProperties = [-- Root properties.+                          AP st st, CA st, FF 1, GM 1, ST vm, SZ 1 1]+        gameInfoProperties = [-- Game info properties.+                              AN st, BR st, BT st, CP st, DT st, EV st, GC st, GN st, ON st, OT st,+                              PB st, PC st, PW st, RE GameResultVoid, RO st, RU ru,+                              SO st, TM rv, US st, WR st, WT st]+        allProperties = moveProperties ++ setupProperties ++ generalProperties +++                        rootProperties ++ gameInfoProperties+        cl = emptyCoordList+        db = Double1+        tx = toText ""+        st = toSimpleText ""+        ru = KnownRuleset RulesetJapanese+        rv = 1+        vm = defaultVariationMode++markPropertyTests = testGroup "markProperty" [+  testCase "doesn't repeat properties" $+    let marks = [minBound..maxBound]+    in length marks @=? Set.size (Set.fromList $ map (propertyName . markProperty) marks)+  ]
+ tests/Game/Goatee/Sgf/RoundTripTest.hs view
@@ -0,0 +1,85 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.RoundTripTest (tests) where++import Data.Function (on)+import Game.Goatee.Common+import Game.Goatee.Sgf.Parser+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Renderer+import Game.Goatee.Sgf.Renderer.Tree+import Game.Goatee.Sgf.TestUtils+import Game.Goatee.Sgf.Tree+import Game.Goatee.Sgf.Types+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=), Assertion, assertFailure)++testCollection' :: Collection -> Assertion+testCollection' collection =+  case runRender $ renderCollection collection of+    Left message -> assertFailure $ "Failed to render: " ++ message+    Right serialized ->+      case parseString serialized of+        Left error -> assertFailure $ "Failed to parse: " ++ error +++                      "\n\nEntire SGF: " ++ serialized+        Right collection' -> do+          on (@?=) CollectionWithDeepEquality collection' collection+          case runRender $ renderCollection collection' of+            Left message -> assertFailure $ "Second render failed: " ++ message+            Right serializedAgain -> serializedAgain @?= serialized++-- | Returns an assertion that the given node round-trips okay.+testNode' :: Node -> Assertion+testNode' = testCollection' . Collection . (:[])++-- | Returns a test with the given string name that round-trips a single node.+testNode :: String -> Node -> Test+testNode label node = testCase label $ testNode' node++tests = testGroup "Game.Goatee.Sgf.RoundTripTest" [+  singleNodeGameTests,+  propertyValueTests+  ]++singleNodeGameTests = testGroup "games with single nodes" [+  testNode "empty game" $ node [],+  testNode "some default properties" $ node [FF 4, GM 1, ST defaultVariationMode]+  ]++propertyValueTests = testGroup "property value types" [+  testGroup "label list values" [+    testNode "one value" $ node [LB [((5,2), toSimpleText "Hi.")]],+    testNode "multiple value" $ node [LB [((5, 2), toSimpleText "Hi."),+                                          ((0, 1), toSimpleText "Bye.")]]+    ],++  testGroup "point-valued values" $+    for [0..boardSizeMax-1]+    (\row -> testNode ("row " ++ show row) $ node [B $ Just (0, row)]) +++    for [0..boardSizeMax-1]+    (\col -> testNode ("row " ++ show col) $ node [B $ Just (col, 0)]),++  testGroup "real values" [+    testNode "1500" $ node [TM 1500],+    testNode "60.5" $ node [TM 60.5],+    testNode "10.1" $ node [TM 10.1]+    ]+  ]++-- TODO Many more round-trip tests.
+ tests/Game/Goatee/Sgf/TestInstances.hs view
@@ -0,0 +1,25 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Test utilities for working with the SGF modules.+module Game.Goatee.Sgf.TestInstances () where++import Data.Function (on)+import Game.Goatee.Sgf.Tree (Node, NodeWithDeepEquality(NodeWithDeepEquality))++instance Eq Node where+  (==) = (==) `on` NodeWithDeepEquality
+ tests/Game/Goatee/Sgf/TestUtils.hs view
@@ -0,0 +1,61 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Test utilities for working with the SGF modules.+module Game.Goatee.Sgf.TestUtils (+  node,+  node1,+  node',+  root,+  child,+  sortProperties,+  ) where++import Data.Function (on)+import Data.List (sortBy)+import Game.Goatee.Sgf.Board+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.Tree++node :: [Property] -> Node+node props = emptyNode { nodeProperties = props }++node1 :: [Property] -> Node -> Node+node1 props child = emptyNode { nodeProperties = props+                              , nodeChildren = [child]+                              }++node' :: [Property] -> [Node] -> Node+node' props children = emptyNode { nodeProperties = props+                                , nodeChildren = children+                                }++-- | Creates a root node that starts with only a 'SZ' property.  This is more+-- minimal than 'rootNode'.+root :: Int -> Int -> [Property] -> [Node] -> Node+root width height props =+  foldr addChild $ foldr addProperty emptyNode (SZ width height:props)++child :: Int -> Cursor -> Cursor+child = flip cursorChild++-- | Sorts properties by their 'Show' strings, for use in tests that need to+-- check an unordered list of properties.+--+-- TODO Probably better to have a compare-unordered operator.+sortProperties :: [Property] -> [Property]+sortProperties = sortBy (compare `on` show)
+ tests/Game/Goatee/Sgf/TreeTest.hs view
@@ -0,0 +1,114 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.TreeTest (tests) where++import Data.Version (showVersion)+import Game.Goatee.App (applicationName)+import Game.Goatee.Sgf.Property+import Game.Goatee.Sgf.TestInstances ()+import Game.Goatee.Sgf.Tree+import Game.Goatee.Sgf.Types+import Game.Goatee.Test.Common+import Paths_goatee (version)+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), (@?=))++tests = testGroup "Game.Goatee.Sgf.Tree" [+  emptyNodeTests,+  rootNodeTests,+  findPropertyTests,+  addPropertyTests,+  addChildTests+  ]++emptyNodeTests = testGroup "emptyNode" [+  testCase "has no properties" $ [] @=? nodeProperties emptyNode,+  testCase "has no children" $ [] @=? nodeChildren emptyNode+  ]++rootNodeTests = testGroup "rootNode" [+  testCase "sets SZ correctly" $ do+    assertElem (SZ 9 9) $ nodeProperties $ rootNode $ Just (9, 9)+    assertElem (SZ 19 19) $ nodeProperties $ rootNode $ Just (19, 19)+    assertElem (SZ 9 5) $ nodeProperties $ rootNode $ Just (9, 5),++  testCase "sets AP correctly" $ do+    let ap = AP (toSimpleText applicationName)+                (toSimpleText $ showVersion version)+    assertElem ap $ nodeProperties $ rootNode Nothing+    assertElem ap $ nodeProperties $ rootNode $ Just (9, 9)+  ]++findPropertyTests = testGroup "findProperty" [+  testCase "returns Nothing for an empty node" $+    Nothing @=? findProperty propertyB (mk []),++  testCase "returns Nothing if no properties match" $+    Nothing @=? findProperty propertyB (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]),++  testCase "finds present properties" $ do+     Just (B (Just (2,3))) @=?+       findProperty propertyB (mk [B (Just (2,3))])+     Just (W Nothing) @=?+       findProperty propertyW (mk [B Nothing, W Nothing])+     Just IT @=?+       findProperty propertyIT (mk [IT, GW Double2])+     Just (GW Double2) @=?+       findProperty propertyGW (mk [IT, GW Double2]),++  testCase "doesn't find absent properties" $ do+    Nothing @=? findProperty propertyW (mk [B Nothing])+    Nothing @=? findProperty propertyW (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9])+  ]+  where mk properties = emptyNode { nodeProperties = properties }++addPropertyTests = testGroup "addProperty" [+  testCase "adds properties in order" $ do+    let prop1 = B (Just (6,6))+        prop2 = RE GameResultVoid+        prop3 = C (toText "Game over.")+        node1 = addProperty prop1 emptyNode+        node2 = addProperty prop2 node1+        node3 = addProperty prop3 node2+    node1 @?= emptyNode { nodeProperties = [prop1] }+    node2 @?= emptyNode { nodeProperties = [prop1, prop2] }+    node3 @?= emptyNode { nodeProperties = [prop1, prop2, prop3] }+  ]++addChildTests = testGroup "addChild" [+  testCase "adds children in order" $ do+    let node1 = emptyNode { nodeProperties = [B (Just (0,0))] }+        node2 = emptyNode { nodeProperties = [W (Just (1,1))] }+        node3 = emptyNode { nodeProperties = [B (Just (2,2))] }+        node4 = emptyNode { nodeProperties = [W Nothing] }+        node2' = addChild node3 node2+        node1' = addChild node2' node1+        node1'' = addChild node4 node1'+    node1'' @?= mk [B (Just (0,0))]+                   [mk [W (Just (1,1))]+                       [mk [B (Just (2,2))]+                           []],+                    mk [W Nothing]+                       []]+  ]+  where mk properties children = emptyNode { nodeProperties = properties+                                           , nodeChildren = children+                                           }++-- TODO Test validateNode.
+ tests/Game/Goatee/Sgf/TypesTest.hs view
@@ -0,0 +1,146 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Game.Goatee.Sgf.TypesTest (tests) where++import Data.List (sort)+import Game.Goatee.Sgf.Types+import Game.Goatee.Test.Common+import Test.Framework (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), Assertion)++tests = testGroup "Game.Goatee.Sgf.Types" [+  expandCoordListTests,+  buildCoordListTests,+  simpleTextTests,+  cnotTests+  ]++expandCoordListTests = testGroup "expandCoordList" [+  testCase "works with an empty CoordList" $ do+    [] @=? expandCoordList (coords [])+    [] @=? expandCoordList (coords' [] []),++  testCase "works for single points" $ do+    [(1,2)] @=? expandCoordList (coord1 (1,2))+    [(3,4), (1,2)] @=? expandCoordList (coords [(3,4), (1,2)])+    let ten = [(i,i) | i <- [1..10]]+    ten @=? expandCoordList (coords ten),++  -- TODO Test that a 1x1 rectangle is rejected.++  testCase "works for a nx1 rect" $+    [(5,2), (5,3), (5,4)] @=? expandCoordList (coords' [] [((5,2), (5,4))]),++  testCase "works for a 1xn rect" $+    [(1,0), (1,1), (1,2), (1,3)] @=? expandCoordList (coords' [] [((1,0), (1,3))]),++  testCase "works for an mxn rect" $+    [(m,n) | m <- [2..5], n <- [3..7]] @=?+    expandCoordList (coords' [] [((2,3), (5,7))]),++  -- TODO Test that x0 > x1 || y0 > y1 is rejected.++  testCase "works with multiple rects" $+    [(0,0), (0,1), (0,2), (3,4), (4,4), (5,4)] @=?+    expandCoordList (coords' [] [((0,0), (0,2)), ((3,4), (5,4))]),++  testCase "concatenates single points and rects" $+    [(1,1), (0,0), (2,2), (2,3), (2,4)] @=?+    expandCoordList (coords' [(1,1), (0,0)] [((2,2), (2,4))])+  ]++buildCoordListTests = testGroup "buildCoordList" [+  testCase "handles the empty case" $ assertSinglesAndRects [] [] [],++  testCase "handles one single" $+    assertSinglesAndRects [(0,1)] [] [(0,1)],++  testCase "handles multiple singles" $+    assertSinglesAndRects [(0,0), (1,1)] [] [(0,0), (1,1)],++  testCase "handles a small rect (1x2)" $+    assertSinglesAndRects [] [((0,1), (0,2))] [(0,1), (0,2)],++  testCase "handles a small square (2x2)" $+    assertSinglesAndRects [] [((1,1), (2,2))] [(x,y) | x <- [1..2], y <- [1..2]],++  testCase "handles a larger rect" $+    assertSinglesAndRects [] [((0,0), (2,4))] [(x,y) | x <- [0..2], y <- [0..4]],++  testCase "handles two rects" $+    assertSinglesAndRects [] [((0,1), (1,2)), ((3,0), (4,1))]+    [(0,1), (1,1), (0,2), (1,2), (3,0), (4,0), (3,1), (4,1)],++  testCase "handles rects and singles together" $+    assertSinglesAndRects [(0,0)] [((1,1), (2,2))]+    [(0,0), (1,1), (1,2), (2,1), (2,2)],++  testCase "handles five points together" $ do+    assertCoords [(1,0), (0,1), (1,1), (0,2), (1,2)]+    assertCoords [(0,0), (1,0), (0,1), (1,1), (0,2)]+    assertCoords [(0,0), (1,0), (2,0), (0,1), (1,1)]+    assertCoords [(1,0), (2,0), (0,1), (1,1), (2,1)],++  testCase "handles a more complex case" $+    assertCoords [(3,0), (4,0),+                  (3,1), (4,1),+                  (0,2), (1,2), (2,2), (3,2), (4,2),+                  (0,3), (1,3),+                  (0,4), (1,4), (3,4), (4,4)],++  testCase "handles a diagonal pattern" $+    assertCoords [(0,0), (2,0), (4,0),+                  (1,1), (3,1), (5,1),+                  (2,2)]+  ]+  where -- | Asserts that the given grid of booleans parses to a 'CoordList'+        -- that has the expected single points (not necessarily in the same+        -- order), as well as the expected rectangles (not necessarily in the+        -- same order).+        assertSinglesAndRects :: [Coord] -> [(Coord, Coord)] -> [Coord] -> Assertion+        assertSinglesAndRects expectedSingles expectedRects input =+          coords' expectedSingles expectedRects @=? buildCoordList input++        -- | Asserts that the set of points returned from applying+        -- 'buildCoordList' to the given grid of booleans is equal to+        -- the given set of points.+        assertCoords :: [Coord] -> Assertion+        assertCoords input = sort input @=? sort (expandCoordList $ buildCoordList input)++simpleTextTests = testGroup "SimpleText" [+  testCase "accepts the empty string" $+    "" @=? fromSimpleText (toSimpleText ""),++  testCase "passes through strings without newlines" $ do+    "Hello." @=? fromSimpleText (toSimpleText "Hello.")+    "Bad for B." @=? fromSimpleText (toSimpleText "Bad for B.")+    "[4k?]" @=? fromSimpleText (toSimpleText "[4k?]")+    printableAsciiChars @=? fromSimpleText (toSimpleText printableAsciiChars),++  testCase "converts newlines to spaces" $ do+    " " @=? fromSimpleText (toSimpleText "\n")+    "Hello, world." @=? fromSimpleText (toSimpleText "Hello,\nworld.")+    "Hello,   world." @=? fromSimpleText (toSimpleText "Hello, \n world.")+    " Hello, world. " @=? fromSimpleText (toSimpleText "\nHello, world.\n")+  ]++cnotTests = testGroup "cnot" [+  testCase "changes Black to White" $ White @=? cnot Black,+  testCase "changes White to Black" $ Black @=? cnot White+  ]
+ tests/Game/Goatee/Test/Common.hs view
@@ -0,0 +1,47 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Common utilities for testing code.+module Game.Goatee.Test.Common (+  (@/=?),+  assertElem,+  printableAsciiChars,+  ) where++import Control.Monad (unless, when)+import Test.HUnit (Assertion, assertFailure)++-- | Asserts that two values are not equal.  Typically, the left argument is a+-- constant value that the right, computed argument should not equal, to mirror+-- '@=?'.+(@/=?) :: (Eq a, Show a) => a -> a -> Assertion+notExpected @/=? actual =+  when (notExpected == actual) $ assertFailure $+  let notExpected' = show notExpected+      actual' = show actual+  in if actual' == notExpected'+     then "did not expect: " ++ actual'+     else "      this value: " ++ actual' +++          "\nshould not equal: " ++ notExpected'++assertElem :: (Eq a, Show a) => a -> [a] -> Assertion+assertElem item list =+  unless (item `elem` list) $ assertFailure $+    "Expected to find " ++ show item ++ " in the list " ++ show list ++ "."++printableAsciiChars :: String+printableAsciiChars = [' '..'~']
+ tests/Test.hs view
@@ -0,0 +1,43 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee 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.+--+-- Goatee 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 Goatee.  If not, see <http://www.gnu.org/licenses/>.++module Main (main) where++import qualified Game.Goatee.CommonTest+import qualified Game.Goatee.Sgf.BoardTest+import qualified Game.Goatee.Sgf.MonadTest+import qualified Game.Goatee.Sgf.ParserTest+import qualified Game.Goatee.Sgf.Property.ParserTest+import qualified Game.Goatee.Sgf.PropertyTest+import qualified Game.Goatee.Sgf.RoundTripTest+import qualified Game.Goatee.Sgf.TreeTest+import qualified Game.Goatee.Sgf.TypesTest+import Test.Framework (defaultMain)++tests = [ Game.Goatee.CommonTest.tests+        , Game.Goatee.Sgf.BoardTest.tests+        , Game.Goatee.Sgf.MonadTest.tests+        , Game.Goatee.Sgf.ParserTest.tests+        , Game.Goatee.Sgf.Property.ParserTest.tests+        , Game.Goatee.Sgf.PropertyTest.tests+        , Game.Goatee.Sgf.RoundTripTest.tests+        , Game.Goatee.Sgf.TreeTest.tests+        , Game.Goatee.Sgf.TypesTest.tests+        ]++main :: IO ()+main = defaultMain tests