diff --git a/CHANGELOG.txt b/CHANGELOG.txt
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.txt
@@ -0,0 +1,24 @@
+Changelog ideas-1.3.1 => ideas.1.4
+-----------------------------------------------------------------------------
+
+* refactoring of strategies
+ - strategies are now represented cyclic trees (that preserve fixpoints)
+ - new strategy combinators can be defined outside the framework
+ - simpler interfaces: no more Builder, Step, and Core datatypes
+ - nice speed-up for constructing and running strategies
+
+* support for new database schema (v2) with more columns
+ - request can have an optional 'logging' attribute (false, v1, v2)
+ - command-line flag for seeing information that is logged
+ - userid, sessionid, and taskid are stored in a state
+
+* changing license to Apache License version 2.0 (was: GPL)
+* renaming strategy combinators (eg .*.) to solve clash with Applicative.<*>
+* adding SyntaxError constructor to Diagnose datatype
+* added read instance for Difficulty
+* changed newline and tab escaping in JSON
+* re-implemented atomic combinator
+* introduced inits combinator (initial prefixes) and atomic prefix (!~>)
+* introduced somewhereWhen traversal combinator
+* added cabal flag to resolve dependency on network >= 2.6
+* added cabal flag to enable support for logging
diff --git a/CREDITS.txt b/CREDITS.txt
deleted file mode 100644
--- a/CREDITS.txt
+++ /dev/null
@@ -1,15 +0,0 @@
-AUTHORS
-
-Bastiaan Heeren, Alex Gerdes, Johan Jeuring
-
-CREDITS
-
-Harrie Passier, Arthur van Leeuwen, Josje Lodder, Hieke Keuning
-
-
-This package contains a verbatim copy of the cgi-3001.2.2.0 package, with
-minor modifications to resolve conflicting dependencies. The original package,
-together with its BSD3 license and further information about copyright, author
-and maintainer, can be found at:
-
- http://hackage.haskell.org/package/cgi-3001.2.2.0
diff --git a/LICENSE.txt b/LICENSE.txt
--- a/LICENSE.txt
+++ b/LICENSE.txt
@@ -1,674 +1,202 @@
- GNU GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
- Copyright (C) 2007 Free Software Foundation, Inc.
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
- The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works. By contrast,
-the GNU General Public License is intended to guarantee your freedom to
-share and change all versions of a program--to make sure it remains free
-software for all its users. We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors. You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-them if you wish), that you receive source code or can get it if you
-want it, that you can change the software or use pieces of it in new
-free programs, and that you know you can do these things.
-
- To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights. Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received. You must make sure that they, too, receive
-or can get the source code. And you must show them these terms so they
-know their rights.
-
- Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
- For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software. For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
- Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so. This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software. The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable. Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products. If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
- Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary. To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- TERMS AND CONDITIONS
-
- 0. Definitions.
-
- "This License" refers to version 3 of the GNU General Public License.
-
- "Copyright" also means copyright-like laws that apply to other kinds of
-works, such as semiconductor masks.
-
- "The Program" refers to any copyrightable work licensed under this
-License. Each licensee is addressed as "you". "Licensees" and
-"recipients" may be individuals or organizations.
-
- To "modify" a work means to copy from or adapt all or part of the work
-in a fashion requiring copyright permission, other than the making of an
-exact copy. The resulting work is called a "modified version" of the
-earlier work or a work "based on" the earlier work.
-
- A "covered work" means either the unmodified Program or a work based
-on the Program.
-
- To "propagate" a work means to do anything with it that, without
-permission, would make you directly or secondarily liable for
-infringement under applicable copyright law, except executing it on a
-computer or modifying a private copy. Propagation includes copying,
-distribution (with or without modification), making available to the
-public, and in some countries other activities as well.
-
- To "convey" a work means any kind of propagation that enables other
-parties to make or receive copies. Mere interaction with a user through
-a computer network, with no transfer of a copy, is not conveying.
-
- An interactive user interface displays "Appropriate Legal Notices"
-to the extent that it includes a convenient and prominently visible
-feature that (1) displays an appropriate copyright notice, and (2)
-tells the user that there is no warranty for the work (except to the
-extent that warranties are provided), that licensees may convey the
-work under this License, and how to view a copy of this License. If
-the interface presents a list of user commands or options, such as a
-menu, a prominent item in the list meets this criterion.
-
- 1. Source Code.
-
- The "source code" for a work means the preferred form of the work
-for making modifications to it. "Object code" means any non-source
-form of a work.
-
- A "Standard Interface" means an interface that either is an official
-standard defined by a recognized standards body, or, in the case of
-interfaces specified for a particular programming language, one that
-is widely used among developers working in that language.
-
- The "System Libraries" of an executable work include anything, other
-than the work as a whole, that (a) is included in the normal form of
-packaging a Major Component, but which is not part of that Major
-Component, and (b) serves only to enable use of the work with that
-Major Component, or to implement a Standard Interface for which an
-implementation is available to the public in source code form. A
-"Major Component", in this context, means a major essential component
-(kernel, window system, and so on) of the specific operating system
-(if any) on which the executable work runs, or a compiler used to
-produce the work, or an object code interpreter used to run it.
-
- The "Corresponding Source" for a work in object code form means all
-the source code needed to generate, install, and (for an executable
-work) run the object code and to modify the work, including scripts to
-control those activities. However, it does not include the work's
-System Libraries, or general-purpose tools or generally available free
-programs which are used unmodified in performing those activities but
-which are not part of the work. For example, Corresponding Source
-includes interface definition files associated with source files for
-the work, and the source code for shared libraries and dynamically
-linked subprograms that the work is specifically designed to require,
-such as by intimate data communication or control flow between those
-subprograms and other parts of the work.
-
- The Corresponding Source need not include anything that users
-can regenerate automatically from other parts of the Corresponding
-Source.
-
- The Corresponding Source for a work in source code form is that
-same work.
-
- 2. Basic Permissions.
-
- All rights granted under this License are granted for the term of
-copyright on the Program, and are irrevocable provided the stated
-conditions are met. This License explicitly affirms your unlimited
-permission to run the unmodified Program. The output from running a
-covered work is covered by this License only if the output, given its
-content, constitutes a covered work. This License acknowledges your
-rights of fair use or other equivalent, as provided by copyright law.
-
- You may make, run and propagate covered works that you do not
-convey, without conditions so long as your license otherwise remains
-in force. You may convey covered works to others for the sole purpose
-of having them make modifications exclusively for you, or provide you
-with facilities for running those works, provided that you comply with
-the terms of this License in conveying all material for which you do
-not control copyright. Those thus making or running the covered works
-for you must do so exclusively on your behalf, under your direction
-and control, on terms that prohibit them from making any copies of
-your copyrighted material outside their relationship with you.
-
- Conveying under any other circumstances is permitted solely under
-the conditions stated below. Sublicensing is not allowed; section 10
-makes it unnecessary.
-
- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
-
- No covered work shall be deemed part of an effective technological
-measure under any applicable law fulfilling obligations under article
-11 of the WIPO copyright treaty adopted on 20 December 1996, or
-similar laws prohibiting or restricting circumvention of such
-measures.
-
- When you convey a covered work, you waive any legal power to forbid
-circumvention of technological measures to the extent such circumvention
-is effected by exercising rights under this License with respect to
-the covered work, and you disclaim any intention to limit operation or
-modification of the work as a means of enforcing, against the work's
-users, your or third parties' legal rights to forbid circumvention of
-technological measures.
-
- 4. Conveying Verbatim Copies.
-
- You may convey verbatim copies of the Program's source code as you
-receive it, in any medium, provided that you conspicuously and
-appropriately publish on each copy an appropriate copyright notice;
-keep intact all notices stating that this License and any
-non-permissive terms added in accord with section 7 apply to the code;
-keep intact all notices of the absence of any warranty; and give all
-recipients a copy of this License along with the Program.
-
- You may charge any price or no price for each copy that you convey,
-and you may offer support or warranty protection for a fee.
-
- 5. Conveying Modified Source Versions.
-
- You may convey a work based on the Program, or the modifications to
-produce it from the Program, in the form of source code under the
-terms of section 4, provided that you also meet all of these conditions:
-
- a) The work must carry prominent notices stating that you modified
- it, and giving a relevant date.
-
- b) The work must carry prominent notices stating that it is
- released under this License and any conditions added under section
- 7. This requirement modifies the requirement in section 4 to
- "keep intact all notices".
-
- c) You must license the entire work, as a whole, under this
- License to anyone who comes into possession of a copy. This
- License will therefore apply, along with any applicable section 7
- additional terms, to the whole of the work, and all its parts,
- regardless of how they are packaged. This License gives no
- permission to license the work in any other way, but it does not
- invalidate such permission if you have separately received it.
-
- d) If the work has interactive user interfaces, each must display
- Appropriate Legal Notices; however, if the Program has interactive
- interfaces that do not display Appropriate Legal Notices, your
- work need not make them do so.
-
- A compilation of a covered work with other separate and independent
-works, which are not by their nature extensions of the covered work,
-and which are not combined with it such as to form a larger program,
-in or on a volume of a storage or distribution medium, is called an
-"aggregate" if the compilation and its resulting copyright are not
-used to limit the access or legal rights of the compilation's users
-beyond what the individual works permit. Inclusion of a covered work
-in an aggregate does not cause this License to apply to the other
-parts of the aggregate.
-
- 6. Conveying Non-Source Forms.
-
- You may convey a covered work in object code form under the terms
-of sections 4 and 5, provided that you also convey the
-machine-readable Corresponding Source under the terms of this License,
-in one of these ways:
-
- a) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by the
- Corresponding Source fixed on a durable physical medium
- customarily used for software interchange.
-
- b) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by a
- written offer, valid for at least three years and valid for as
- long as you offer spare parts or customer support for that product
- model, to give anyone who possesses the object code either (1) a
- copy of the Corresponding Source for all the software in the
- product that is covered by this License, on a durable physical
- medium customarily used for software interchange, for a price no
- more than your reasonable cost of physically performing this
- conveying of source, or (2) access to copy the
- Corresponding Source from a network server at no charge.
-
- c) Convey individual copies of the object code with a copy of the
- written offer to provide the Corresponding Source. This
- alternative is allowed only occasionally and noncommercially, and
- only if you received the object code with such an offer, in accord
- with subsection 6b.
-
- d) Convey the object code by offering access from a designated
- place (gratis or for a charge), and offer equivalent access to the
- Corresponding Source in the same way through the same place at no
- further charge. You need not require recipients to copy the
- Corresponding Source along with the object code. If the place to
- copy the object code is a network server, the Corresponding Source
- may be on a different server (operated by you or a third party)
- that supports equivalent copying facilities, provided you maintain
- clear directions next to the object code saying where to find the
- Corresponding Source. Regardless of what server hosts the
- Corresponding Source, you remain obligated to ensure that it is
- available for as long as needed to satisfy these requirements.
-
- e) Convey the object code using peer-to-peer transmission, provided
- you inform other peers where the object code and Corresponding
- Source of the work are being offered to the general public at no
- charge under subsection 6d.
-
- A separable portion of the object code, whose source code is excluded
-from the Corresponding Source as a System Library, need not be
-included in conveying the object code work.
-
- A "User Product" is either (1) a "consumer product", which means any
-tangible personal property which is normally used for personal, family,
-or household purposes, or (2) anything designed or sold for incorporation
-into a dwelling. In determining whether a product is a consumer product,
-doubtful cases shall be resolved in favor of coverage. For a particular
-product received by a particular user, "normally used" refers to a
-typical or common use of that class of product, regardless of the status
-of the particular user or of the way in which the particular user
-actually uses, or expects or is expected to use, the product. A product
-is a consumer product regardless of whether the product has substantial
-commercial, industrial or non-consumer uses, unless such uses represent
-the only significant mode of use of the product.
-
- "Installation Information" for a User Product means any methods,
-procedures, authorization keys, or other information required to install
-and execute modified versions of a covered work in that User Product from
-a modified version of its Corresponding Source. The information must
-suffice to ensure that the continued functioning of the modified object
-code is in no case prevented or interfered with solely because
-modification has been made.
-
- If you convey an object code work under this section in, or with, or
-specifically for use in, a User Product, and the conveying occurs as
-part of a transaction in which the right of possession and use of the
-User Product is transferred to the recipient in perpetuity or for a
-fixed term (regardless of how the transaction is characterized), the
-Corresponding Source conveyed under this section must be accompanied
-by the Installation Information. But this requirement does not apply
-if neither you nor any third party retains the ability to install
-modified object code on the User Product (for example, the work has
-been installed in ROM).
-
- The requirement to provide Installation Information does not include a
-requirement to continue to provide support service, warranty, or updates
-for a work that has been modified or installed by the recipient, or for
-the User Product in which it has been modified or installed. Access to a
-network may be denied when the modification itself materially and
-adversely affects the operation of the network or violates the rules and
-protocols for communication across the network.
-
- Corresponding Source conveyed, and Installation Information provided,
-in accord with this section must be in a format that is publicly
-documented (and with an implementation available to the public in
-source code form), and must require no special password or key for
-unpacking, reading or copying.
-
- 7. Additional Terms.
-
- "Additional permissions" are terms that supplement the terms of this
-License by making exceptions from one or more of its conditions.
-Additional permissions that are applicable to the entire Program shall
-be treated as though they were included in this License, to the extent
-that they are valid under applicable law. If additional permissions
-apply only to part of the Program, that part may be used separately
-under those permissions, but the entire Program remains governed by
-this License without regard to the additional permissions.
-
- When you convey a copy of a covered work, you may at your option
-remove any additional permissions from that copy, or from any part of
-it. (Additional permissions may be written to require their own
-removal in certain cases when you modify the work.) You may place
-additional permissions on material, added by you to a covered work,
-for which you have or can give appropriate copyright permission.
-
- Notwithstanding any other provision of this License, for material you
-add to a covered work, you may (if authorized by the copyright holders of
-that material) supplement the terms of this License with terms:
-
- a) Disclaiming warranty or limiting liability differently from the
- terms of sections 15 and 16 of this License; or
-
- b) Requiring preservation of specified reasonable legal notices or
- author attributions in that material or in the Appropriate Legal
- Notices displayed by works containing it; or
-
- c) Prohibiting misrepresentation of the origin of that material, or
- requiring that modified versions of such material be marked in
- reasonable ways as different from the original version; or
-
- d) Limiting the use for publicity purposes of names of licensors or
- authors of the material; or
-
- e) Declining to grant rights under trademark law for use of some
- trade names, trademarks, or service marks; or
-
- f) Requiring indemnification of licensors and authors of that
- material by anyone who conveys the material (or modified versions of
- it) with contractual assumptions of liability to the recipient, for
- any liability that these contractual assumptions directly impose on
- those licensors and authors.
-
- All other non-permissive additional terms are considered "further
-restrictions" within the meaning of section 10. If the Program as you
-received it, or any part of it, contains a notice stating that it is
-governed by this License along with a term that is a further
-restriction, you may remove that term. If a license document contains
-a further restriction but permits relicensing or conveying under this
-License, you may add to a covered work material governed by the terms
-of that license document, provided that the further restriction does
-not survive such relicensing or conveying.
-
- If you add terms to a covered work in accord with this section, you
-must place, in the relevant source files, a statement of the
-additional terms that apply to those files, or a notice indicating
-where to find the applicable terms.
-
- Additional terms, permissive or non-permissive, may be stated in the
-form of a separately written license, or stated as exceptions;
-the above requirements apply either way.
-
- 8. Termination.
-
- You may not propagate or modify a covered work except as expressly
-provided under this License. Any attempt otherwise to propagate or
-modify it is void, and will automatically terminate your rights under
-this License (including any patent licenses granted under the third
-paragraph of section 11).
-
- However, if you cease all violation of this License, then your
-license from a particular copyright holder is reinstated (a)
-provisionally, unless and until the copyright holder explicitly and
-finally terminates your license, and (b) permanently, if the copyright
-holder fails to notify you of the violation by some reasonable means
-prior to 60 days after the cessation.
-
- Moreover, your license from a particular copyright holder is
-reinstated permanently if the copyright holder notifies you of the
-violation by some reasonable means, this is the first time you have
-received notice of violation of this License (for any work) from that
-copyright holder, and you cure the violation prior to 30 days after
-your receipt of the notice.
-
- Termination of your rights under this section does not terminate the
-licenses of parties who have received copies or rights from you under
-this License. If your rights have been terminated and not permanently
-reinstated, you do not qualify to receive new licenses for the same
-material under section 10.
-
- 9. Acceptance Not Required for Having Copies.
-
- You are not required to accept this License in order to receive or
-run a copy of the Program. Ancillary propagation of a covered work
-occurring solely as a consequence of using peer-to-peer transmission
-to receive a copy likewise does not require acceptance. However,
-nothing other than this License grants you permission to propagate or
-modify any covered work. These actions infringe copyright if you do
-not accept this License. Therefore, by modifying or propagating a
-covered work, you indicate your acceptance of this License to do so.
-
- 10. Automatic Licensing of Downstream Recipients.
-
- Each time you convey a covered work, the recipient automatically
-receives a license from the original licensors, to run, modify and
-propagate that work, subject to this License. You are not responsible
-for enforcing compliance by third parties with this License.
-
- An "entity transaction" is a transaction transferring control of an
-organization, or substantially all assets of one, or subdividing an
-organization, or merging organizations. If propagation of a covered
-work results from an entity transaction, each party to that
-transaction who receives a copy of the work also receives whatever
-licenses to the work the party's predecessor in interest had or could
-give under the previous paragraph, plus a right to possession of the
-Corresponding Source of the work from the predecessor in interest, if
-the predecessor has it or can get it with reasonable efforts.
-
- You may not impose any further restrictions on the exercise of the
-rights granted or affirmed under this License. For example, you may
-not impose a license fee, royalty, or other charge for exercise of
-rights granted under this License, and you may not initiate litigation
-(including a cross-claim or counterclaim in a lawsuit) alleging that
-any patent claim is infringed by making, using, selling, offering for
-sale, or importing the Program or any portion of it.
-
- 11. Patents.
-
- A "contributor" is a copyright holder who authorizes use under this
-License of the Program or a work on which the Program is based. The
-work thus licensed is called the contributor's "contributor version".
-
- A contributor's "essential patent claims" are all patent claims
-owned or controlled by the contributor, whether already acquired or
-hereafter acquired, that would be infringed by some manner, permitted
-by this License, of making, using, or selling its contributor version,
-but do not include claims that would be infringed only as a
-consequence of further modification of the contributor version. For
-purposes of this definition, "control" includes the right to grant
-patent sublicenses in a manner consistent with the requirements of
-this License.
-
- Each contributor grants you a non-exclusive, worldwide, royalty-free
-patent license under the contributor's essential patent claims, to
-make, use, sell, offer for sale, import and otherwise run, modify and
-propagate the contents of its contributor version.
-
- In the following three paragraphs, a "patent license" is any express
-agreement or commitment, however denominated, not to enforce a patent
-(such as an express permission to practice a patent or covenant not to
-sue for patent infringement). To "grant" such a patent license to a
-party means to make such an agreement or commitment not to enforce a
-patent against the party.
-
- If you convey a covered work, knowingly relying on a patent license,
-and the Corresponding Source of the work is not available for anyone
-to copy, free of charge and under the terms of this License, through a
-publicly available network server or other readily accessible means,
-then you must either (1) cause the Corresponding Source to be so
-available, or (2) arrange to deprive yourself of the benefit of the
-patent license for this particular work, or (3) arrange, in a manner
-consistent with the requirements of this License, to extend the patent
-license to downstream recipients. "Knowingly relying" means you have
-actual knowledge that, but for the patent license, your conveying the
-covered work in a country, or your recipient's use of the covered work
-in a country, would infringe one or more identifiable patents in that
-country that you have reason to believe are valid.
+ Apache License
+ Version 2.0, January 2004
+ http://www.apache.org/licenses/
- 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.
+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
- 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.
+ 1. Definitions.
- 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.
+ "License" shall mean the terms and conditions for use, reproduction,
+ and distribution as defined by Sections 1 through 9 of this document.
- 12. No Surrender of Others' Freedom.
+ "Licensor" shall mean the copyright owner or entity authorized by
+ the copyright owner that is granting the License.
- 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.
+ "Legal Entity" shall mean the union of the acting entity and all
+ other entities that control, are controlled by, or are under common
+ control with that entity. For the purposes of this definition,
+ "control" means (i) the power, direct or indirect, to cause the
+ direction or management of such entity, whether by contract or
+ otherwise, or (ii) ownership of fifty percent (50%) or more of the
+ outstanding shares, or (iii) beneficial ownership of such entity.
- 13. Use with the GNU Affero General Public License.
+ "You" (or "Your") shall mean an individual or Legal Entity
+ exercising permissions granted by this License.
- Notwithstanding any other provision of this License, you have
-permission to link or combine any covered work with a work licensed
-under version 3 of the GNU Affero General Public License into a single
-combined work, and to convey the resulting work. The terms of this
-License will continue to apply to the part which is the covered work,
-but the special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
+ "Source" form shall mean the preferred form for making modifications,
+ including but not limited to software source code, documentation
+ source, and configuration files.
- 14. Revised Versions of this License.
+ "Object" form shall mean any form resulting from mechanical
+ transformation or translation of a Source form, including but
+ not limited to compiled object code, generated documentation,
+ and conversions to other media types.
- The Free Software Foundation may publish revised and/or new versions of
-the GNU General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
+ "Work" shall mean the work of authorship, whether in Source or
+ Object form, made available under the License, as indicated by a
+ copyright notice that is included in or attached to the work
+ (an example is provided in the Appendix below).
- Each version is given a distinguishing version number. If the
-Program specifies that a certain numbered version of the GNU General
-Public License "or any later version" applies to it, you have the
-option of following the terms and conditions either of that numbered
-version or of any later version published by the Free Software
-Foundation. If the Program does not specify a version number of the
-GNU General Public License, you may choose any version ever published
-by the Free Software Foundation.
+ "Derivative Works" shall mean any work, whether in Source or Object
+ form, that is based on (or derived from) the Work and for which the
+ editorial revisions, annotations, elaborations, or other modifications
+ represent, as a whole, an original work of authorship. For the purposes
+ of this License, Derivative Works shall not include works that remain
+ separable from, or merely link (or bind by name) to the interfaces of,
+ the Work and Derivative Works thereof.
- If the Program specifies that a proxy can decide which future
-versions of the GNU General Public License can be used, that proxy's
-public statement of acceptance of a version permanently authorizes you
-to choose that version for the Program.
+ "Contribution" shall mean any work of authorship, including
+ the original version of the Work and any modifications or additions
+ to that Work or Derivative Works thereof, that is intentionally
+ submitted to Licensor for inclusion in the Work by the copyright owner
+ or by an individual or Legal Entity authorized to submit on behalf of
+ the copyright owner. For the purposes of this definition, "submitted"
+ means any form of electronic, verbal, or written communication sent
+ to the Licensor or its representatives, including but not limited to
+ communication on electronic mailing lists, source code control systems,
+ and issue tracking systems that are managed by, or on behalf of, the
+ Licensor for the purpose of discussing and improving the Work, but
+ excluding communication that is conspicuously marked or otherwise
+ designated in writing by the copyright owner as "Not a Contribution."
- 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.
+ "Contributor" shall mean Licensor and any individual or Legal Entity
+ on behalf of whom a Contribution has been received by Licensor and
+ subsequently incorporated within the Work.
- 15. Disclaimer of Warranty.
+ 2. Grant of Copyright License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ copyright license to reproduce, prepare Derivative Works of,
+ publicly display, publicly perform, sublicense, and distribute the
+ Work and such Derivative Works in Source or Object form.
- 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.
+ 3. Grant of Patent License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ (except as stated in this section) patent license to make, have made,
+ use, offer to sell, sell, import, and otherwise transfer the Work,
+ where such license applies only to those patent claims licensable
+ by such Contributor that are necessarily infringed by their
+ Contribution(s) alone or by combination of their Contribution(s)
+ with the Work to which such Contribution(s) was submitted. If You
+ institute patent litigation against any entity (including a
+ cross-claim or counterclaim in a lawsuit) alleging that the Work
+ or a Contribution incorporated within the Work constitutes direct
+ or contributory patent infringement, then any patent licenses
+ granted to You under this License for that Work shall terminate
+ as of the date such litigation is filed.
- 16. Limitation of Liability.
+ 4. Redistribution. You may reproduce and distribute copies of the
+ Work or Derivative Works thereof in any medium, with or without
+ modifications, and in Source or Object form, provided that You
+ meet the following conditions:
- 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.
+ (a) You must give any other recipients of the Work or
+ Derivative Works a copy of this License; and
- 17. Interpretation of Sections 15 and 16.
+ (b) You must cause any modified files to carry prominent notices
+ stating that You changed the files; and
- 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.
+ (c) You must retain, in the Source form of any Derivative Works
+ that You distribute, all copyright, patent, trademark, and
+ attribution notices from the Source form of the Work,
+ excluding those notices that do not pertain to any part of
+ the Derivative Works; and
- END OF TERMS AND CONDITIONS
+ (d) If the Work includes a "NOTICE" text file as part of its
+ distribution, then any Derivative Works that You distribute must
+ include a readable copy of the attribution notices contained
+ within such NOTICE file, excluding those notices that do not
+ pertain to any part of the Derivative Works, in at least one
+ of the following places: within a NOTICE text file distributed
+ as part of the Derivative Works; within the Source form or
+ documentation, if provided along with the Derivative Works; or,
+ within a display generated by the Derivative Works, if and
+ wherever such third-party notices normally appear. The contents
+ of the NOTICE file are for informational purposes only and
+ do not modify the License. You may add Your own attribution
+ notices within Derivative Works that You distribute, alongside
+ or as an addendum to the NOTICE text from the Work, provided
+ that such additional attribution notices cannot be construed
+ as modifying the License.
- How to Apply These Terms to Your New Programs
+ You may add Your own copyright statement to Your modifications and
+ may provide additional or different license terms and conditions
+ for use, reproduction, or distribution of Your modifications, or
+ for any such Derivative Works as a whole, provided Your use,
+ reproduction, and distribution of the Work otherwise complies with
+ the conditions stated in this License.
- 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.
+ 5. Submission of Contributions. Unless You explicitly state otherwise,
+ any Contribution intentionally submitted for inclusion in the Work
+ by You to the Licensor shall be under the terms and conditions of
+ this License, without any additional terms or conditions.
+ Notwithstanding the above, nothing herein shall supersede or modify
+ the terms of any separate license agreement you may have executed
+ with Licensor regarding such Contributions.
- 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.
+ 6. Trademarks. This License does not grant permission to use the trade
+ names, trademarks, service marks, or product names of the Licensor,
+ except as required for reasonable and customary use in describing the
+ origin of the Work and reproducing the content of the NOTICE file.
-
- Copyright (C)
+ 7. Disclaimer of Warranty. Unless required by applicable law or
+ agreed to in writing, Licensor provides the Work (and each
+ Contributor provides its Contributions) on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+ implied, including, without limitation, any warranties or conditions
+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+ PARTICULAR PURPOSE. You are solely responsible for determining the
+ appropriateness of using or redistributing the Work and assume any
+ risks associated with Your exercise of permissions under this License.
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
+ 8. Limitation of Liability. In no event and under no legal theory,
+ whether in tort (including negligence), contract, or otherwise,
+ unless required by applicable law (such as deliberate and grossly
+ negligent acts) or agreed to in writing, shall any Contributor be
+ liable to You for damages, including any direct, indirect, special,
+ incidental, or consequential damages of any character arising as a
+ result of this License or out of the use or inability to use the
+ Work (including but not limited to damages for loss of goodwill,
+ work stoppage, computer failure or malfunction, or any and all
+ other commercial damages or losses), even if such Contributor
+ has been advised of the possibility of such damages.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
+ 9. Accepting Warranty or Additional Liability. While redistributing
+ the Work or Derivative Works thereof, You may choose to offer,
+ and charge a fee for, acceptance of support, warranty, indemnity,
+ or other liability obligations and/or rights consistent with this
+ License. However, in accepting such obligations, You may act only
+ on Your own behalf and on Your sole responsibility, not on behalf
+ of any other Contributor, and only if You agree to indemnify,
+ defend, and hold each Contributor harmless for any liability
+ incurred by, or claims asserted against, such Contributor by reason
+ of your accepting any such warranty or additional liability.
- You should have received a copy of the GNU General Public License
- along with this program. If not, see .
+ END OF TERMS AND CONDITIONS
-Also add information on how to contact you by electronic and paper mail.
+ APPENDIX: How to apply the Apache License to your work.
- If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
+ To apply the Apache License to your work, attach the following
+ boilerplate notice, with the fields enclosed by brackets "[]"
+ replaced with your own identifying information. (Don't include
+ the brackets!) The text should be enclosed in the appropriate
+ comment syntax for the file format. We also recommend that a
+ file or class name and description of purpose be included on the
+ same "printed page" as the copyright notice for easier
+ identification within third-party archives.
- Copyright (C)
- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
+ Copyright [yyyy] [name of copyright owner]
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
+ Licensed under the Apache License, Version 2.0 (the "License");
+ you may not use this file except in compliance with the License.
+ You may obtain a copy of the License at
- You should also get your employer (if you work as a programmer) or school,
-if any, to sign a "copyright disclaimer" for the program, if necessary.
-For more information on this, and how to apply and follow the GNU GPL, see
-.
+ http://www.apache.org/licenses/LICENSE-2.0
- The GNU General Public License does not permit incorporating your program
-into proprietary programs. If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library. If this is what you want to do, use the GNU Lesser General
-Public License instead of this License. But first, please read
-.
+ Unless required by applicable law or agreed to in writing, software
+ distributed under the License is distributed on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ See the License for the specific language governing permissions and
+ limitations under the License.
diff --git a/NOTICE.txt b/NOTICE.txt
new file mode 100644
--- /dev/null
+++ b/NOTICE.txt
@@ -0,0 +1,44 @@
+Copyright 2015 Ideas project team
+
+ Licensed under the Apache License, Version 2.0 (the "License");
+ you may not use this file except in compliance with the License.
+ You may obtain a copy of the License at
+
+ http://www.apache.org/licenses/LICENSE-2.0
+
+ Unless required by applicable law or agreed to in writing, software
+ distributed under the License is distributed on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ See the License for the specific language governing permissions and
+ limitations under the License.
+
+PROJECT
+
+ Ideas (Interactive Domain-specific Exercise Assistants) is a joint research
+ project between the Open University of the Netherlands and Utrecht
+ University. The project's goal is to use software and compiler technology to
+ build state-of-the-art components of intelligent tutoring systems (ITS) and
+ learning environments. The 'ideas' software package provides a generic
+ framework for constructing the expert knowledge module (also known as a
+ domain reasoner) for an ITS or learning environment. More information about
+ the project can be found on the project's homepage:
+
+ http://ideas.cs.uu.nl/www/
+
+AUTHORS
+
+ The authors and copyright holders of the 'ideas' software package are:
+ - Bastiaan Heeren (bastiaan.heeren@ou.nl, maintainer)
+ - Alex Gerdes (agerdes@me.com)
+ - Johan Jeuring (J.T.Jeuring@uu.nl)
+
+CREDITS
+
+ Harrie Passier, Arthur van Leeuwen, Josje Lodder, Hieke Keuning
+
+ This package contains a verbatim copy of the cgi-3001.2.2.0 package, with
+ minor modifications to resolve conflicting dependencies. The original
+ package, together with its BSD3 license and further information about
+ copyright, author and maintainer, can be found at:
+
+ http://hackage.haskell.org/package/cgi-3001.2.2.0
diff --git a/ideas.cabal b/ideas.cabal
--- a/ideas.cabal
+++ b/ideas.cabal
@@ -1,35 +1,59 @@
name: ideas
-version: 1.3.1
+version: 1.4
synopsis: Feedback services for intelligent tutoring systems
homepage: http://ideas.cs.uu.nl/www/
description:
- ideas provides feedback services to intelligent tutoring systems such as
- the digital mathematical environment of the Freudenthal Institute, MathDox,
- and Activemath.
+ Ideas (Interactive Domain-specific Exercise Assistants) is a joint research
+ project between the Open University of the Netherlands and Utrecht
+ University. The project's goal is to use software and compiler technology to
+ build state-of-the-art components for intelligent tutoring systems (ITS) and
+ learning environments. The 'ideas' software package provides a generic
+ framework for constructing the expert knowledge module (also known as a
+ domain reasoner) for an ITS or learning environment. Domain knowledge is
+ offered as a set of feedback services that are used by external tools such
+ as the digital mathematical environment (DME), MathDox, and the Math-Bridge
+ system. We have developed several domain reasoners based on this framework,
+ including reasoners for mathematics, linear algebra, logic, learning Haskell
+ (the Ask-Elle programming tutor) and evaluating Haskell expressions, and for
+ practicing communication skills (the serious game Communicate!).
category: Education
copyright: (c) 2015
-license: GPL
+license: Apache-2.0
license-file: LICENSE.txt
author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring
maintainer: bastiaan.heeren@ou.nl
stability: provisional
-extra-source-files: CREDITS.txt
+extra-source-files: NOTICE.txt, CHANGELOG.txt
build-type: Simple
cabal-version: >= 1.8.0.2
-tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.3
+tested-with: GHC == 7.4.1, GHC == 7.8.3, GHC == 7.8.4
source-repository head
type: svn
location: https://ideas.cs.uu.nl/svn/Feedback/trunk/
+flag network-uri
+ description: Get Network.URI from the network-uri package
+ default: True
+
+flag logging
+ description: enable support for logging interactions to a sqlite3 database
+ default: False
+
--------------------------------------------------------------------------------
Library
+ if flag(logging) {
+ cpp-options: -DDB
+ Build-Depends: HDBC, HDBC-sqlite3
+ }
+
ghc-options: -Wall
hs-source-dirs: src
Build-Depends: base >= 4.2 && < 5,
+ mtl == 2.1.*,
QuickCheck >= 2.4.1 && < 2.7,
Diff,
containers,
@@ -41,8 +65,6 @@
parsec,
wl-pprint,
array,
- mtl == 2.1.*,
- network < 2.6,
exceptions,
multipart,
bytestring,
@@ -50,6 +72,11 @@
old-locale,
xhtml
+ if flag(network-uri)
+ build-depends: network-uri >= 2.6, network >= 2.6
+ else
+ build-depends: network < 2.6
+
Exposed-modules:
Ideas.Common.Algebra.Boolean
Ideas.Common.Algebra.BooleanLaws
@@ -61,6 +88,7 @@
Ideas.Common.Algebra.SmartGroup
Ideas.Common.Classes
Ideas.Common.Context
+ Ideas.Common.CyclicTree
Ideas.Common.Derivation
Ideas.Common.DerivationTree
Ideas.Common.Environment
@@ -88,12 +116,14 @@
Ideas.Common.Strategy.Choice
Ideas.Common.Strategy.Combinators
Ideas.Common.Strategy.Configuration
- Ideas.Common.Strategy.Core
Ideas.Common.Strategy.Derived
+ Ideas.Common.Strategy.Legacy
Ideas.Common.Strategy.Location
- Ideas.Common.Strategy.Parsing
+ Ideas.Common.Strategy.Prefix
Ideas.Common.Strategy.Process
Ideas.Common.Strategy.Sequence
+ Ideas.Common.Strategy.StrategyTree
+ Ideas.Common.Strategy.Symbol
Ideas.Common.Strategy.Traversal
Ideas.Common.Traversal.Iterator
Ideas.Common.Traversal.Navigator
@@ -122,7 +152,7 @@
Ideas.Main.BlackBoxTests
Ideas.Main.Default
Ideas.Main.Documentation
- Ideas.Main.LoggingDatabase
+ Ideas.Main.Logging
Ideas.Main.Options
Ideas.Main.Revision
Ideas.Service.BasicServices
diff --git a/src/Ideas/Common/Algebra/Boolean.hs b/src/Ideas/Common/Algebra/Boolean.hs
--- a/src/Ideas/Common/Algebra/Boolean.hs
+++ b/src/Ideas/Common/Algebra/Boolean.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Boolean.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Boolean.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Algebra.Boolean
( -- * Boolean algebra
diff --git a/src/Ideas/Common/Algebra/BooleanLaws.hs b/src/Ideas/Common/Algebra/BooleanLaws.hs
--- a/src/Ideas/Common/Algebra/BooleanLaws.hs
+++ b/src/Ideas/Common/Algebra/BooleanLaws.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: BooleanLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: BooleanLaws.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Algebra.BooleanLaws
( -- * Boolean laws
diff --git a/src/Ideas/Common/Algebra/Field.hs b/src/Ideas/Common/Algebra/Field.hs
--- a/src/Ideas/Common/Algebra/Field.hs
+++ b/src/Ideas/Common/Algebra/Field.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Field.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Field.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Common.Algebra.Field
( -- * Semi-ring
@@ -34,53 +34,54 @@
import Ideas.Common.Classes (mapBoth)
import Test.QuickCheck
import qualified Control.Applicative as A
+import qualified Control.Applicative as Applicative
--------------------------------------------------------
-- Semi-ring
-infixl 6 <+>
-infixl 7 <*>
+infixl 6 |+|
+infixl 7 |*|
class SemiRing a where
-- additive
- (<+>) :: a -> a -> a
+ (|+|) :: a -> a -> a
zero :: a
sum :: [a] -> a
-- multiplicative
- (<*>) :: a -> a -> a
+ (|*|) :: a -> a -> a
one :: a
product :: [a] -> a
-- default implementation
sum [] = zero
- sum xs = foldl1 (<+>) xs
+ sum xs = foldl1 (|+|) xs
product [] = one
- product xs = foldl1 (<*>) xs
+ product xs = foldl1 (|*|) xs
--------------------------------------------------------
-- Ring
-infixl 6 <->
+infixl 6 |-|
-- Minimal complete definition: plusInverse or <->
class SemiRing a => Ring a where
plusInverse :: a -> a
- (<->) :: a -> a -> a
+ (|-|) :: a -> a -> a
-- default definitions
- plusInverse = (zero <->)
- a <-> b = a <+> plusInverse b
+ plusInverse = (zero |-|)
+ a |-| b = a |+| plusInverse b
--------------------------------------------------------
-- Field
-infixl 7
+infixl 7 |/|
-- Minimal complete definition: mulInverse or
class Ring a => Field a where
timesInverse :: a -> a
- () :: a -> a -> a
+ (|/|) :: a -> a -> a
-- default definitions
- timesInverse = (one )
- a b = a <*> timesInverse b
+ timesInverse = (one |/|)
+ a |/| b = a |*| timesInverse b
--------------------------------------------------------
-- Additive monoid
@@ -97,11 +98,11 @@
instance SemiRing a => Monoid (Additive a) where
mempty = A.pure zero
- mappend = A.liftA2 (<+>)
+ mappend = A.liftA2 (|+|)
instance Ring a => Group (Additive a) where
inverse = A.liftA plusInverse
- appendInv = A.liftA2 (<->)
+ appendInv = A.liftA2 (|-|)
--------------------------------------------------------
-- Multiplicative monoid
@@ -118,11 +119,11 @@
instance SemiRing a => Monoid (Multiplicative a) where
mempty = A.pure one
- mappend = A.liftA2 (<*>)
+ mappend = A.liftA2 (|*|)
instance Field a => Group (Multiplicative a) where
inverse = A.liftA timesInverse
- appendInv = A.liftA2 ()
+ appendInv = A.liftA2 (|/|)
instance SemiRing a => MonoidZero (Multiplicative a) where
mzero = Multiplicative zero
@@ -153,6 +154,10 @@
instance Functor SafeNum where
fmap f = either Exception (return . f) . safeNum
+instance Applicative.Applicative SafeNum where
+ pure = return
+ (<*>) = ap
+
instance Monad SafeNum where
return = Ok
fail = Exception
@@ -173,18 +178,18 @@
fromRational = return . fromRational
instance Num a => SemiRing (SafeNum a) where
- (<+>) = (+)
- (<*>) = (*)
+ (|+|) = (+)
+ (|*|) = (*)
zero = 0
one = 1
instance Num a => Ring (SafeNum a) where
plusInverse = negate
- (<->) = (-)
+ (|-|) = (-)
instance (Eq a, Fractional a) => Field (SafeNum a) where
timesInverse = recip
- () = (/)
+ (|/|) = (/)
safeDivisor :: (Eq a, Num a) => SafeNum a -> SafeNum a
safeDivisor m = m >>= \a ->
diff --git a/src/Ideas/Common/Algebra/FieldLaws.hs b/src/Ideas/Common/Algebra/FieldLaws.hs
--- a/src/Ideas/Common/Algebra/FieldLaws.hs
+++ b/src/Ideas/Common/Algebra/FieldLaws.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: FieldLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: FieldLaws.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Algebra.FieldLaws
( -- * Semi-ring laws
@@ -38,10 +38,10 @@
-- Semi-ring laws
leftDistributive :: SemiRing a => Law a
-leftDistributive = leftDistributiveFor (<*>) (<+>)
+leftDistributive = leftDistributiveFor (|*|) (|+|)
rightDistributive :: SemiRing a => Law a
-rightDistributive = rightDistributiveFor (<*>) (<+>)
+rightDistributive = rightDistributiveFor (|*|) (|+|)
distributiveLaws :: SemiRing a => [Law a]
distributiveLaws = [leftDistributive, rightDistributive]
@@ -57,11 +57,11 @@
leftNegateTimes :: Ring a => Law a
leftNegateTimes = law "left-negate-times" $ \a b ->
- plusInverse a <*> b :==: plusInverse (a <*> b)
+ plusInverse a |*| b :==: plusInverse (a |*| b)
rightNegateTimes :: Ring a => Law a
rightNegateTimes = law "right-negate-times" $ \a b ->
- a <*> plusInverse b :==: plusInverse (a <*> b)
+ a |*| plusInverse b :==: plusInverse (a |*| b)
negateTimesLaws :: Ring a => [Law a]
negateTimesLaws = [leftNegateTimes, rightNegateTimes]
@@ -78,7 +78,7 @@
distributiveSubtractionLaws :: Ring a => [Law a]
distributiveSubtractionLaws =
- [leftDistributiveFor (<*>) (<->), rightDistributiveFor (<*>) (<->)]
+ [leftDistributiveFor (|*|) (|-|), rightDistributiveFor (|*|) (|-|)]
--------------------------------------------------------
-- Field laws
diff --git a/src/Ideas/Common/Algebra/Group.hs b/src/Ideas/Common/Algebra/Group.hs
--- a/src/Ideas/Common/Algebra/Group.hs
+++ b/src/Ideas/Common/Algebra/Group.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Group.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Group.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Algebra.Group
( -- * Monoids
diff --git a/src/Ideas/Common/Algebra/GroupLaws.hs b/src/Ideas/Common/Algebra/GroupLaws.hs
--- a/src/Ideas/Common/Algebra/GroupLaws.hs
+++ b/src/Ideas/Common/Algebra/GroupLaws.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: GroupLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: GroupLaws.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Algebra.GroupLaws
( -- * Monoid laws
diff --git a/src/Ideas/Common/Algebra/Law.hs b/src/Ideas/Common/Algebra/Law.hs
--- a/src/Ideas/Common/Algebra/Law.hs
+++ b/src/Ideas/Common/Algebra/Law.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ExistentialQuantification #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,10 +10,10 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Law.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Law.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Common.Algebra.Law
- ( Law, LawSpec((:==:)), law, mapLaw
+ ( Law, LawSpec((:==:)), law, lawAbs, mapLaw
, propertyLaw, rewriteLaw
) where
@@ -27,19 +27,28 @@
instance Show (Law a) where
show (Law s _) = s
-data LawSpec a = Abs (a -> LawSpec a) | a :==: a
+data LawSpec a
+ = AbsMono (a -> LawSpec a) -- simple abstraction (fewer classes needed)
+ | forall b . (Arbitrary b, Show b, Different b) => Abs (b -> LawSpec a) -- generalized abstraction
+ | a :==: a
law :: LawBuilder l a => String -> l -> Law a
law s l = Law s (lawSpec l)
+lawAbs :: (Different b, Arbitrary b, Show b) => (b -> LawSpec a) -> LawSpec a
+lawAbs = Abs
+
class LawBuilder l a | l -> a where
lawSpec :: l -> LawSpec a
instance LawBuilder (LawSpec a) a where
lawSpec = id
+instance LawBuilder (Law a) a where
+ lawSpec = getLawSpec
+
instance LawBuilder b a => LawBuilder (a -> b) a where
- lawSpec f = Abs (lawSpec . f)
+ lawSpec f = AbsMono (lawSpec . f)
instance (Show a, Eq a, Arbitrary a) => Testable (Law a) where
property = propertyLaw (==)
@@ -47,21 +56,24 @@
mapLaw :: (b -> a) -> (a -> b) -> Law a -> Law b
mapLaw to from (Law s l) = Law s (rec l)
where
- rec (Abs f) = Abs (rec . f . to)
- rec (a :==: b) = from a :==: from b
+ rec (AbsMono f) = AbsMono (rec . f . to)
+ rec (Abs f) = Abs (rec . f)
+ rec (a :==: b) = from a :==: from b
propertyLaw :: (Arbitrary a, Show a, Testable b) => (a -> a -> b) -> Law a -> Property
propertyLaw eq = rec . getLawSpec
where
- rec (Abs f) = property (rec . f)
- rec (a :==: b) = property (eq a b)
+ rec (AbsMono f) = property (rec . f)
+ rec (Abs f) = property (rec . f)
+ rec (a :==: b) = property (eq a b)
rewriteLaw :: (Different a, IsTerm a, Arbitrary a, Show a) => Law a -> RewriteRule a
rewriteLaw (Law s l) = makeRewriteRule s l
instance (Arbitrary a, IsTerm a, Show a, Different a) => RuleBuilder (LawSpec a) a where
- buildRuleSpec i (a :==: b) = buildRuleSpec i (a :~> b)
- buildRuleSpec i (Abs f) = buildRuleSpec i f
+ buildRuleSpec i (a :==: b) = buildRuleSpec i (a :~> b)
+ buildRuleSpec i (AbsMono f) = buildRuleSpec i f
+ buildRuleSpec i (Abs f) = buildRuleSpec i f
getLawSpec :: Law a -> LawSpec a
getLawSpec (Law _ l) = l
diff --git a/src/Ideas/Common/Algebra/SmartGroup.hs b/src/Ideas/Common/Algebra/SmartGroup.hs
--- a/src/Ideas/Common/Algebra/SmartGroup.hs
+++ b/src/Ideas/Common/Algebra/SmartGroup.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: SmartGroup.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: SmartGroup.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Algebra.SmartGroup
( -- * Smart datatypes
@@ -25,9 +25,8 @@
import Control.Monad (mplus)
import Data.Maybe
import Ideas.Common.Algebra.Boolean
-import Ideas.Common.Algebra.Field hiding ((<*>))
+import Ideas.Common.Algebra.Field
import Ideas.Common.Algebra.Group
-import qualified Ideas.Common.Algebra.Field as Field
newtype Smart a = Smart {fromSmart :: a}
deriving (Show, Eq, Ord, CoMonoid, MonoidZero, CoMonoidZero)
@@ -121,22 +120,22 @@
instance (CoField a, Field a) => SemiRing (SmartField a) where
zero = SmartField zero
one = SmartField one
- SmartField a <+> SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
+ SmartField a |+| SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
SmartGroup (Additive a) <> SmartGroup (Additive b)
- a <*> b
- | Just x <- isNegate a = plusInverse (x Field.<*> b)
- | Just x <- isNegate b = plusInverse (a Field.<*> x)
+ a |*| b
+ | Just x <- isNegate a = plusInverse (x |*| b)
+ | Just x <- isNegate b = plusInverse (a |*| x)
| isZero a || isZero b = zero
| isOne a = b
| isOne b = a
- | Just (x, y) <- isTimes b = (a Field.<*> x) Field.<*> y
- | Just (x, y) <- isDivision b = (a Field.<*> x) y
- | otherwise = liftA2 (Field.<*>) a b
+ | Just (x, y) <- isTimes b = (a |*| x) |*| y
+ | Just (x, y) <- isDivision b = (a |*| x) |/| y
+ | otherwise = liftA2 (|*|) a b
instance (CoField a, Field a) => Ring (SmartField a) where
plusInverse = SmartField . fromAdditive . fromSmartGroup . inverse
. SmartGroup . Additive . fromSmartField
- SmartField a <-> SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
+ SmartField a |-| SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
SmartGroup (Additive a) <>- SmartGroup (Additive b)
instance (CoField a, Field a) => Field (SmartField a) where
@@ -144,12 +143,12 @@
| Just x <- isNegate a = plusInverse (timesInverse x)
| Just (x, y) <- isDivision a, isOne y = x
| otherwise = liftA timesInverse a
- a b
- | Just x <- isNegate a = plusInverse (x b)
- | Just x <- isNegate b = plusInverse (a x)
+ a |/| b
+ | Just x <- isNegate a = plusInverse (x |/| b)
+ | Just x <- isNegate b = plusInverse (a |/| x)
| isOne b = a
- | Just (x, y) <- isDivision a = x (y Field.<*> b)
- | otherwise = liftA2 () a b
+ | Just (x, y) <- isDivision a = x |/| (y |*| b)
+ | otherwise = liftA2 (|/|) a b
------------------------------------------------------------------
@@ -157,19 +156,19 @@
infixl 6 .-., .+.
(.+.) :: (CoField a, Field a) => a -> a -> a
-a .+. b = fromSmartField $ SmartField a <+> SmartField b
+a .+. b = fromSmartField $ SmartField a |+| SmartField b
(.-.) :: (CoField a, Field a) => a -> a -> a
-a .-. b = fromSmartField $ SmartField a <-> SmartField b
+a .-. b = fromSmartField $ SmartField a |-| SmartField b
neg :: (CoField a, Field a) => a -> a
neg = fromSmartField . plusInverse . SmartField
(.*.) :: (CoField a, Field a) => a -> a -> a
-a .*. b = fromSmartField $ SmartField a Field.<*> SmartField b
+a .*. b = fromSmartField $ SmartField a |*| SmartField b
(./.) :: (CoField a, Field a) => a -> a -> a
-a ./. b = fromSmartField $ SmartField a SmartField b
+a ./. b = fromSmartField $ SmartField a |/| SmartField b
-- myrecip :: (CoField a, Field a) => a -> a
-- myrecip = fromSmartField . timesInverse . SmartField
diff --git a/src/Ideas/Common/Classes.hs b/src/Ideas/Common/Classes.hs
--- a/src/Ideas/Common/Classes.hs
+++ b/src/Ideas/Common/Classes.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,17 +11,19 @@
-- Type classes and instances.
--
-----------------------------------------------------------------------------
--- $Id: Classes.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Classes.hs 8763 2015-10-23 06:46:32Z bastiaan $
module Ideas.Common.Classes
( -- * Type class Apply
- Apply, apply, applyAll, applicable, applyD, applyM, applyList
+ Apply(applyAll), apply, applicable, applyD, applyM, applyList
-- * Type class Container
- , Container, singleton, getSingleton
+ , Container(singleton, getSingleton)
-- * Type class BiArrow
, BiArrow(..)
-- * Type class BiFunctor
- , BiFunctor, biMap, mapFirst, mapSecond, mapBoth
+ , BiFunctor(biMap, mapFirst, mapSecond), mapBoth
+ -- * Type class Fix
+ , Fix(..)
-- * Buggy and Minor properties
, Buggy(..), Minor(..)
) where
@@ -111,6 +113,14 @@
mapBoth :: BiFunctor f => (a -> b) -> f a a -> f b b
mapBoth f = biMap f f
+
+-----------------------------------------------------------
+-- Type class BiFunctor
+
+class Fix a where
+ fix :: (a -> a) -> a
+ -- default implementation
+ fix f = let a = f a in a
-----------------------------------------------------------
-- Buggy and Minor properties
diff --git a/src/Ideas/Common/Context.hs b/src/Ideas/Common/Context.hs
--- a/src/Ideas/Common/Context.hs
+++ b/src/Ideas/Common/Context.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs, RankNTypes #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -16,7 +16,7 @@
-- the 'Navigator' type class (for traversing the term).
--
-----------------------------------------------------------------------------
--- $Id: Context.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Context.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Context
( -- * Abstract data type
diff --git a/src/Ideas/Common/CyclicTree.hs b/src/Ideas/Common/CyclicTree.hs
new file mode 100644
--- /dev/null
+++ b/src/Ideas/Common/CyclicTree.hs
@@ -0,0 +1,221 @@
+-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer : bastiaan.heeren@ou.nl
+-- Stability : provisional
+-- Portability : portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+-- $Id: CyclicTree.hs 8747 2015-10-15 14:54:48Z bastiaan $
+
+module Ideas.Common.CyclicTree
+ ( -- * Data type
+ CyclicTree
+ -- * Constructor functions
+ , node, node0, node1, node2, leaf, label
+ -- * Querying
+ , isNode, isLeaf, isLabel
+ -- * Replace functions
+ , replaceNode, replaceLeaf, replaceLabel, shrinkTree
+ -- * Fold and algebra
+ , fold, foldUnwind
+ , CyclicTreeAlg, fNode, fLeaf, fLabel, fRec, fVar
+ , emptyAlg, monoidAlg
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Foldable (Foldable, foldMap)
+import Data.List (intercalate)
+import Data.Traversable (Traversable, traverse, sequenceA)
+import Ideas.Common.Classes
+import Ideas.Common.Id
+import Test.QuickCheck hiding (label)
+
+--------------------------------------------------------------
+-- Data type
+
+data CyclicTree a b
+ = Node a [CyclicTree a b]
+ | Leaf b
+ | Label Id (CyclicTree a b)
+ | Rec Int (CyclicTree a b)
+ | Var Int
+
+instance (Show a, Show b) => Show (CyclicTree a b) where
+ show = fold Alg
+ { fNode = \a xs -> show a ++ par xs
+ , fLeaf = show
+ , fLabel = \l s -> show l ++ ":" ++ s
+ , fRec = \n s -> '#' : show n ++ "=" ++ s
+ , fVar = \n -> '#' : show n
+ }
+
+instance BiFunctor CyclicTree where
+ biMap f g = fold idAlg {fNode = Node . f, fLeaf = Leaf . g}
+
+instance Functor (CyclicTree d) where
+ fmap = mapSecond
+
+instance Applicative (CyclicTree d) where
+ pure = leaf
+ p <*> q = fold idAlg {fLeaf = (`fmap` q)} p
+
+instance Monad (CyclicTree d) where
+ return = leaf
+ (>>=) = flip replaceLeaf
+
+instance Foldable (CyclicTree d) where
+ foldMap f = fold monoidAlg {fLeaf = f}
+
+instance Traversable (CyclicTree d) where
+ traverse f = fold emptyAlg
+ { fNode = \a -> liftA (node a) . sequenceA
+ , fLeaf = liftA leaf . f
+ , fLabel = liftA . label
+ , fRec = liftA . Rec
+ , fVar = pure . Var
+ }
+
+instance Fix (CyclicTree a b) where
+ fix f = Rec n (f (Var n))
+ where
+ vs = vars (f (Var (-1)))
+ n = maximum (-1 : vs) + 1
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (CyclicTree a b) where
+ arbitrary = sized arbTree
+ shrink = shrinkTree
+
+arbTree :: (Arbitrary a, Arbitrary b) => Int -> Gen (CyclicTree a b)
+arbTree = rec 0
+ where
+ rec vi 0 = frequency $
+ (3, liftM leaf arbitrary)
+ : [ (1, elements (map Var [1..vi])) | vi > 0 ]
+ rec vi n = frequency
+ [ (3, liftM2 node arbitrary ms)
+ , (2, rec vi 0)
+ , (1, liftM2 label genId m)
+ , (1, liftM (Rec (vi+1)) (rec (vi+1) (n `div` 2)))
+ ]
+ where
+ m = rec vi (n `div` 2)
+ genId = elements [ newId [c] | c <- ['A' .. 'Z']]
+ ms = choose (0, 3) >>= \i -> replicateM i m
+
+shrinkTree :: CyclicTree a b -> [CyclicTree a b]
+shrinkTree tree =
+ case tree of
+ Node a ts -> ts ++ map (node a) (shrinkTrees ts)
+ Label l t -> t : map (Label l) (shrinkTree t)
+ Rec n t -> map (Rec n) (shrinkTree t)
+ _ -> []
+
+-- shrink exactly one tree
+shrinkTrees :: [CyclicTree a b] -> [[CyclicTree a b]]
+shrinkTrees [] = []
+shrinkTrees (t:ts) = map (:ts) (shrinkTree t) ++ map (t:) (shrinkTrees ts)
+
+-- local helpers
+par :: [String] -> String
+par xs | null xs = ""
+ | otherwise = "(" ++ intercalate ", " xs ++ ")"
+
+vars :: CyclicTree a b -> [Int]
+vars = fold monoidAlg {fVar = return}
+
+--------------------------------------------------------------
+-- Constructor functions
+
+node :: a -> [CyclicTree a b] -> CyclicTree a b
+node = Node
+
+node0 :: a -> CyclicTree a b
+node0 a = node a []
+
+node1 :: a -> CyclicTree a b -> CyclicTree a b
+node1 a x = node a [x]
+
+node2 :: a -> CyclicTree a b -> CyclicTree a b -> CyclicTree a b
+node2 a x y = node a [x, y]
+
+leaf :: b -> CyclicTree a b
+leaf = Leaf
+
+label :: IsId n => n -> CyclicTree a b -> CyclicTree a b
+label = Label . newId
+
+--------------------------------------------------------------
+-- Querying
+
+isNode :: CyclicTree a b -> Maybe (a, [CyclicTree a b])
+isNode (Node a xs) = Just (a, xs)
+isNode _ = Nothing
+
+isLeaf :: CyclicTree a b -> Maybe b
+isLeaf (Leaf b) = Just b
+isLeaf _ = Nothing
+
+isLabel :: CyclicTree a b -> Maybe (Id, CyclicTree a b)
+isLabel (Label l t) = Just (l, t)
+isLabel _ = Nothing
+
+--------------------------------------------------------------
+-- Replace functions
+
+replaceNode :: (a -> [CyclicTree a b] -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b
+replaceNode f = fold idAlg {fNode = f}
+
+replaceLabel :: (Id -> CyclicTree a b -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b
+replaceLabel f = fold idAlg {fLabel = f}
+
+replaceLeaf :: (b -> CyclicTree a c) -> CyclicTree a b -> CyclicTree a c
+replaceLeaf f = fold idAlg {fLeaf = f}
+
+--------------------------------------------------------------
+-- Fold and algebra
+
+fold :: CyclicTreeAlg a b t -> CyclicTree a b -> t
+fold alg = rec
+ where
+ rec (Node a ts) = fNode alg a (map rec ts)
+ rec (Leaf b) = fLeaf alg b
+ rec (Label l t) = fLabel alg l (rec t)
+ rec (Rec n t) = fRec alg n (rec t)
+ rec (Var n) = fVar alg n
+
+foldUnwind :: CyclicTreeAlg a b t -> CyclicTree a b -> t
+foldUnwind alg = start . fold Alg
+ { fNode = \a fs sub -> fNode alg a (map ($ sub) fs)
+ , fLeaf = \b _ -> fLeaf alg b
+ , fLabel = \l f sub -> fLabel alg l (f sub)
+ , fRec = \n f sub -> let this = f (extend n this sub)
+ in this
+ , fVar = \n sub -> sub n
+ }
+ where
+ start f = f (error "foldUnwind: unbound var")
+ extend n a sub i
+ | i == n = a
+ | otherwise = sub i
+
+data CyclicTreeAlg a b t = Alg
+ { fNode :: a -> [t] -> t
+ , fLeaf :: b -> t
+ , fLabel :: Id -> t -> t
+ , fRec :: Int -> t -> t
+ , fVar :: Int -> t
+ }
+
+idAlg :: CyclicTreeAlg a b (CyclicTree a b)
+idAlg = Alg Node Leaf Label Rec Var
+
+emptyAlg :: CyclicTreeAlg a b t
+emptyAlg = let f = error "emptyAlg: uninitialized" in Alg f f f f f
+
+monoidAlg :: Monoid m => CyclicTreeAlg a b m
+monoidAlg = Alg (const mconcat) mempty (const id) (const id) mempty
diff --git a/src/Ideas/Common/Derivation.hs b/src/Ideas/Common/Derivation.hs
--- a/src/Ideas/Common/Derivation.hs
+++ b/src/Ideas/Common/Derivation.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- and the steps)
--
-----------------------------------------------------------------------------
--- $Id: Derivation.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Derivation.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Derivation
( -- * Data type
diff --git a/src/Ideas/Common/DerivationTree.hs b/src/Ideas/Common/DerivationTree.hs
--- a/src/Ideas/Common/DerivationTree.hs
+++ b/src/Ideas/Common/DerivationTree.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- intermediate results as well as annotations for the steps.
--
-----------------------------------------------------------------------------
--- $Id: DerivationTree.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: DerivationTree.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.DerivationTree
( -- * Data types
diff --git a/src/Ideas/Common/Environment.hs b/src/Ideas/Common/Environment.hs
--- a/src/Ideas/Common/Environment.hs
+++ b/src/Ideas/Common/Environment.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- References, bindings, and heterogenous environments
--
-----------------------------------------------------------------------------
--- $Id: Environment.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Environment.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Environment
( -- * Reference
diff --git a/src/Ideas/Common/Exercise.hs b/src/Ideas/Common/Exercise.hs
--- a/src/Ideas/Common/Exercise.hs
+++ b/src/Ideas/Common/Exercise.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -15,7 +15,7 @@
-- "Ideas.Common.ExerciseTests" module.
--
-----------------------------------------------------------------------------
--- $Id: Exercise.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Exercise.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Exercise
( -- * Exercise record
@@ -258,6 +258,20 @@
show = (xs !!) . fromEnum
where
xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"]
+
+instance Read Difficulty where
+ readsPrec _ s =
+ case concatMap f txt of
+ "veryeasy" -> [(VeryEasy, xs)]
+ "easy" -> [(Easy, xs)]
+ "medium" -> [(Medium, xs)]
+ "difficult" -> [(Difficult, xs)]
+ "verydifficult" -> [(VeryDifficult, xs)]
+ _ -> []
+ where
+ (txt, xs) = span p (dropWhile isSpace s)
+ p c = isAlpha c || c `elem` "_-"
+ f c = [toLower c | c `notElem` "_-"]
-- | Parser for difficulty levels, which ignores non-alpha charactes (including
-- spaces) and upper/lower case distinction.
diff --git a/src/Ideas/Common/ExerciseTests.hs b/src/Ideas/Common/ExerciseTests.hs
--- a/src/Ideas/Common/ExerciseTests.hs
+++ b/src/Ideas/Common/ExerciseTests.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: ExerciseTests.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: ExerciseTests.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.ExerciseTests where
diff --git a/src/Ideas/Common/Id.hs b/src/Ideas/Common/Id.hs
--- a/src/Ideas/Common/Id.hs
+++ b/src/Ideas/Common/Id.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -30,7 +30,7 @@
-- The 'Id' datatype implements and re-exports the Monoid interface.
--
-----------------------------------------------------------------------------
--- $Id: Id.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Id.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Id
( -- * Constructing identifiers
diff --git a/src/Ideas/Common/Library.hs b/src/Ideas/Common/Library.hs
--- a/src/Ideas/Common/Library.hs
+++ b/src/Ideas/Common/Library.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Exports most from package Common
--
-----------------------------------------------------------------------------
--- $Id: Library.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Library.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Library
( module Export
diff --git a/src/Ideas/Common/Predicate.hs b/src/Ideas/Common/Predicate.hs
--- a/src/Ideas/Common/Predicate.hs
+++ b/src/Ideas/Common/Predicate.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Representation for predicates
--
-----------------------------------------------------------------------------
--- $Id: Predicate.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Predicate.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Predicate
( -- * Predicate representation
diff --git a/src/Ideas/Common/Rewriting.hs b/src/Ideas/Common/Rewriting.hs
--- a/src/Ideas/Common/Rewriting.hs
+++ b/src/Ideas/Common/Rewriting.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Rewriting.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Rewriting.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting (module Export) where
diff --git a/src/Ideas/Common/Rewriting/AC.hs b/src/Ideas/Common/Rewriting/AC.hs
--- a/src/Ideas/Common/Rewriting/AC.hs
+++ b/src/Ideas/Common/Rewriting/AC.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: AC.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: AC.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.AC
( -- * Types
diff --git a/src/Ideas/Common/Rewriting/Confluence.hs b/src/Ideas/Common/Rewriting/Confluence.hs
--- a/src/Ideas/Common/Rewriting/Confluence.hs
+++ b/src/Ideas/Common/Rewriting/Confluence.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Confluence.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Confluence.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.Confluence
( isConfluent, checkConfluence, checkConfluenceWith
diff --git a/src/Ideas/Common/Rewriting/Difference.hs b/src/Ideas/Common/Rewriting/Difference.hs
--- a/src/Ideas/Common/Rewriting/Difference.hs
+++ b/src/Ideas/Common/Rewriting/Difference.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- into account.
--
-----------------------------------------------------------------------------
--- $Id: Difference.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Difference.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.Difference
( difference, differenceEqual
diff --git a/src/Ideas/Common/Rewriting/RewriteRule.hs b/src/Ideas/Common/Rewriting/RewriteRule.hs
--- a/src/Ideas/Common/Rewriting/RewriteRule.hs
+++ b/src/Ideas/Common/Rewriting/RewriteRule.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: RewriteRule.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: RewriteRule.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.RewriteRule
( -- * Supporting type class
diff --git a/src/Ideas/Common/Rewriting/Substitution.hs b/src/Ideas/Common/Rewriting/Substitution.hs
--- a/src/Ideas/Common/Rewriting/Substitution.hs
+++ b/src/Ideas/Common/Rewriting/Substitution.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Substitutions on terms. Substitutions are idempotent, and non-cyclic.
--
-----------------------------------------------------------------------------
--- $Id: Substitution.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Substitution.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.Substitution
( Substitution, emptySubst, singletonSubst, dom, lookupVar
diff --git a/src/Ideas/Common/Rewriting/Term.hs b/src/Ideas/Common/Rewriting/Term.hs
--- a/src/Ideas/Common/Rewriting/Term.hs
+++ b/src/Ideas/Common/Rewriting/Term.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS -fno-warn-orphans #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -13,7 +13,7 @@
-- A simple data type for term rewriting
--
-----------------------------------------------------------------------------
--- $Id: Term.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Term.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.Term
( -- * Symbols
diff --git a/src/Ideas/Common/Rewriting/Unification.hs b/src/Ideas/Common/Rewriting/Unification.hs
--- a/src/Ideas/Common/Rewriting/Unification.hs
+++ b/src/Ideas/Common/Rewriting/Unification.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Unification.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Unification.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rewriting.Unification
( unify, match, matchExtended, matchList
diff --git a/src/Ideas/Common/Rule.hs b/src/Ideas/Common/Rule.hs
--- a/src/Ideas/Common/Rule.hs
+++ b/src/Ideas/Common/Rule.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Rule.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Rule.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rule (module Export) where
diff --git a/src/Ideas/Common/Rule/Abstract.hs b/src/Ideas/Common/Rule/Abstract.hs
--- a/src/Ideas/Common/Rule/Abstract.hs
+++ b/src/Ideas/Common/Rule/Abstract.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -14,7 +14,7 @@
-- can be lifted with a view using the LiftView type class.
--
-----------------------------------------------------------------------------
--- $Id: Abstract.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Abstract.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rule.Abstract
( -- * Rule data type and accessors
diff --git a/src/Ideas/Common/Rule/EnvironmentMonad.hs b/src/Ideas/Common/Rule/EnvironmentMonad.hs
--- a/src/Ideas/Common/Rule/EnvironmentMonad.hs
+++ b/src/Ideas/Common/Rule/EnvironmentMonad.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- State monad for environments
--
-----------------------------------------------------------------------------
--- $Id: EnvironmentMonad.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: EnvironmentMonad.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rule.EnvironmentMonad
( -- * Environment Monad
@@ -24,6 +24,7 @@
, envMonadRefs, envMonadFunctionRefs
) where
+import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad
import Data.Maybe
import Data.Typeable
@@ -51,6 +52,17 @@
(:~) :: Typeable a => Ref a -> (a -> a) -> EnvMonad ()
(:?) :: Typeable a => Ref a -> a -> EnvMonad a
GetRef :: Typeable a => Ref a -> EnvMonad a
+
+instance Functor EnvMonad where
+ fmap = liftM
+
+instance Applicative EnvMonad where
+ pure = return
+ (<*>) = ap
+
+instance Alternative EnvMonad where
+ empty = Zero
+ (<|>) = Plus
instance Monad EnvMonad where
return = Return
diff --git a/src/Ideas/Common/Rule/Parameter.hs b/src/Ideas/Common/Rule/Parameter.hs
--- a/src/Ideas/Common/Rule/Parameter.hs
+++ b/src/Ideas/Common/Rule/Parameter.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -15,7 +15,7 @@
-- the LiftView type class.
--
-----------------------------------------------------------------------------
--- $Id: Parameter.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Parameter.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rule.Parameter
( ParamTrans
diff --git a/src/Ideas/Common/Rule/Recognizer.hs b/src/Ideas/Common/Rule/Recognizer.hs
--- a/src/Ideas/Common/Rule/Recognizer.hs
+++ b/src/Ideas/Common/Rule/Recognizer.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Recognizer.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Recognizer.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rule.Recognizer
( -- * data type and type class
diff --git a/src/Ideas/Common/Rule/Transformation.hs b/src/Ideas/Common/Rule/Transformation.hs
--- a/src/Ideas/Common/Rule/Transformation.hs
+++ b/src/Ideas/Common/Rule/Transformation.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs, Rank2Types #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -13,7 +13,7 @@
-- a list of results (often a singleton list or the empty list).
--
-----------------------------------------------------------------------------
--- $Id: Transformation.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Transformation.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Rule.Transformation
( -- * Trans data type
diff --git a/src/Ideas/Common/Strategy.hs b/src/Ideas/Common/Strategy.hs
--- a/src/Ideas/Common/Strategy.hs
+++ b/src/Ideas/Common/Strategy.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,12 +9,13 @@
-- Portability : portable (depends on ghc)
--
-- A strategy is a context-free grammar with rules as symbols. Strategies can be
--- labeled with strings. A type class is introduced to lift all the combinators
--- that work on strategies, only to prevent that you have to insert these lifting
--- functions yourself.
+-- labeled with strings. The type class 'IsStrategy' is introduced to lift
+-- functions and combinators that work on strategies to also accept rules and
+-- labeled strategies. This module re-exports the most important functionality
+-- of the underlying modules.
--
-----------------------------------------------------------------------------
--- $Id: Strategy.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Strategy.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Strategy
( -- * Data types and type classes
@@ -24,27 +25,26 @@
, derivationList
-- * Strategy combinators
-- ** Basic combinators
- , (<*>), (<|>), (<%>), succeed, fail, atomic, label
- , sequence, alternatives, interleave, permute, fix
+ , (.*.), (.|.), (.%.), (.@.), (!~>)
+ , succeed, fail, atomic, label, inits
+ , sequence, choice, alternatives, interleave, permute
-- ** EBNF combinators
, many, many1, replicate, option
-- ** Negation and greedy combinators
- , check, not, repeat, repeat1, try, (|>), (>|>), exhaustive
- , while, until, multi
+ , check, not, repeat, repeat1, try, (|>), (./.)
+ , exhaustive, while, until
-- ** Graph
, DependencyGraph, dependencyGraph
-- ** Traversal combinators
, module Ideas.Common.Strategy.Traversal
-- * Configuration combinators
, module Ideas.Common.Strategy.Configuration
- , remove, collapse, hide
-- * Strategy locations
, strategyLocations, checkLocation
, subTaskLocation, nextTaskLocation
-- * Prefixes
, Prefix, emptyPrefix, noPrefix
, replayPath, replayPaths, replayStrategy
- , Step(..), stepRule, stepEnvironment
, Path, emptyPath, readPath, readPaths
, prefixPaths, majorPrefix, isEmptyPrefix
-- * Misc
@@ -55,7 +55,8 @@
import Ideas.Common.Strategy.Abstract
import Ideas.Common.Strategy.Combinators
import Ideas.Common.Strategy.Configuration
+import Ideas.Common.Strategy.Legacy (alternatives)
import Ideas.Common.Strategy.Location
-import Ideas.Common.Strategy.Parsing
+import Ideas.Common.Strategy.Prefix
import Ideas.Common.Strategy.Traversal hiding (full, spine, stop, once)
import Prelude ()
diff --git a/src/Ideas/Common/Strategy/Abstract.hs b/src/Ideas/Common/Strategy/Abstract.hs
--- a/src/Ideas/Common/Strategy/Abstract.hs
+++ b/src/Ideas/Common/Strategy/Abstract.hs
@@ -1,55 +1,91 @@
-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, RankNTypes #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
+-- Abstract data type for a 'Strategy' and a 'LabeledStrategy'.
+--
-----------------------------------------------------------------------------
--- $Id: Abstract.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Abstract.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Strategy.Abstract
- ( Strategy, IsStrategy(..)
+ ( -- * Strategy data type
+ Strategy
+ -- * Labeled strategies
, LabeledStrategy, label, unlabel
- , derivationList
+ -- * Lifting to strategies
+ , IsStrategy(..), liftS, liftS2, liftSn
+ -- * Prefixes
, emptyPrefix, replayPath, replayPaths, replayStrategy
- , rulesInStrategy
- , mapRules, mapRulesS
+ -- * Rules
+ , rulesInStrategy, mapRules, mapRulesS
, cleanUpStrategy, cleanUpStrategyAfter
- -- Accessors to the underlying representation
- , toCore, fromCore, liftCore, liftCore2
- , noInterleaving
+ , derivationList
+ -- * Access to underlying representation
+ , toStrategyTree, onStrategyTree
+ -- * Strategy declarations
+ , useDecl, decl0, decl1, decl2, declN
) where
-import Data.Function
+import Data.Foldable (toList)
import Ideas.Common.Classes
+import Ideas.Common.CyclicTree hiding (label)
import Ideas.Common.Derivation
import Ideas.Common.Environment
import Ideas.Common.Id
import Ideas.Common.Rewriting (RewriteRule)
import Ideas.Common.Rule
-import Ideas.Common.Strategy.Core
-import Ideas.Common.Strategy.Parsing
-import Ideas.Common.Strategy.Sequence (Firsts(..), firstsOrdered)
-import Ideas.Common.Utils.Uniplate hiding (rewriteM)
+import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.Prefix
+import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.Sequence (Sequence(..), ready)
+import Ideas.Common.Strategy.StrategyTree
+import Ideas.Common.Strategy.Symbol
import Ideas.Common.View
+import Prelude hiding (sequence)
+import qualified Ideas.Common.CyclicTree as Tree
-----------------------------------------------------------
--- Strategy data-type
-- | Abstract data type for strategies
-newtype Strategy a = S (Core a)
+newtype Strategy a = S { unS :: StrategyTree a }
instance Show (Strategy a) where
- show = show . toCore
+ show = show . unS
instance Apply Strategy where
- applyAll = runCore . toCore
+ applyAll = runProcess . getProcess
+instance Choice (Strategy a) where
+ empty = decl0 ("fail" .=. Nullary empty)
+ s .|. t = choice [s, t]
+
+ s |> t = orelse [s, t]
+ s ./. t = preference [s, t]
+
+ choice = declN (associative ("choice" .=. Nary choice))
+ preference = declN (associative ("preference" .=. Nary preference))
+ orelse = declN (associative ("orelse" .=. Nary orelse))
+
+instance Sequence (Strategy a) where
+ type Sym (Strategy a) = Rule a
+
+ done = decl0 ("succeed" .=. Nullary done)
+ a ~> s = sequence [toStrategy a, s]
+ s .*. t = sequence [s, t]
+ single = toStrategy
+ sequence = declN (associative ("sequence" .=. Nary sequence))
+
+instance Fix (Strategy a) where
+ fix f = S (fix (unS . f . S))
+
-----------------------------------------------------------
--- Type class
@@ -60,15 +96,25 @@
instance IsStrategy Strategy where
toStrategy = id
-instance IsStrategy (LabeledStrategy) where
- toStrategy (LS info (S core)) = S (Label info core)
+instance IsStrategy LabeledStrategy where
+ toStrategy (LS info (S t)) = S (Tree.label info t)
instance IsStrategy Rule where
- toStrategy = S . Rule
+ toStrategy = S . leaf
instance IsStrategy RewriteRule where
toStrategy = toStrategy . ruleRewrite
+liftS :: IsStrategy f => (Strategy a -> Strategy a) -> f a -> Strategy a
+liftS f = f . toStrategy
+
+liftS2 :: (IsStrategy f, IsStrategy g)
+ => (Strategy a -> Strategy a -> Strategy a) -> f a -> g a -> Strategy a
+liftS2 f = liftS . f . toStrategy
+
+liftSn :: IsStrategy f => ([Strategy a] -> Strategy a) -> [f a] -> Strategy a
+liftSn f = f . map toStrategy
+
-----------------------------------------------------------
--- Labeled Strategy data-type
@@ -98,13 +144,13 @@
-- | Construct the empty prefix for a labeled strategy
emptyPrefix :: IsStrategy f => f a -> a -> Prefix a
-emptyPrefix = makePrefix . toCore
+emptyPrefix = makePrefix . getProcess
-- | Construct a prefix for a path and a labeled strategy. The third argument
-- is the current term.
-replayPath :: IsStrategy f => Path -> f a -> a -> ([Step a], Prefix a)
+replayPath :: IsStrategy f => Path -> f a -> a -> ([Rule a], Prefix a)
replayPath path s a =
- let (xs, f) = replayCore path (toCore s)
+ let (xs, f) = replayProcess path (getProcess s)
in (xs, f a)
-- | Construct a prefix for a list of paths and a labeled strategy. The third
@@ -117,7 +163,7 @@
-- is the initial term.
replayStrategy :: (Monad m, IsStrategy f) => Path -> f a -> a -> m (a, Prefix a)
replayStrategy path s a =
- let (xs, f) = replayCore path (toCore s)
+ let (xs, f) = replayProcess path (getProcess s)
in case applyList xs a of
Just b -> return (b, f b)
Nothing -> fail "Cannot replay strategy"
@@ -128,22 +174,18 @@
derivationList :: IsStrategy f => (Rule a -> Rule a -> Ordering) -> f a -> a -> [Derivation (Rule a, Environment) a]
derivationList cmpRule s a0 = rec a0 (toPrefix s)
where
- toPrefix = majorPrefix . flip makePrefix a0 . toCore
+ toPrefix = majorPrefix . flip makePrefix a0 . getProcess
rec a prfx = (if ready prfx then (emptyDerivation a:) else id)
[ prepend (a, rEnv) d | (rEnv, b, new) <- firstsOrd prfx, d <- rec b new ]
- firstsOrd = map f . firstsOrdered cmp
+ firstsOrd = map f . firstsOrdered cmpRule
where
- cmp = cmpRule `on` (fst . g . fst)
-
- f ((stp, b), new) = (g stp, b, new)
-
- g stp = (stepRule stp, stepEnvironment stp)
+ f ((stp, b, env), new) = ((stp, env), b, new)
-- | Returns a list of all major rules that are part of a labeled strategy
rulesInStrategy :: IsStrategy f => f a -> [Rule a]
-rulesInStrategy s = [ r | Rule r <- universe (toCore s), isMajor r ]
+rulesInStrategy s = [ r | r <- toList (toStrategyTree s), isMajor r ]
instance LiftView LabeledStrategy where
liftViewIn = mapRules . liftViewIn
@@ -156,38 +198,48 @@
mapRules f (LS n s) = LS n (mapRulesS f s)
mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b
-mapRulesS f = S . fmap f . toCore
+mapRulesS f = S . fmap f . unS
-- | Use a function as do-after hook for all rules in a labeled strategy, but
-- also use the function beforehand
cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
-cleanUpStrategy f (LS n s) = cleanUpStrategyAfter f (LS n (make s))
- where
- make = liftCore2 (:*:) (doAfter f (idRule ()))
+cleanUpStrategy f (LS n s) = cleanUpStrategyAfter f $
+ LS n (doAfter f (idRule ()) ~> s)
-- | Use a function as do-after hook for all rules in a labeled strategy
cleanUpStrategyAfter :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
cleanUpStrategyAfter f = mapRules $ \r ->
if isMajor r then doAfter f r else r
-noInterleaving :: IsStrategy f => f a -> Strategy a
-noInterleaving = liftCore $ transform f
- where
- f (a :%: b) = a :*: b
- f (Atomic a) = a
- f s = s
-
-----------------------------------------------------------
--- Functions to lift the core combinators
-toCore :: IsStrategy f => f a -> Core a
-toCore s = let S core = toStrategy s in core
+toStrategyTree :: IsStrategy f => f a -> StrategyTree a
+toStrategyTree = unS . toStrategy
-fromCore :: Core a -> Strategy a
-fromCore = S
+onStrategyTree :: IsStrategy f => (StrategyTree a -> StrategyTree a) -> f a -> Strategy a
+onStrategyTree f = S . f . toStrategyTree
-liftCore :: IsStrategy f => (Core a -> Core a) -> f a -> Strategy a
-liftCore f = fromCore . f . toCore
+getProcess :: IsStrategy f => f a -> Process (Rule a)
+getProcess = foldUnwind emptyAlg
+ { fNode = fromNary . combinator
+ , fLeaf = single
+ , fLabel = \l p -> enterRule l ~> p .*. (exitRule l ~> done)
+ } . toStrategyTree
-liftCore2 :: (IsStrategy f, IsStrategy g) => (Core a -> Core a -> Core a) -> f a -> g a -> Strategy a
-liftCore2 f = liftCore . f . toCore
+-------------------------
+
+decl0 :: Decl Nullary -> Strategy a
+decl0 = fromNullary . useDecl
+
+decl1 :: IsStrategy f => Decl Unary -> f a -> Strategy a
+decl1 = liftS . fromUnary . useDecl
+
+decl2 :: (IsStrategy f, IsStrategy g) => Decl Binary -> f a -> g a -> Strategy a
+decl2 = liftS2 . fromBinary . useDecl
+
+declN :: IsStrategy f => Decl Nary -> [f a] -> Strategy a
+declN = liftSn . fromNary . useDecl
+
+useDecl :: Arity f => Decl f -> f (Strategy a)
+useDecl = liftIso (S <-> unS) . applyDecl
diff --git a/src/Ideas/Common/Strategy/Choice.hs b/src/Ideas/Common/Strategy/Choice.hs
--- a/src/Ideas/Common/Strategy/Choice.hs
+++ b/src/Ideas/Common/Strategy/Choice.hs
@@ -1,69 +1,73 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
--- A type class with an implementation for expressing choice and left-biased
--- choice.
+-- A type class for expressing choice, preference, and left-biased choice.
+-- The 'Menu' datatype implements the type class by keeping all the
+-- alternatives.
--
-----------------------------------------------------------------------------
--- $Id: Sequential.hs 6598 2014-06-04 14:59:01Z bastiaan $
+-- $Id: Choice.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Strategy.Choice
( -- * Choice type class
Choice(..)
-- * Menu data type
- , Menu, eqMenuBy
+ , Menu, (|->), doneMenu, eqMenuBy
-- * Queries
- , elems, bests, bestsOrdered, isEmpty, getByIndex
+ , elems, bests, bestsOrdered
+ , isEmpty, hasDone, getByIndex, cut
-- * Generalized functions
- , onMenu, cut, cutOn, mapWithIndex
+ , onMenu, onMenuWithIndex
) where
-import Data.Maybe (listToMaybe)
+import Data.Maybe
-infixr 3 <|>, >|>, |>, :|:, :>|, :|>
+infixr 3 .|., ./., |>, :|:, :/:, :|>
+infixr 5 |->, :->
------------------------------------------------------------------------
-- Choice type class
--- | Laws: '<|>', '>|>' '|>' are all associative, and have 'empty' as their
+-- | Laws: '.|.', './.' '|>' are all associative, and have 'empty' as their
-- unit element.
-class Choice f where
+class Choice a where
-- | Nothing to choose from.
- empty :: f a
- -- | One element.
- single :: a -> f a
+ empty :: a
-- | Normal (unbiased) choice.
- (<|>) :: f a -> f a -> f a
+ (.|.) :: a -> a -> a
-- | Left-preference.
- (>|>) :: f a -> f a -> f a
+ (./.) :: a -> a -> a
-- | Left-biased choice.
- (|>) :: f a -> f a -> f a
- -- | One element from a list (unbiased).
- oneof :: [a] -> f a
+ (|>) :: a -> a -> a
-- | One of the alternatives in a list (unbiased).
- choice :: [f a] -> f a
+ choice :: [a] -> a
+ preference :: [a] -> a
+ orelse :: [a] -> a
-- default implementation
- oneof = choice . map single
- choice xs
- | null xs = empty
- | otherwise = foldr1 (<|>) xs
+ choice xs = if null xs then empty else foldr1 (.|.) xs
+ preference xs = if null xs then empty else foldr1 (./.) xs
+ orelse xs = if null xs then empty else foldr1 (|>) xs
-instance Choice [] where
+instance Choice [a] where
empty = []
- single = return
- (<|>) = (++)
- (>|>) = (++)
+ (.|.) = (++)
+ (./.) = (++)
xs |> ys = if null xs then ys else xs
- oneof = id
choice = concat
+instance Choice b => Choice (a -> b) where
+ empty = const empty
+ (f .|. g) a = f a .|. g a
+ (f ./. g) a = f a ./. g a
+ (f |> g) a = f a |> g a
+
------------------------------------------------------------------------
-- Menu data type
@@ -71,22 +75,23 @@
-- (Unit) The left-hand side of :|: and :|> cannot be Empty
-- (Asso) :|: and :|> are balanced to the right
--- | A menu offers choices and preferences. It is an instance of the 'Functor'
--- and 'Monad' type classes.
-data Menu a = Single a
- | Empty
- | Menu a :|: Menu a
- | Menu a :>| Menu a -- left-preference
- | Menu a :|> Menu a -- left-biased
+-- | A menu offers choices and preferences. It stores singleton bindings (thus
+-- acting as a finite map) and one special element ('doneMenu'). It is an
+-- instance of the 'Functor' and 'Monad' type classes.
+data Menu k a = k :-> a
+ | Done
+ | Empty
+ | Menu k a :|: Menu k a
+ | Menu k a :/: Menu k a -- left-preference
+ | Menu k a :|> Menu k a -- left-biased
-instance Eq a => Eq (Menu a) where
- (==) = eqMenuBy (==)
+instance (Eq k, Eq a) => Eq (Menu k a) where
+ (==) = eqMenuBy (==) (==)
-instance Choice Menu where
+instance Choice (Menu k a) where
empty = Empty
- single = Single
- p0 <|> rest = rec p0 -- maintain invariant
+ p0 .|. rest = rec p0 -- maintain invariant
where
rec Empty = rest
rec (p :|: q) = p :|: rec q
@@ -94,11 +99,11 @@
Empty -> p
_ -> p :|: rest
- p0 >|> rest = rec p0 -- maintain invariant
+ p0 ./. rest = rec p0 -- maintain invariant
where
rec Empty = rest
- rec (p :>| q) = p :>| rec q
- rec p = p :>| rest
+ rec (p :/: q) = p :/: rec q
+ rec p = p :/: rest
p0 |> rest = rec p0 -- maintain invariant
where
@@ -106,26 +111,45 @@
rec (p :|> q) = p :|> rec q
rec p = p :|> rest
-instance Functor Menu where
- fmap f p = p >>= (Single . f)
+instance Functor (Menu k) where
+ fmap f = rec
+ where
+ rec (p :|: q) = rec p :|: rec q
+ rec (p :/: q) = rec p :/: rec q
+ rec (p :|> q) = rec p :|> rec q
+ rec (k :-> a) = k :-> f a
+ rec Done = Done
+ rec Empty = Empty
-instance Monad Menu where
- return = single
- fail _ = empty
- (>>=) = flip onMenu
+-- | Singleton binding
+(|->) :: a -> s -> Menu a s
+(|->) = (:->)
+-- | Special element for denoting success
+doneMenu :: Menu k a
+doneMenu = Done
+
+hasDone :: Menu k a -> Bool
+hasDone (p :|: q) = hasDone p || hasDone q
+hasDone (p :/: q) = hasDone p || hasDone q
+hasDone (p :|> _) = hasDone p
+hasDone (_ :-> _) = False
+hasDone Done = True
+hasDone Empty = False
+
-- | Equality with a comparison function for the elements
-eqMenuBy :: (a -> a -> Bool) -> Menu a -> Menu a -> Bool
-eqMenuBy eq = test
+eqMenuBy :: (k -> k -> Bool) -> (a -> a -> Bool) -> Menu k a -> Menu k a -> Bool
+eqMenuBy eqK eqA = test
where
test (p1 :|: p2) (q1 :|: q2) = test p1 q1 && test p2 q2
- test (p1 :>| p2) (q1 :>| q2) = test p1 q1 && test p2 q2
+ test (p1 :/: p2) (q1 :/: q2) = test p1 q1 && test p2 q2
test (p1 :|> p2) (q1 :|> q2) = test p1 q1 && test p2 q2
- test (Single a) (Single b) = eq a b
+ test (k1 :-> a1) (k2 :-> a2) = eqK k1 k2 && eqA a1 a2
+ test Done Done = True
test Empty Empty = True
- test (p :>| Empty) q = test p q
+ test (p :/: Empty) q = test p q
test (p :|> Empty) q = test p q
- test p (q :>| Empty) = test p q
+ test p (q :/: Empty) = test p q
test p (q :|> Empty) = test p q
test _ _ = False
@@ -133,100 +157,91 @@
-- Queries
-- | Returns all elements that are in the menu.
-elems :: Menu a -> [a]
+elems :: Menu k a -> [(k, a)]
elems = ($ []) . rec
where
- rec (p :|: q) = rec p . rec q
- rec (p :>| q) = rec p . rec q
- rec (p :|> q) = rec p . rec q
- rec (Single p) = (p:)
- rec Empty = id
+ rec (p :|: q) = rec p . rec q
+ rec (p :/: q) = rec p . rec q
+ rec (p :|> q) = rec p . rec q
+ rec (k :-> a) = ((k, a):)
+ rec Done = id
+ rec Empty = id
--- | Returns only the best elements that are in the menu.
-bests :: Menu a -> [a]
-bests (p :|: q) = bests p ++ bests q
-bests (p :>| q) = bests p ++ bests q
-bests (p :|> q) = bests p |> bests q
-bests (Single a) = [a]
-bests Empty = []
+-- | Returns only the best elements that are in the menu with respect to
+-- left-biased choices.
+bests :: Menu k a -> [(k, a)]
+bests = bestsWith (++)
-- | Returns only the best elements that are in the menu, with a given ordering.
-bestsOrdered :: (a -> a -> Ordering) -> Menu a -> [a]
-bestsOrdered cmp = rec
+bestsOrdered :: (k -> k -> Ordering) -> Menu k a -> [(k, a)]
+bestsOrdered cmp = bestsWith merge
where
- rec (p :|: q) = merge (rec p) (rec q)
- rec (p :>| q) = rec p ++ rec q
- rec (p :|> q) = rec p |> rec q
- rec (Single a) = [a]
- rec Empty = []
-
-- merge two lists with comparison function
- merge lx@(x:xs) ly@(y:ys)
- | cmp x y == GT = y : merge lx ys
- | otherwise = x : merge xs ly
+ merge lx@(x:xs) ly@(y:ys) =
+ case cmp (fst x) (fst y) of
+ GT -> y : merge lx ys
+ _ -> x : merge xs ly
merge [] ys = ys
merge xs [] = xs
+-- helper: takes combinator for (:|:)
+bestsWith:: ([(k, a)] -> [(k, a)] -> [(k, a)]) -> Menu k a -> [(k, a)]
+bestsWith f = rec
+ where
+ rec (p :|: q) = f (rec p) (rec q)
+ rec (p :/: q) = rec p ++ rec q
+ rec (p :|> _) = rec p
+ rec (k :-> a) = [(k, a)]
+ rec Done = []
+ rec Empty = []
+
-- | Is the menu empty?
-isEmpty :: Menu a -> Bool
+isEmpty :: Menu k a -> Bool
isEmpty Empty = True
isEmpty _ = False -- because of invariant
-- | Get an element from the menu by its index.
-getByIndex :: Int -> Menu a -> Maybe a
+getByIndex :: Int -> Menu k a -> Maybe (k, a)
getByIndex n = listToMaybe . drop n . elems
+-- | Only keep the best elements in the menu.
+cut :: Menu k a -> Menu k a
+cut (p :|: q) = cut p .|. cut q
+cut (p :/: q) = cut p ./. cut q
+cut (p :|> _) = cut p
+cut (k :-> a) = k |-> a
+cut Done = doneMenu
+cut Empty = empty
+
------------------------------------------------------------------------
-- Generalized functions
-- | Generalized monadic bind, with the arguments flipped.
{-# INLINE onMenu #-}
-onMenu :: Choice f => (a -> f b) -> Menu a -> f b
-onMenu f = rec
- where
- rec (p :|: q) = rec p <|> rec q
- rec (p :>| q) = rec p >|> rec q
- rec (p :|> q) = rec p |> rec q
- rec (Single a) = f a
- rec Empty = empty
-
--- | Only keep the best elements in the menu.
-{-# INLINE cut #-}
-cut :: Choice f => Menu a -> f a
-cut (p :|: q) = cut p <|> cut q
-cut (p :>| q) = cut p >|> cut q
-cut (p :|> _) = cut p
-cut (Single a) = single a
-cut Empty = empty
-
-cutOn :: Choice f => (a -> Bool) -> Menu a -> f a
-cutOn f = snd . rec
+onMenu :: Choice b => (k -> a -> b) -> b -> Menu k a -> b
+onMenu f e = rec
where
- rec (p :|: q) = let (b1, cp) = rec p
- (b2, cq) = rec q
- in (b1 || b2, cp <|> cq)
- rec (p :>| q) = let (b1, cp) = rec p
- (b2, cq) = rec q
- in (b1 || b2, cp >|> cq)
- rec (p :|> q) = let (b1, cp) = rec p
- (b2, cq) = rec q
- in (b1 || b2, if b1 then cp else cp |> cq)
- rec (Single a) = (f a, single a)
- rec Empty = (False, empty)
+ rec (p :|: q) = rec p .|. rec q
+ rec (p :/: q) = rec p ./. rec q
+ rec (p :|> q) = rec p |> rec q
+ rec (k :-> a) = f k a
+ rec Done = e
+ rec Empty = empty
-- | Maps a function over a menu that also takes the index of an element.
-{-# INLINE mapWithIndex #-}
-mapWithIndex :: Choice f => (Int -> a -> f b) -> Menu a -> f b
-mapWithIndex f = snd . rec 0
+{-# INLINE onMenuWithIndex #-}
+onMenuWithIndex :: Choice b => (Int -> k -> a -> b) -> b -> Menu k a -> b
+onMenuWithIndex f e = snd . rec 0
where
- rec n (p :|: q) = let (n1, pn) = rec n p
- (n2, qn) = rec n1 q
- in (n2, pn <|> qn)
- rec n (p :>| q) = let (n1, pn) = rec n p
- (n2, qn) = rec n1 q
- in (n2, pn >|> qn)
- rec n (p :|> q) = let (n1, pn) = rec n p
- (n2, qn) = rec n1 q
- in (n2, pn |> qn)
- rec n (Single a) = (n+1, f n a)
- rec n Empty = (n, empty)
+ rec n (p :|: q) = let (n1, pn) = rec n p
+ (n2, qn) = rec n1 q
+ in (n2, pn .|. qn)
+ rec n (p :/: q) = let (n1, pn) = rec n p
+ (n2, qn) = rec n1 q
+ in (n2, pn ./. qn)
+ rec n (p :|> q) = let (n1, pn) = rec n p
+ (n2, qn) = rec n1 q
+ in (n2, pn |> qn)
+ rec n (k :-> a) = (n+1, f n k a)
+ rec n Done = (n, e)
+ rec n Empty = (n, empty)
diff --git a/src/Ideas/Common/Strategy/Combinators.hs b/src/Ideas/Common/Strategy/Combinators.hs
--- a/src/Ideas/Common/Strategy/Combinators.hs
+++ b/src/Ideas/Common/Strategy/Combinators.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,19 +12,24 @@
-- data types
--
-----------------------------------------------------------------------------
--- $Id: Combinators.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Combinators.hs 8745 2015-10-15 14:45:46Z bastiaan $
module Ideas.Common.Strategy.Combinators where
import Data.Array
import Data.Graph
import Data.List ((\\))
+import Ideas.Common.CyclicTree hiding (label)
import Ideas.Common.Id
import Ideas.Common.Rule
import Ideas.Common.Strategy.Abstract
-import Ideas.Common.Strategy.Core
+import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.StrategyTree
import Ideas.Common.Utils (fst3)
import Prelude hiding (not, repeat, fail, sequence)
+import qualified Ideas.Common.Strategy.Choice as Choice
+import qualified Ideas.Common.Strategy.Derived as Derived
+import qualified Ideas.Common.Strategy.Sequence as Sequence
import qualified Prelude
-----------------------------------------------------------
@@ -32,72 +37,90 @@
-- Basic combinators --------------------------------------
-infixr 2 <%>, <@>
-infixr 3 <|>
-infixr 4 >|>, |>
-infixr 5 <*>
+infixr 2 .%., .@.
+infixr 3 .|.
+infixr 4 ./., |>
+infixr 5 .*., !~>
-- | Put two strategies in sequence (first do this, then do that)
-(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<*>) = liftCore2 (:*:)
+(.*.) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(.*.) = liftS2 (Sequence..*.)
-- | Choose between the two strategies (either do this or do that)
-(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<|>) = liftCore2 (:|:)
+(.|.) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(.|.) = liftS2 (Choice..|.)
-- | Interleave two strategies
-(<%>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<%>) = liftCore2 (:%:)
+(.%.) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+s .%. t = interleave [toStrategy s, toStrategy t]
-- | Alternate two strategies
-(<@>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<@>) = liftCore2 (:@:)
+(.@.) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(.@.) = decl2 $ "alternate" .=. Binary (Derived.<@>)
+-- | Prefixing a basic rule to a strategy atomically
+(!~>) :: IsStrategy f => Rule a -> f a -> Strategy a
+(!~>) = decl2 $ "atomicprefix" .=. Binary (Derived.!*>)
+
+-- | Initial prefixes (allows the strategy to stop succesfully at any time)
+inits :: IsStrategy f => f a -> Strategy a
+inits = decl1 $ "inits" .=. Unary Derived.inits
+
-- | The strategy that always succeeds (without doing anything)
succeed :: Strategy a
-succeed = fromCore Succeed
+succeed = Sequence.done
-- | The strategy that always fails
fail :: Strategy a
-fail = fromCore Fail
+fail = Choice.empty
-- | Makes a strategy atomic (w.r.t. parallel composition)
atomic :: IsStrategy f => f a -> Strategy a
-atomic = liftCore Atomic
+atomic = decl1 $ "atomic" .=. Unary Derived.atomic
-- | Puts a list of strategies into a sequence
sequence :: IsStrategy f => [f a] -> Strategy a
-sequence = foldr ((<*>) . toStrategy) succeed
+sequence = Sequence.sequence . map toStrategy
-- | Combines a list of alternative strategies
-alternatives :: IsStrategy f => [f a] -> Strategy a
-alternatives = foldr ((<|>) . toStrategy) fail
+choice :: IsStrategy f => [f a] -> Strategy a
+choice = Choice.choice . map toStrategy
-- | Merges a list of strategies (in parallel)
interleave :: IsStrategy f => [f a] -> Strategy a
-interleave = foldr ((<%>) . toStrategy) succeed
+interleave = declN $ associative (interleaveId .=. Nary Derived.interleave)
+noInterleaving :: IsStrategy f => f a -> Strategy a
+noInterleaving = onStrategyTree (replaceNode f)
+ where
+ f d = if getId d == interleaveId
+ then fromNary (applyDecl ("sequence" .=. Nary Sequence.sequence)) -- fix me
+ else node d
+
+interleaveId :: Id
+interleaveId = newId "interleave"
+
-- | Allows all permutations of the list
permute :: IsStrategy f => [f a] -> Strategy a
-permute = foldr ((<%>) . atomic) succeed
+permute = declN $ "permute" .=. Nary Derived.permute
-- EBNF combinators --------------------------------------
-- | Repeat a strategy zero or more times (non-greedy)
many :: IsStrategy f => f a -> Strategy a
-many a = fix $ \x -> succeed <|> (a <*> x)
+many = decl1 $ "many" .=. Unary Derived.many
-- | Apply a certain strategy at least once (non-greedy)
many1 :: IsStrategy f => f a -> Strategy a
-many1 s = s <*> many s
+many1 = decl1 $ "many1" .=. Unary Derived.many1
-- | Apply a strategy a certain number of times
replicate :: IsStrategy f => Int -> f a -> Strategy a
-replicate n = sequence . Prelude.replicate n
+replicate n = decl1 $ ("replicate" # show n) .=. Unary (Derived.replicate n)
-- | Apply a certain strategy or do nothing (non-greedy)
option :: IsStrategy f => f a -> Strategy a
-option s = s <|> succeed
+option = decl1 $ "option" .=. Unary Derived.option
-- Negation and greedy combinators ----------------------
@@ -109,60 +132,43 @@
-- | Check whether or not the argument strategy cannot be applied: the result
-- strategy only succeeds if this is not the case (otherwise it fails).
not :: IsStrategy f => f a -> Strategy a
-not = liftCore Not
+not = decl1 $ "not" .=. Unary (\x ->
+ Sequence.single $ checkRule "core.not" $ null . runProcess x)
-- | Repeat a strategy zero or more times (greedy version of 'many')
repeat :: IsStrategy f => f a -> Strategy a
-repeat a = fix $ \x -> (a <*> x) |> succeed
+repeat = decl1 $ "repeat" .=. Unary Derived.repeat
-- | Apply a certain strategy at least once (greedy version of 'many1')
repeat1 :: IsStrategy f => f a -> Strategy a
-repeat1 s = s <*> repeat s
+repeat1 = decl1 $ "repeat1" .=. Unary Derived.repeat1
-- | Apply a certain strategy if this is possible (greedy version of 'option')
try :: IsStrategy f => f a -> Strategy a
-try s = s |> succeed
+try = decl1 $ "try" .=. Unary Derived.try
-- | Choose between the two strategies, with a preference for steps from the
-- left hand-side strategy.
-(>|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(>|>) = liftCore2 (:>|>)
+(./.) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(./.) = liftS2 (Choice../.)
-- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise,
-- try the right-operand strategy
(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(|>) = liftCore2 (:|>:)
--- s |> t = s <|> (not s <*> t)
+(|>) = liftS2 (Choice.|>)
+-- s |> t = s <|> (not s .*. t)
-- | Repeat the strategy as long as the predicate holds
while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
-while p s = repeat (check p <*> s)
+while p s = repeat (check p .*. s)
-- | Repeat the strategy until the predicate holds
until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
until p = while (Prelude.not . p)
--- | Apply a strategy at least once, but collapse into a single step
-multi :: (IsId l, IsStrategy f) => l -> f a -> Strategy a
-multi l = collapse . label l . repeat1
-
-- | Apply the strategies from the list exhaustively (until this is no longer possible)
exhaustive :: IsStrategy f => [f a] -> Strategy a
-exhaustive = repeat . alternatives
-
--- | A fix-point combinator on strategies (to model recursion). Powerful
--- (but dangerous) combinator
-fix :: (Strategy a -> Strategy a) -> Strategy a
-fix f = fromCore (coreFix (toCore . f . fromCore))
-
-remove :: IsStrategy f => f a -> Strategy a
-remove = liftCore Remove
-
-collapse :: IsStrategy f => f a -> Strategy a
-collapse = liftCore Collapse
-
-hide :: IsStrategy f => f a -> Strategy a
-hide = liftCore Hide
+exhaustive = declN $ "exhaustive" .=. Nary Derived.exhaustive
-- Graph to strategy ----------------------
@@ -175,8 +181,8 @@
where
g2s seen
| null reachables = succeed
- | otherwise = alternatives $ map makePath reachables
+ | otherwise = choice $ map makePath reachables
where
reachables = filter isReachable $ vertices graph \\ seen
isReachable = null . (\\ seen) . (graph!)
- makePath vertex = (fst3 . vertex2data) vertex <*> g2s (vertex:seen)
+ makePath vertex = (fst3 . vertex2data) vertex .*. g2s (vertex:seen)
diff --git a/src/Ideas/Common/Strategy/Configuration.hs b/src/Ideas/Common/Strategy/Configuration.hs
--- a/src/Ideas/Common/Strategy/Configuration.hs
+++ b/src/Ideas/Common/Strategy/Configuration.hs
@@ -1,29 +1,40 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
+-- Strategies can be configured at their labeled positions. Possible actions
+-- are remove/reinsert, collapse/expand, and hide/reveal.
+--
-----------------------------------------------------------------------------
--- $Id: Configuration.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Configuration.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Strategy.Configuration
( StrategyCfg, byName, ConfigAction(..)
, configure, configureS
- , module Data.Monoid
+ , remove, collapse, hide, multi
+ , isConfigId
) where
import Data.Char
import Data.Monoid
+import Ideas.Common.Classes
+import Ideas.Common.CyclicTree hiding (label)
import Ideas.Common.Id
+import Ideas.Common.Rule
import Ideas.Common.Strategy.Abstract
-import Ideas.Common.Strategy.Core hiding (Remove, Collapse, Hide)
-import Ideas.Common.Utils.Uniplate
-import qualified Ideas.Common.Strategy.Core as Core
+import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.Derived (repeat1)
+import Ideas.Common.Strategy.Process hiding (fold)
+import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Strategy.StrategyTree
+import Ideas.Common.Strategy.Symbol
+import qualified Ideas.Common.CyclicTree as Tree
---------------------------------------------------------------------
-- Types and constructors
@@ -64,45 +75,76 @@
configure cfg ls = label (getId ls) (configureS cfg (unlabel ls))
configureS :: StrategyCfg -> Strategy a -> Strategy a
-configureS cfg = fromCore . configureCore cfg . toCore
+configureS = onStrategyTree . configureStrategyTree
-configureCore :: StrategyCfg -> Core a -> Core a
-configureCore (Cfg pairs) = rec
+configureStrategyTree :: StrategyCfg -> StrategyTree a -> StrategyTree a
+configureStrategyTree (Cfg pairs) tree = foldr handle tree pairs
where
- rec core =
- case core of
- Core.Remove s | has Reinsert -> rec s
- Core.Collapse s | has Expand -> rec s
- Core.Hide s | has Reveal -> rec s
- Label l s -> props (Label l (rec s))
- Rule r -> props (Rule r)
- _ -> descend rec core
- where
- myLabel = getLabel core
- actions = cancel [ a | (loc, a) <- pairs, maybe False (here loc) myLabel ]
- has = (`elem` actions)
- make x g = if has x then g else id
+ handle (ByName l, action) =
+ case action of
+ Remove -> insertAtLabel l removeDecl
+ Reinsert -> removeAtLabel l removeDecl
+ Collapse -> insertAtLabel l collapseDecl
+ Expand -> removeAtLabel l collapseDecl
+ Hide -> insertAtLabel l hideDecl
+ Reveal -> removeAtLabel l hideDecl
- props = make Remove Core.Remove
- . make Hide Core.Hide
- . make Collapse Core.Collapse
+insertAtLabel :: Id -> Decl Unary -> StrategyTree a -> StrategyTree a
+insertAtLabel n comb = replaceLeaf f . replaceLabel g
+ where
+ f a | n == getId a = fromUnary (applyDecl comb) (leaf a)
+ | otherwise = leaf a
-here :: ConfigLocation -> Id -> Bool
-here (ByName a) info = getId info == a
+ g l a | n == l = fromUnary (applyDecl comb) (Tree.label l a)
+ | otherwise = Tree.label l a
-getLabel :: Core a -> Maybe Id
-getLabel (Label l _) = Just l
-getLabel (Rule r) = Just (getId r)
-getLabel (Core.Remove s) = getLabel s
-getLabel (Core.Collapse s) = getLabel s
-getLabel (Core.Hide s) = getLabel s
-getLabel _ = Nothing
+removeAtLabel :: Id -> Decl Unary -> StrategyTree a -> StrategyTree a
+removeAtLabel n _decl = replaceNode $ \d xs -> -- fix me: use decl
+ case map nextId xs of
+ [Just l] | n == l -> head xs
+ _ -> node d xs
-cancel :: [ConfigAction] -> [ConfigAction]
-cancel [] = []
-cancel (x:xs) = x : cancel (rec actionGroups)
+nextId :: StrategyTree a -> Maybe Id
+nextId = fold monoidAlg
+ { fNode = \d xs -> if isConfigId d && length xs == 1
+ then head xs
+ else Nothing
+ , fLeaf = Just . getId
+ , fLabel = \l _ -> Just l
+ }
+
+isConfigId :: HasId a => a -> Bool
+isConfigId = (`elem` map getId configIds) . getId
+
+---------------------------------------------------------------------
+-- Combinator definitions
+
+remove, collapse, hide :: IsStrategy f => f a -> Strategy a
+remove = decl1 removeDecl
+collapse = decl1 collapseDecl
+hide = decl1 hideDecl
+
+-- | Apply a strategy at least once, but collapse into a single step
+multi :: (IsId l, IsStrategy f) => l -> f a -> Strategy a
+multi l = collapse . label l . decl1 repeatDecl . toStrategy
+
+repeatDecl :: Decl Unary -- fix me: overlap with combinators
+repeatDecl = "repeat1" .=. Unary repeat1
+
+configIds :: [Id]
+configIds = map getId [removeDecl, collapseDecl, hideDecl]
+
+removeDecl :: Decl Unary
+removeDecl = "removed" .=. Unary (const empty)
+
+collapseDecl :: Decl Unary
+collapseDecl = "collapsed" .=. Unary (\a ->
+ case firsts a of
+ [(r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r)
+ _ -> empty)
where
- rec (g:gs)
- | x `elem` g = filter (`notElem` g) xs
- | otherwise = rec gs
- rec [] = xs
+ collapseWith l =
+ single . makeRule l . runProcess
+
+hideDecl :: Decl Unary
+hideDecl = "hidden" .=. Unary (fmap minor)
diff --git a/src/Ideas/Common/Strategy/Core.hs b/src/Ideas/Common/Strategy/Core.hs
deleted file mode 100644
--- a/src/Ideas/Common/Strategy/Core.hs
+++ /dev/null
@@ -1,166 +0,0 @@
------------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer : bastiaan.heeren@ou.nl
--- Stability : provisional
--- Portability : portable (depends on ghc)
---
--- The core strategy combinators. This module defines the interal data
--- structure of a strategy, and some utility functions that operate
--- directly on it.
---
------------------------------------------------------------------------------
--- $Id: Core.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Strategy.Core
- ( GCore(..), Core
- , coreFix, coreSubstAll, substCoreVar
- ) where
-
-import Data.Maybe
-import Ideas.Common.Classes
-import Ideas.Common.Id
-import Ideas.Common.Rule
-import Ideas.Common.Strategy.Choice
-import Ideas.Common.Strategy.Sequence
-import Ideas.Common.Utils.Uniplate
-
------------------------------------------------------------------
--- Strategy (internal) data structure, containing a selection
--- of combinators
-
-infixr 2 :%:, :@:
-infixr 3 :|:, :>|>, :|>:
-infixr 5 :*:
-
--- | Core expression, with rules
-type Core a = GCore (Rule a)
-
--- | An environment with generalized Core expressions
-type CoreEnv a = [(Int, GCore a)]
-
--- | A generalized Core expression, not restricted to rules. This makes GCore
--- a (traversable and foldable) functor.
-data GCore a
- = GCore a :*: GCore a
- | GCore a :|: GCore a
- | GCore a :>|> GCore a -- left-preference (choice)
- | GCore a :|>: GCore a -- left-biased choice
- | GCore a :%: GCore a -- interleave
- | GCore a :@: GCore a -- alternate
- | Label Id (GCore a)
- | Atomic (GCore a)
- | Not (GCore a)
- | Remove (GCore a) -- config: replaced by fail
- | Collapse (GCore a) -- config: execute labeled sub-strategy as 1 step
- | Hide (GCore a) -- config: make all steps invisible/minor
- | Succeed
- | Fail
- | Rule a -- ^ Generalized constructor (not restricted to rules)
- | Var Int
- | Let (CoreEnv a) (GCore a)
- deriving Show
-
-instance Choice GCore where
- empty = Fail
- single = Rule
- (<|>) = (:|:)
- (>|>) = (:>|>)
- (|>) = (:|>:)
-
-instance Sequence GCore where
- done = Succeed
- (~>) = (:*:) . Rule
- (<*>) = (:*:)
-
------------------------------------------------------------------
--- Useful instances
-
-instance Functor GCore where
- fmap f = rec
- where
- rec core =
- case core of
- a :*: b -> rec a :*: rec b
- a :|: b -> rec a :|: rec b
- a :>|> b -> rec a :>|> rec b
- a :|>: b -> rec a :|>: rec b
- a :%: b -> rec a :%: rec b
- a :@: b -> rec a :@: rec b
- Atomic a -> Atomic (rec a)
- Not a -> Not (rec a)
- Remove a -> Remove (rec a)
- Collapse a -> Collapse (rec a)
- Hide a -> Hide (rec a)
- Let ds a -> Let (map (mapSecond rec) ds) (rec a)
- Label l a -> Label l (rec a)
- Rule a -> Rule (f a)
- Var n -> Var n
- Succeed -> Succeed
- Fail -> Fail
-
-instance Uniplate (GCore a) where
- uniplate core =
- case core of
- a :*: b -> plate (:*:) |* a |* b
- a :|: b -> plate (:|:) |* a |* b
- a :>|> b -> plate (:>|>) |* a |* b
- a :|>: b -> plate (:|>:) |* a |* b
- a :%: b -> plate (:%:) |* a |* b
- a :@: b -> plate (:@:) |* a |* b
- Label l a -> plate Label |- l |* a
- Atomic a -> plate Atomic |* a
- Not a -> plate Not |* a
- Remove a -> plate Remove |* a
- Collapse a -> plate Collapse |* a
- Hide a -> plate Hide |* a
- Let ds a -> let (ns, bs) = unzip ds
- make = Let . zip ns
- in plate make ||* bs |* a
- _ -> plate core
-
------------------------------------------------------------------
--- Definitions
-
-coreFix :: (GCore a -> GCore a) -> GCore a
-coreFix f = -- disadvantage: function f is applied twice
- let i = nextVar (f (Var (-1)))
- in coreRec i (f (Var i))
-
-coreRec :: Int -> GCore a -> GCore a
-coreRec n a = Let [(n, a)] (Var n)
-
-coreSubstAll :: GCore a -> GCore a
-coreSubstAll = rec []
- where
- rec xs (Var i) = fromMaybe (error "coreInf") (lookup i xs)
- rec xs (Let ds a) = let this = [ (n, rec this b) | (n, b) <- ds ] ++ xs
- in rec this a
- rec xs core = descend (rec xs) core
-
------------------------------------------------------------------
--- Utility functions
-
-substCoreVar :: Int -> GCore a -> GCore a -> GCore a
-substCoreVar i a core =
- case core of
- Var j | i==j -> a
- Let ds _ | i `elem` map fst ds -> core
- _ -> descend (substCoreVar i a) core
-
-nextVar :: GCore a -> Int
-nextVar p
- | null xs = 0
- | otherwise = maximum xs + 1
- where xs = coreVars p
-
-coreVars :: GCore a -> [Int]
-coreVars core =
- case core of
- Var n -> [n]
- Let ds a -> let (ns, bs) = unzip ds
- in ns ++ concatMap coreVars (bs ++ [a])
- _ -> concatMap coreVars (children core)
diff --git a/src/Ideas/Common/Strategy/Derived.hs b/src/Ideas/Common/Strategy/Derived.hs
--- a/src/Ideas/Common/Strategy/Derived.hs
+++ b/src/Ideas/Common/Strategy/Derived.hs
@@ -1,62 +1,146 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
+-- This module defines extra combinators.
+--
-----------------------------------------------------------------------------
--- $Id: Sequential.hs 6612 2014-06-12 07:57:59Z bastiaan $
+-- $Id: Derived.hs 8747 2015-10-15 14:54:48Z bastiaan $
module Ideas.Common.Strategy.Derived
- ( filterP, hide
- , fromAtoms, Sym(..), atomic, concurrent, (<@>)
+ ( -- * General combinators
+ permute, many, many1, replicate, option, try
+ , repeat, repeat1, exhaustive
+ -- * Process-specific combinators
+ , atomic, (<%>), interleave, concurrent
+ , (<@>), (!*>), inits, filterP, hide
) where
+import Ideas.Common.Classes
import Ideas.Common.Strategy.Choice
import Ideas.Common.Strategy.Process
import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Strategy.Symbol
+import Prelude hiding (sequence, replicate, repeat)
+import qualified Prelude
-useFirst :: Choice f => (a -> Process a -> f b) -> f b -> Process a -> f b
-useFirst op e = onMenu (menuItem e op) . menu
+split :: (AtomicSymbol a, Choice b)
+ => (Process a -> Process a -> b) -> b -> Process a -> b
+split op = split2 (op . single) op
+-- Specialized version of split that also takes an operator for the special case
+-- that the left part of the split is a single symbol.
+split2 :: (AtomicSymbol a, Choice b)
+ => (a -> Process a -> b) -> (Process a -> Process a -> b) -> b -> Process a -> b
+split2 op1 op2 = withMenu f
+ where
+ f a | a == atomicOpen = rec (op2 . (a ~>)) 1
+ | otherwise = op1 a
+
+ rec acc n
+ | n == 0 = acc done
+ | otherwise = withMenu g empty
+ where
+ g a = rec (acc . (a ~>)) (pm a n)
+
+ pm :: AtomicSymbol a => a -> Int -> Int
+ pm a | a == atomicOpen = succ
+ | a == atomicClose = pred
+ | otherwise = id
+
+-- atomic prefix
+(!*>) :: AtomicSymbol a => Process a -> Process a -> Process a
+a !*> p = split op (atomic a) p
+ where
+ op b q = atomic (a .*. b) .*. q
+
filterP :: (a -> Bool) -> Process a -> Process a
filterP cond = fold (\a q -> if cond a then a ~> q else empty) done
hide :: (a -> Bool) -> Process a -> Process a
hide cond = fold (\a q -> if cond a then a ~> q else q) done
-data Sym a = Single a | Composed (Process a)
+atomic :: AtomicSymbol a => Process a -> Process a
+atomic p = atomicOpen ~> (p .*. single atomicClose)
-fromAtoms :: Process (Sym a) -> Process a
-fromAtoms = fold f done
- where
- f (Single a) = (a ~>)
- f (Composed p) = (p <*>)
+interleave :: (AtomicSymbol a, LabelSymbol a) => [Process a] -> Process a
+interleave xs = if null xs then done else foldr1 (<%>) xs
-atomic :: IsProcess f => f (Sym a) -> f (Sym a)
-atomic = single . Composed . fromAtoms . toProcess
+(<%>) :: (AtomicSymbol a, LabelSymbol a) => Process a -> Process a -> Process a
+(<%>) = concurrent (not . isEnterSymbol)
-concurrent :: IsProcess f => (a -> Bool) -> f a -> f a -> f a
-concurrent switch x y = normal (toProcess x) (toProcess y)
+concurrent :: AtomicSymbol a => (a -> Bool) -> Process a -> Process a -> Process a
+concurrent switch = normal
where
- normal p q = stepBoth q p <|> (stepRight q p <|> stepRight p q)
+ normal p q = stepBoth q p .|. (stepRight q p .|. stepRight p q)
- stepBoth = useFirst stop2 . useFirst stop2 done
+ stepBoth = withMenu stop2 . withMenu stop2 done
stop2 _ _ = empty
- stepRight p = useFirst op empty
+ stepRight p = split2 op1 op2 empty
where
- op a = (a ~>) . (if switch a then normal else stepRight) p
+ op1 a q2
+ | switch a = a ~> normal p q2
+ | otherwise = a ~> stepRight p q2
+ op2 q1 q2 = q1 .*. normal p q2
+-- | Allows all permutations of the list
+permute :: (Choice a, Sequence a) => [a] -> a
+permute as
+ | null as = done
+ | otherwise = choice [ s .*. permute ys | (s, ys) <- pickOne as ]
+ where
+ pickOne :: [a] -> [(a, [a])]
+ pickOne [] = []
+ pickOne (x:xs) = (x, xs) : [ (y, x:ys) | (y, ys) <- pickOne xs ]
+
-- Alternate combinator
-(<@>) :: IsProcess f => f a -> f a -> f a
-p0 <@> q0 = rec (toProcess q0) (toProcess p0)
+(<@>) :: AtomicSymbol a => Process a -> Process a -> Process a
+p0 <@> q0 = rec q0 p0
where
- rec q = useFirst (\a r -> a ~> rec r q) (bothOk q)
- bothOk = useFirst (\_ _ -> empty) done
+ rec q = let op b r = b .*. rec r q
+ in split op (bothOk q)
+ bothOk = withMenu (\_ _ -> empty) done
+
+inits :: AtomicSymbol a => Process a -> Process a
+inits = rec
+ where
+ rec p = done .|. split op empty p
+ op x = (x .*.) . rec
+
+many :: (Sequence a, Fix a, Choice a) => a -> a
+many s = fix $ \x -> done .|. (s .*. x)
+
+many1 :: (Sequence a, Fix a, Choice a) => a -> a
+many1 s = s .*. many s
+
+replicate :: Sequence a => Int -> a -> a
+replicate n = sequence . Prelude.replicate n
+
+-- | Apply a certain strategy or do nothing (non-greedy)
+option :: (Choice a, Sequence a) => a -> a
+option s = s .|. done
+
+-- | Apply a certain strategy if this is possible (greedy version of 'option')
+try :: (Choice a, Sequence a) => a -> a
+try s = s |> done
+
+-- | Repeat a strategy zero or more times (greedy version of 'many')
+repeat :: (Sequence a, Fix a, Choice a) => a -> a
+repeat s = fix $ \x -> try (s .*. x)
+
+-- | Apply a certain strategy at least once (greedy version of 'many1')
+repeat1 :: (Sequence a, Fix a, Choice a) => a -> a
+repeat1 s = s .*. repeat s
+
+-- | Apply the strategies from the list exhaustively (until this is no longer possible)
+exhaustive :: (Sequence a, Fix a, Choice a) => [a] -> a
+exhaustive = repeat . choice
---------------------------------------------------------------------------
diff --git a/src/Ideas/Common/Strategy/Legacy.hs b/src/Ideas/Common/Strategy/Legacy.hs
new file mode 100644
--- /dev/null
+++ b/src/Ideas/Common/Strategy/Legacy.hs
@@ -0,0 +1,37 @@
+-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer : bastiaan.heeren@ou.nl
+-- Stability : provisional
+-- Portability : portable (depends on ghc)
+--
+-- Legacy strategy combinators (before the Functor-Applicative-Monad proposal)
+--
+-----------------------------------------------------------------------------
+-- $Id: Legacy.hs 8747 2015-10-15 14:54:48Z bastiaan $
+
+module Ideas.Common.Strategy.Legacy where
+
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Combinators
+import qualified Prelude
+
+infixr 2 <%>, <@>
+infixr 3 <|>
+infixr 4 >|>
+infixr 5 <*>
+
+(<%>), (<@>), (<|>), (>|>), (<*>) ::
+ (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+
+(<%>) = (.%.)
+(<@>) = (.@.)
+(<|>) = (.|.)
+(>|>) = (./.)
+(<*>) = (.*.)
+
+alternatives :: IsStrategy f => [f a] -> Strategy a
+alternatives = choice
diff --git a/src/Ideas/Common/Strategy/Location.hs b/src/Ideas/Common/Strategy/Location.hs
--- a/src/Ideas/Common/Strategy/Location.hs
+++ b/src/Ideas/Common/Strategy/Location.hs
@@ -1,17 +1,17 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
--- Locations in a strategy
+-- Locations that correspond to the labels in a strategy
--
-----------------------------------------------------------------------------
--- $Id: Location.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Location.hs 8745 2015-10-15 14:45:46Z bastiaan $
module Ideas.Common.Strategy.Location
( checkLocation, subTaskLocation, nextTaskLocation
@@ -19,11 +19,9 @@
) where
import Data.Maybe
-import Ideas.Common.Classes
+import Ideas.Common.CyclicTree
import Ideas.Common.Id
import Ideas.Common.Strategy.Abstract
-import Ideas.Common.Strategy.Core
-import Ideas.Common.Utils.Uniplate
-----------------------------------------------------------
--- Strategy locations
@@ -57,17 +55,16 @@
-- | Returns a list of all strategy locations, paired with the label
strategyLocations :: LabeledStrategy a -> [([Int], Id)]
-strategyLocations s = ([], getId s) : rec [] (toCore (unlabel s))
+strategyLocations s = ([], getId s) : make s
where
- rec is = concat . zipWith make (map (:is) [0..]) . collect
-
- make is (l, mc) = (is, l) : maybe [] (rec is) mc
+ make = nrs . fold alg . toStrategyTree . unlabel
+ alg = monoidAlg
+ { fLeaf = \a -> [(getId a, [])]
+ , fLabel = \l x -> [(l, nrs x)]
+ }
+ nrs = concat . zipWith f [0..]
- collect core =
- case core of
- Label l c -> [(l, Just c)]
- Rule r | isMajor r -> [(getId r, Nothing)]
- _ -> concatMap collect (children core)
+ f i (l, xs) = ([i], l) : [ (i:is, l2) | (is, l2) <- xs ]
fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id
fromLoc s loc = fmap getId (lookup loc (strategyLocations s))
diff --git a/src/Ideas/Common/Strategy/Parsing.hs b/src/Ideas/Common/Strategy/Parsing.hs
deleted file mode 100644
--- a/src/Ideas/Common/Strategy/Parsing.hs
+++ /dev/null
@@ -1,261 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer : bastiaan.heeren@ou.nl
--- Stability : provisional
--- Portability : portable (depends on ghc)
---
--- Basic machinery for fully executing a core strategy expression, or only
--- partially. Partial execution results in a prefix that keeps the current
--- locations in the strategy (a list of @Path@s) for continuing the execution
--- later on. A path can be used to reconstruct the sequence of steps already
--- performed (a so-called trace). Prefixes can be merged with the Monoid
--- operation.
---
------------------------------------------------------------------------------
--- $Id: Parsing.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Strategy.Parsing
- ( -- * Running @Core@ strategies
- runCore
- -- * Prefix
- , Prefix, noPrefix, makePrefix, replayCore
- , isEmptyPrefix, majorPrefix, searchModePrefix, prefixPaths
- -- * Step
- , Step(..), stepRule, stepEnvironment
- -- * Path
- , Path, emptyPath, readPath, readPaths
- ) where
-
-import Control.Monad
-import Data.Function
-import Data.List
-import Ideas.Common.Classes
-import Ideas.Common.Environment
-import Ideas.Common.Id
-import Ideas.Common.Rule
-import Ideas.Common.Strategy.Choice
-import Ideas.Common.Strategy.Core
-import Ideas.Common.Strategy.Derived
-import Ideas.Common.Strategy.Process
-import Ideas.Common.Strategy.Sequence
-import Ideas.Common.Utils (fst3, splitsWithElem, readM)
-import Ideas.Common.Utils.Uniplate
-
---------------------------------------------------------------------------------
--- Running Core strategies
-
--- | Run a @Core@ strategy and return all results.
-runCore :: Core a -> a -> [a]
-runCore core a = bests $ accum applyAll a $ coreToProcess False core
-
-coreToProcess :: Bool -> Core a -> Process (Step a)
-coreToProcess useLabels = fromAtoms . toProcess . rec . coreSubstAll
- where
- rec :: Core a -> Builder (Sym (Step a))
- rec core =
- case core of
- a :*: b -> rec a <*> rec b
- a :|: b -> rec a <|> rec b
- a :>|> b -> rec a >|> rec b
- a :|>: b -> rec a |> rec b
- Rule r -> single (Single (RuleStep mempty r))
- Fail -> empty
- Succeed -> done
- Label l a
- | useLabels -> Single (Enter l) ~> rec a
- <*> single (Single (Exit l))
- | otherwise -> rec a
- a :%: b -> concurrent switch (rec a) (rec b)
- a :@: b -> rec a <@> rec b
- Atomic a -> atomic (rec a)
- Not a -> notCore a
- Remove _ -> empty
- Collapse a -> rec (collapse a)
- Hide a -> rec (fmap minor a)
- Let _ _ -> error "not substituted: let"
- Var _ -> error "not substituted: var"
-
- switch (Single (Enter _)) = False
- switch _ = True
-
-collapse :: Core a -> Core a
-collapse (Label l s) = Rule $ makeRule l (runCore s)
-collapse core = descend collapse core
-
-notCore :: Core a -> Builder (Sym (Step a))
-notCore core = single $ Single $ RuleStep mempty $
- checkRule "core.not" $ null . runCore core
-
---------------------------------------------------------------------------------
--- Prefix datatype
-
-data Prefix a = Prefix
- { getPaths :: [Path]
- , remainder :: Process (Step a, a, Path)
- }
-
-instance Show (Prefix a) where
- show = intercalate ";" . map show . prefixPaths
-
-instance Monoid (Prefix a) where
- mempty = noPrefix
- mappend (Prefix xs p) (Prefix ys q) = Prefix (xs ++ ys) (p <|> q)
-
-instance Firsts (Prefix a) where
- type Elem (Prefix a) = (Step a, a)
-
- menu = fmap f . menu . remainder
- where
- f Done = Done
- f ((st, a, path) :~> p) = (st, a) :~> Prefix [path] p
-
---------------------------------------------------------------------------------
--- Constructing a prefix
-
--- | The error prefix (i.e., without a location in the strategy).
-noPrefix :: Prefix a
-noPrefix = Prefix [] empty
-
--- | Make a prefix from a core strategy and a start term.
-makePrefix :: Core a -> a -> Prefix a
-makePrefix = snd . replayCore emptyPath
-
--- | Construct a prefix by replaying a path in a core strategy: the third
--- argument is the current term.
-replayCore :: Path -> Core a -> ([Step a], a -> Prefix a)
-replayCore path core =
- let (acc, p) = runPath path (withPath (coreToProcess True core))
- in (map fst acc, Prefix [path] . applySteps p)
-
-runPath :: Path -> Process a -> ([a], Process a)
-runPath (Path is) = rec [] is
- where
- rec acc [] p = (reverse acc, p)
- rec acc (n:ns) p =
- case getByIndex n (menu p) of
- Just (a :~> r) -> rec (a:acc) ns r
- _ -> ([], empty)
-
-applySteps :: Process (Step a, Path) -> a -> Process (Step a, a, Path)
-applySteps p a0 = prune (isMajor . fst3) (scan f a0 p)
- where
- f a (RuleStep _ r, path) =
- [ (b, (RuleStep env r, b, path))
- | (b, env) <- transApply (transformation r) a
- ]
- f a (st, path) = [(a, (st, a, path))]
-
-withPath :: Process a -> Process (a, Path)
-withPath = rec []
- where
- rec ns = mapWithIndex (menuItem done . f ns) . menu
-
- f ns n a p =
- let ms = n:ns
- in (a, Path (reverse ms)) ~> rec ms p
-
---------------------------------------------------------------------------------
--- Prefix fuctions
-
-isEmptyPrefix :: Prefix a -> Bool
-isEmptyPrefix = all (== emptyPath) . getPaths
-
--- | Transforms the prefix such that only major steps are kept in the remaining
--- strategy.
-majorPrefix :: Prefix a -> Prefix a
-majorPrefix prfx = prfx { remainder = hide (isMajor . fst3) (remainder prfx) }
-
--- | The searchModePrefix transformation changes the process in such a way that
--- all intermediate states can only be reached by one path. A prerequisite is
--- that symbols are unique (or only used once).
-searchModePrefix :: (Step a -> Step a -> Bool) -> Prefix a -> Prefix a
-searchModePrefix eq prfx =
- prfx { remainder = rec (remainder (majorPrefix prfx)) }
- where
- eq3 = eq `on` fst3
-
- rec p | ready p = done
- | otherwise = process (firsts p)
-
- process [] = empty
- process ((a, p):xs) =
- let ys = map fst $ firsts (a ~> p)
- in (a ~> rec p) <|> process (concatMap (change ys) xs)
-
- change ys (a, q) =
- let f x = all (not . eq3 x) ys
- in firsts $ filterP f (a ~> q)
-
--- | Returns the current @Path@.
-prefixPaths :: Prefix a -> [Path]
-prefixPaths = getPaths
-
---------------------------------------------------------------------------------
--- Step
-
--- | The steps during the parsing process: enter (or exit) a labeled
--- sub-strategy, or a rule.
-data Step a = Enter Id -- ^ Enter a labeled sub-strategy
- | Exit Id -- ^ Exit a labeled sub-strategy
- | RuleStep Environment (Rule a) -- ^ Rule that was applied
- deriving Eq
-
-instance Show (Step a) where
- show (Enter l) = "enter " ++ showId l
- show (Exit l) = "exit " ++ showId l
- show (RuleStep _ r) = show r
-
-instance Apply Step where
- applyAll (RuleStep _ r) = applyAll r
- applyAll _ = return
-
-instance HasId (Step a) where
- getId (Enter l) = getId l
- getId (Exit l) = getId l
- getId (RuleStep _ r) = getId r
-
- changeId f (Enter l) = Enter (changeId f l)
- changeId f (Exit l) = Exit (changeId f l)
- changeId f (RuleStep env r) = RuleStep env (changeId f r)
-
-instance Minor (Step a) where
- setMinor b (RuleStep env r) = RuleStep env (setMinor b r)
- setMinor _ st = st
-
- isMinor (RuleStep _ r) = isMinor r
- isMinor _ = True
-
-stepRule :: Step a -> Rule a
-stepRule (RuleStep _ r) = r
-stepRule (Enter l) = idRule (l # "enter")
-stepRule (Exit l) = idRule (l # "exit")
-
-stepEnvironment :: Step a -> Environment
-stepEnvironment (RuleStep env _) = env
-stepEnvironment _ = mempty
-
---------------------------------------------------------------------------------
--- Path
-
--- | A path encodes a location in a strategy. Paths are represented as a list
--- of integers.
-newtype Path = Path [Int]
- deriving Eq
-
-instance Show Path where
- show (Path is) = show is
-
--- | The empty path.
-emptyPath :: Path
-emptyPath = Path []
-
-readPath :: Monad m => String -> m Path
-readPath = liftM Path . readM
-
-readPaths :: Monad m => String -> m [Path]
-readPaths = mapM readPath . splitsWithElem ';'
diff --git a/src/Ideas/Common/Strategy/Prefix.hs b/src/Ideas/Common/Strategy/Prefix.hs
new file mode 100644
--- /dev/null
+++ b/src/Ideas/Common/Strategy/Prefix.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer : bastiaan.heeren@ou.nl
+-- Stability : provisional
+-- Portability : portable (depends on ghc)
+--
+-- Basic machinery for fully executing a strategy expression, or only
+-- partially. Partial execution results in a prefix that keeps the current
+-- locations in the strategy (a list of @Path@s) for continuing the execution
+-- later on. A path can be used to reconstruct the sequence of steps already
+-- performed (a so-called trace). Prefixes can be merged with the Monoid
+-- operation.
+--
+-----------------------------------------------------------------------------
+-- $Id: Prefix.hs 8745 2015-10-15 14:45:46Z bastiaan $
+
+module Ideas.Common.Strategy.Prefix
+ ( -- * Prefix
+ Prefix, noPrefix, makePrefix, firstsOrdered
+ , replayProcess
+ , isEmptyPrefix, majorPrefix, searchModePrefix, prefixPaths
+ -- * Path
+ , Path, emptyPath, readPath, readPaths
+ ) where
+
+import Control.Monad
+import Data.List (intercalate)
+import Ideas.Common.Classes
+import Ideas.Common.Environment
+import Ideas.Common.Id
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Utils (splitsWithElem, readM)
+
+--------------------------------------------------------------------------------
+-- Prefix datatype
+
+data Prefix a = Prefix
+ { getPaths :: [Path]
+ , remainder :: Menu (Rule a) (a, Environment, Prefix a)
+ }
+
+instance Show (Prefix a) where
+ show = intercalate ";" . map show . prefixPaths
+
+instance Monoid (Prefix a) where
+ mempty = noPrefix
+ mappend (Prefix xs p) (Prefix ys q) = Prefix (xs ++ ys) (p .|. q)
+
+instance Firsts (Prefix a) where
+ type Elem (Prefix a) = (Rule a, a, Environment)
+
+ ready = hasDone . remainder
+ firsts = map reorder . bests . remainder
+
+firstsOrdered :: (Rule a -> Rule a -> Ordering) -> Prefix a -> [((Rule a, a, Environment), Prefix a)]
+firstsOrdered cmp = map reorder . bestsOrdered cmp . remainder
+
+reorder :: (a, (b, env, c)) -> ((a, b, env), c)
+reorder (x, (y, env, z)) = ((x, y, env), z)
+
+--------------------------------------------------------------------------------
+-- Constructing a prefix
+
+-- | The error prefix (i.e., without a location in the strategy).
+noPrefix :: Prefix a
+noPrefix = Prefix [] empty
+
+-- | Make a prefix from a core strategy and a start term.
+makePrefix :: Process (Rule a) -> a -> Prefix a
+makePrefix = snd . replayProcess emptyPath
+
+-- | Construct a prefix by replaying a path in a core strategy: the third
+-- argument is the current term.
+replayProcess :: Path -> Process (Rule a) -> ([Rule a], a -> Prefix a)
+replayProcess (Path is) = replay [] is
+ where
+ replay acc [] p = (reverse acc, createPrefix p)
+ replay acc (n:ns) p =
+ case getByIndex n (menu p) of
+ Just (a, r) -> replay (a:acc) ns r
+ _ -> ([], const noPrefix)
+
+ createPrefix p = Prefix [Path is] . flip (rec []) p
+
+ rec ns a = cut . onMenuWithIndex f doneMenu . menu
+ where
+ f n r p = choice
+ [ r ?~> (b, env, mk b)
+ | (b, env) <- transApply (transformation r) a
+ ]
+ where
+ ms = n:ns
+ path = Path (is ++ reverse ms)
+ mk b = Prefix [path] (rec ms b p)
+
+ x ?~> y@(_, _, q)
+ | isMinor r && stopped q = empty
+ | otherwise = x |-> y
+
+stopped :: Prefix a -> Bool
+stopped = isEmpty . remainder
+
+--------------------------------------------------------------------------------
+-- Prefix fuctions
+
+isEmptyPrefix :: Prefix a -> Bool
+isEmptyPrefix = all (== emptyPath) . getPaths
+
+-- | Transforms the prefix such that only major steps are kept in the remaining
+-- strategy.
+majorPrefix :: Prefix a -> Prefix a
+majorPrefix prfx = prfx { remainder = onMenu f doneMenu (remainder prfx) }
+ where
+ f r (a, env, p)
+ | isMajor r = r |-> (a, env, majorPrefix p)
+ | otherwise = remainder (majorPrefix p)
+
+-- | The searchModePrefix transformation changes the process in such a way that
+-- all intermediate states can only be reached by one path. A prerequisite is
+-- that symbols are unique (or only used once).
+searchModePrefix :: Prefix a -> Prefix a
+searchModePrefix prfx =
+ prfx { remainder = rec (remainder (majorPrefix prfx)) }
+ where
+ rec m | hasDone m = doneMenu
+ | otherwise = process (bests m)
+
+ process [] = empty
+ process ((r, (a, env, pr)):xs) =
+ (r |-> (a, env, pr { remainder = rec (remainder pr) }))
+ .|. process (concatMap (change r) xs)
+
+ change y (r, pair) =
+ bests (filterPrefix (/= y) r pair)
+
+filterPrefix :: (Rule a -> Bool) -> Rule a -> (a, Environment, Prefix a) -> Menu (Rule a) (a, Environment, Prefix a)
+filterPrefix cond = f
+ where
+ rec = onMenu f doneMenu
+ f r (a, env, pr) = if cond r then r |-> (a, env, pr { remainder = rec (remainder pr) }) else empty
+
+-- | Returns the current @Path@.
+prefixPaths :: Prefix a -> [Path]
+prefixPaths = getPaths
+
+--------------------------------------------------------------------------------
+-- Path
+
+-- | A path encodes a location in a strategy. Paths are represented as a list
+-- of integers.
+newtype Path = Path [Int]
+ deriving Eq
+
+instance Show Path where
+ show (Path is) = show is
+
+-- | The empty path.
+emptyPath :: Path
+emptyPath = Path []
+
+readPath :: Monad m => String -> m Path
+readPath = liftM Path . readM
+
+readPaths :: Monad m => String -> m [Path]
+readPaths = mapM readPath . splitsWithElem ';'
diff --git a/src/Ideas/Common/Strategy/Process.hs b/src/Ideas/Common/Strategy/Process.hs
--- a/src/Ideas/Common/Strategy/Process.hs
+++ b/src/Ideas/Common/Strategy/Process.hs
@@ -1,156 +1,93 @@
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
--- Processes must support choices and sequences. This module defines a type
--- class, an implementation, and utility functions.
+-- Processes support choices and sequences and are modelled after Hoare's CSP
+-- calculus.
--
-----------------------------------------------------------------------------
--- $Id: Process.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Process.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Strategy.Process
- ( -- * IsProcess type class
- IsProcess(..)
- -- * Process data type
- , Process, menu, eqProcessBy
- -- * Building sequences
- , Builder
- -- * Query functions on a Process
- , ready, stopped, firsts
- -- * Higher-order functions for iterating over a Process
- , fold, accum, scan, prune
+ ( Process, eqProcessBy, menu, withMenu
+ , fold, runProcess
) where
+import Ideas.Common.Classes
import Ideas.Common.Strategy.Choice
import Ideas.Common.Strategy.Sequence
------------------------------------------------------------------------
--- IsProcess type class
-
-class (Choice f, Sequence f) => IsProcess f where
- -- | Convert to the 'Process' data type.
- toProcess :: f a -> Process a
-
-------------------------------------------------------------------------
-- Process data type
--- | This datatype implements choices and sequences, but is slow for
--- building sequences with the '<*>' combinator. See the 'Builder' data
--- type for a faster alternative.
-newtype Process a = P (Menu (MenuItem a (Process a)))
+-- | Process data type with efficient support for sequences
+newtype Process a = P [Menu a (Process a)]
instance Eq a => Eq (Process a) where
(==) = eqProcessBy (==)
instance Functor Process where
- fmap f (P m) = P (fmap g m)
+ fmap f = rec
where
- g Done = Done
- g (a :~> p) = f a :~> fmap f p
+ rec (P xs) = P (map g xs)
+ g = onMenu (\a q -> f a |-> rec q) doneMenu
-instance Choice Process where
- single a = P (single (a :~> P (single Done)))
- empty = P empty
- P x <|> P y = P (x <|> y)
- P x >|> P y = P (x >|> y)
- P x |> P y = P (x |> y)
+instance Choice (Process a) where
+ empty = P [empty]
+ x .|. y = P [menu x .|. menu y]
+ x ./. y = P [menu x ./. menu y]
+ x |> y = P [menu x |> menu y]
-instance Sequence Process where
- done = P (return Done)
- a ~> p = P (return (a :~> p))
+instance Sequence (Process a) where
+ type Sym (Process a) = a
- p0 <*> P rest = rec p0
- where
- rec (P m) = P $ do
- st <- m -- cutOn (menuItem True (\_ _ -> False)) m
- case st of
- a :~> p -> return (a :~> rec p)
- Done -> rest
+ done = P []
+ a ~> b = P [a |-> b]
+ P xs .*. P ys = P (xs ++ ys)
+ sequence ps = P [ x | P xs <- ps, x <- xs ]
-instance IsProcess Process where
- toProcess = id
+instance Fix (Process a)
instance Firsts (Process a) where
type Elem (Process a) = a
- menu (P m) = m
+ firsts = bests . menu
+ ready = hasDone . menu
--- | Generalized equality of processes, which takes an equality function for
--- the symbols.
-eqProcessBy :: (a -> a -> Bool) -> Process a -> Process a -> Bool
-eqProcessBy eq = rec
+runProcess :: Apply f => Process (f a) -> a -> [a]
+runProcess p a = withMenu op [a] p
where
- rec p q = eqMenuBy eqStep (menu p) (menu q)
-
- eqStep (a :~> p) (b :~> q) = eq a b && rec p q
- eqStep Done Done = True
- eqStep _ _ = False
-
-------------------------------------------------------------------------
--- Building sequences
-
--- | The 'Builder' data type offers a fast implementation for building
--- sequences. The data type implements the 'IsProcess' type class.
--- A 'Builder' value must be converted to a 'Process' (with 'toProcess')
--- it can be inspected in any way.
-
-newtype Builder a = B (Process a -> Process a)
-
-instance Choice Builder where
- single a = B (a ~>)
- empty = B (const empty)
- B f <|> B g = B (\p -> f p <|> g p)
- B f >|> B g = B (\p -> f p >|> g p)
- B f |> B g = B (\p -> f p |> g p)
-
-instance Sequence Builder where
- done = B id
- a ~> B f = B ((a ~>) . f)
- B f <*> B g = B (f . g)
-
-instance IsProcess Builder where
- toProcess (B f) = f done
-
-------------------------------------------------------------------------
--- Higher-order functions for iterating over a Process
+ op f x = [ c | b <- applyAll f a, c <- runProcess x b ]
--- | Folding over a process takes a function for single steps and for 'done'.
-{-# INLINE fold #-}
-fold :: Choice f => (a -> f b -> f b) -> f b -> Process a -> f b
-fold op e = rec
+menu :: Process a -> Menu a (Process a)
+menu (P zs) = rec zs
where
- rec = onMenu (menuItem e (\a -> op a . rec)) . menu
+ rec [] = doneMenu
+ rec [x] = x
+ rec (x:xs) = onMenu (\a (P ys) -> a |-> P (ys ++ xs)) (rec xs) x
-{-# INLINE accum #-}
-accum :: (a -> b -> [b]) -> b -> Process a -> Menu b
-accum f = rec
+withMenu :: Choice b => (a -> Process a -> b) -> b -> Process a -> b
+withMenu op e (P zs) = rec zs
where
- rec b p = menu p >>= g
- where
- g Done = single b
- g (a :~> q) = choice [ rec b2 q | b2 <- f a b ]
+ rec [] = e
+ rec [x] = onMenu op e x
+ rec (x:xs) = onMenu (\a (P ys) -> op a (P (ys ++ xs))) (rec xs) x
-{-# INLINE scan #-}
-scan :: (s -> a -> [(s, b)]) -> s -> Process a -> Process b
-scan op = rec
+-- | Generalized equality of processes, which takes an equality function for
+-- the symbols.
+eqProcessBy :: (a -> a -> Bool) -> Process a -> Process a -> Bool
+eqProcessBy eq = rec
where
- rec s =
- let f a q = choice [ b ~> rec s2 q | (s2, b) <- op s a ]
- in onMenu (menuItem done f) . menu
+ rec p q = eqMenuBy eq rec (menu p) (menu q)
--- fail early
-prune :: (a -> Bool) -> Process a -> Process a
-prune f = fold op done
+fold :: Choice b => (a -> b -> b) -> b -> Process a -> b
+fold op e = rec
where
- op a p
- | not (f a) && stopped np = empty
- | otherwise = a ~> np
- where
- np = P (cut (menu p))
+ rec = withMenu (\a -> op a . rec) e
diff --git a/src/Ideas/Common/Strategy/Sequence.hs b/src/Ideas/Common/Strategy/Sequence.hs
--- a/src/Ideas/Common/Strategy/Sequence.hs
+++ b/src/Ideas/Common/Strategy/Sequence.hs
@@ -1,46 +1,57 @@
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
--- A type class for sequences together with the 'Step' datatype.
+-- A type class for sequences together with the 'Firsts' type class for
+-- accessing the firsts set and ready predicate.
--
-----------------------------------------------------------------------------
--- $Id: Sequential.hs 6612 2014-06-12 07:57:59Z bastiaan $
+-- $Id: Sequence.hs 8758 2015-10-22 06:48:52Z bastiaan $
module Ideas.Common.Strategy.Sequence
( -- * Sequence type class
Sequence(..)
-- * Firsts type class
- , Firsts(..), firstsMenu, firstsOrdered, firstsTree, stopped
- -- * MenuItem data type with some utility functions
- , MenuItem(..), menuItem, isDone
+ , Firsts(..), firstsTree
) where
-import Data.Function
-import Ideas.Common.Classes
import Ideas.Common.DerivationTree
-import Ideas.Common.Strategy.Choice
-infixr 5 :~>, ~>, <*>
+infixr 5 .*., ~>
------------------------------------------------------------------------
-- Sequence type class
-class Sequence f where
+class Sequence a where
+ type Sym a
-- | The empty sequence.
- done :: f a
- -- | Prefix a sequence with one element.
- (~>) :: a -> f a -> f a
+ done :: a
+ -- | Prepend a symbol to a sequence.
+ (~>) :: Sym a -> a -> a
-- | Append two sequences.
- (<*>) :: f a -> f a -> f a
+ (.*.) :: a -> a -> a
+ -- | Singleton sequence.
+ single :: Sym a -> a
+ single s = s ~> done
+ -- | Sequential composition.
+ sequence :: [a] -> a
+ sequence xs = if null xs then done else foldr1 (.*.) xs
+instance Sequence b => Sequence (a -> b) where
+ type Sym (a -> b) = Sym b
+
+ done = const done
+ single = const . single
+ a ~> f = (a ~>) . f
+ (f .*. g) x = f x .*. g x
+
------------------------------------------------------------------------
-- Firsts type class
@@ -49,53 +60,11 @@
type Elem s
-- | The ready predicate (we are done).
ready :: s -> Bool
- ready = any isDone . bests . menu
- -- | The first set.
+ -- | The firsts set.
firsts :: s -> [(Elem s, s)]
- firsts = bests . firstsMenu
- -- | The menu offers single steps (with the remainder) and 'done' steps.
- menu :: s -> Menu (MenuItem (Elem s) s)
-firstsMenu :: Firsts s => s -> Menu (Elem s, s)
-firstsMenu s = do
- item <- cut (menu s)
- case item of
- a :~> t -> return (a, t)
- Done -> empty
-
-firstsOrdered :: Firsts s => (Elem s -> Elem s -> Ordering)
- -> s -> [(Elem s, s)]
-firstsOrdered cmp = bestsOrdered (cmp `on` fst) . firstsMenu
-
firstsTree :: Firsts s => s -> DerivationTree (Elem s) s
firstsTree x = addBranches bs tr
where
tr = singleNode x (ready x)
- bs = [ (a, firstsTree y) | (a, y) <- firsts x ]
-
--- | Not ready and no further steps to take.
-stopped :: Firsts s => s -> Bool
-stopped = isEmpty . menu
-
-------------------------------------------------------------------------
--- MenuItem data type with some utility functions
-
-data MenuItem a s = a :~> s -- ^ A single step.
- | Done -- ^ No step (we are done).
-
-instance Functor (MenuItem a) where
- fmap = mapSecond
-
-instance BiFunctor MenuItem where
- biMap f g = menuItem Done (\a s -> f a :~> g s)
-
--- | The 'menuItem' function takes a default value for 'Done' and a function
--- to combine the values for a single step.
-menuItem :: b -> (a -> s -> b) -> MenuItem a s -> b
-menuItem b _ Done = b
-menuItem _ f (a :~> x) = f a x
-
--- | Is the item 'done'?
-isDone :: MenuItem a s -> Bool
-isDone Done = True
-isDone _ = False
+ bs = [ (a, firstsTree y) | (a, y) <- firsts x ]
diff --git a/src/Ideas/Common/Strategy/StrategyTree.hs b/src/Ideas/Common/Strategy/StrategyTree.hs
new file mode 100644
--- /dev/null
+++ b/src/Ideas/Common/Strategy/StrategyTree.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE RankNTypes #-}
+-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer : bastiaan.heeren@ou.nl
+-- Stability : provisional
+-- Portability : portable (depends on ghc)
+--
+-- Representation of a strategy as a cyclic tree with explicit fixed-points.
+-- The nodes in the tree are named strategy combinators. The leafs are rules.
+--
+-----------------------------------------------------------------------------
+-- $Id: StrategyTree.hs 8758 2015-10-22 06:48:52Z bastiaan $
+
+module Ideas.Common.Strategy.StrategyTree
+ ( -- * StrategyTree type synonym
+ StrategyTree
+ -- * Declarations (named combinators)
+ , Decl, Combinator, associative, isAssociative, combinator
+ , (.=.), applyDecl
+ -- * Arities
+ , Arity(..), Nullary(..), Unary(..), Binary(..), Nary(..)
+ ) where
+
+import Data.Function
+import Data.Maybe
+import Ideas.Common.CyclicTree
+import Ideas.Common.Id
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.Process
+import Ideas.Common.View
+
+infix 1 .=.
+
+------------------------------------------------------------------------------
+
+type StrategyTree a = CyclicTree (Decl Nary) (Rule a)
+
+applyDecl :: Arity f => Decl f -> f (StrategyTree a)
+applyDecl d = toArity (node (d {combinator = op}) . make)
+ where
+ op = Nary $ fromMaybe empty . listify (combinator d)
+
+ make | isAssociative d = concatMap collect
+ | otherwise = id
+
+ collect a =
+ case isNode a of
+ Just (da, as) | getId da == getId d -> as
+ _ -> [a]
+
+------------------------------------------------------------------------------
+
+type Combinator f = forall a . f (Process (Rule a))
+
+data Decl f = C
+ { declId :: Id
+ , combinator :: Combinator f
+ , isAssociative :: Bool
+ }
+
+instance Show (Decl f) where
+ show = showId
+
+instance Eq (Decl f) where
+ (==) = (==) `on` getId
+
+instance HasId (Decl f) where
+ getId = declId
+ changeId f d = d { declId = f (declId d) }
+
+(.=.) :: IsId n => n -> Combinator f -> Decl f
+n .=. f = C (newId n) f False
+
+associative :: Decl f -> Decl f
+associative c = c {isAssociative = True}
+
+------------------------------------------------------------------------------
+
+class Arity f where
+ listify :: f a -> [a] -> Maybe a
+ toArity :: ([a] -> a) -> f a
+ liftIso :: Isomorphism a b -> f a -> f b
+
+data Nullary a = Nullary { fromNullary :: a }
+data Unary a = Unary { fromUnary :: a -> a }
+data Binary a = Binary { fromBinary :: a -> a -> a }
+data Nary a = Nary { fromNary :: [a] -> a }
+
+instance Arity Nullary where
+ listify (Nullary a) [] = Just a
+ listify _ _ = Nothing
+ toArity f = Nullary (f [])
+ liftIso p (Nullary a) = Nullary (from p a)
+
+instance Arity Unary where
+ listify (Unary f) [x] = Just (f x)
+ listify _ _ = Nothing
+ toArity f = Unary (\x -> f [x])
+ liftIso p (Unary f) = Unary (from p . f . to p)
+
+instance Arity Binary where
+ listify (Binary f) [x, y] = Just (f x y)
+ listify _ _ = Nothing
+ toArity f = Binary (\x y -> f [x, y])
+ liftIso p (Binary f) = Binary (\x y -> from p (f (to p x) (to p y)))
+
+instance Arity Nary where
+ listify (Nary f) = Just . f
+ toArity = Nary
+ liftIso p (Nary f) = Nary (from p . f . map (to p))
diff --git a/src/Ideas/Common/Strategy/Symbol.hs b/src/Ideas/Common/Strategy/Symbol.hs
new file mode 100644
--- /dev/null
+++ b/src/Ideas/Common/Strategy/Symbol.hs
@@ -0,0 +1,62 @@
+-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer : bastiaan.heeren@ou.nl
+-- Stability : provisional
+-- Portability : portable (depends on ghc)
+--
+-- This module defines special symbols for labeling and atomicity.
+--
+-----------------------------------------------------------------------------
+-- $Id: Symbol.hs 8747 2015-10-15 14:54:48Z bastiaan $
+
+module Ideas.Common.Strategy.Symbol
+ ( AtomicSymbol(..), LabelSymbol(..)
+ , enterRule, exitRule, isEnterRule, isExitRule
+ ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Ideas.Common.Id
+import Ideas.Common.Rule
+
+--------------------------------------------------------------------------------
+-- Step
+
+class Eq a => AtomicSymbol a where
+ atomicOpen, atomicClose :: a
+
+instance AtomicSymbol (Rule a) where
+ atomicOpen = idRule "atomic.open"
+ atomicClose = idRule "atomic.close"
+
+class Eq a => LabelSymbol a where
+ isEnterSymbol :: a -> Bool
+
+instance LabelSymbol (Rule a) where
+ isEnterSymbol = isJust . isEnterRule
+
+enterRule :: Id -> Rule a
+enterRule l = idRule (l # "enter")
+
+exitRule :: Id -> Rule a
+exitRule l = idRule (l # "exit")
+
+isEnterRule :: Rule a -> Maybe Id
+isEnterRule st = do
+ let n = getId st
+ guard (unqualified n == "enter")
+ return (initId n)
+
+isExitRule :: Rule a -> Maybe Id
+isExitRule st = do
+ let n = getId st
+ guard (unqualified n == "exit")
+ return (initId n)
+
+initId :: Id -> Id
+initId = newId . intercalate "." . qualifiers
diff --git a/src/Ideas/Common/Strategy/Traversal.hs b/src/Ideas/Common/Strategy/Traversal.hs
--- a/src/Ideas/Common/Strategy/Traversal.hs
+++ b/src/Ideas/Common/Strategy/Traversal.hs
@@ -1,36 +1,44 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
+-- Parameterized traversals based on the strategy language.
+--
-----------------------------------------------------------------------------
--- $Id: Traversal.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Traversal.hs 8745 2015-10-15 14:45:46Z bastiaan $
module Ideas.Common.Strategy.Traversal
- ( layer, traverse, Option
+ ( -- * Parameterized traversals
+ layer, traverse
-- * Options
+ , Option
, topdown, bottomup, leftToRight, rightToLeft
, full, spine, stop, once, leftmost, rightmost
, traversalFilter, parentFilter
-- * One-pass traversals
- , fulltd, fullbu, oncetd, oncebu, leftmostbu, leftmosttd, somewhere
+ , fulltd, fullbu, oncetd, oncebu, leftmostbu, leftmosttd
+ , somewhere, somewhereWhen
, oncetdPref, oncebuPref
-- * Fixpoint traversals
, innermost, outermost
- , ruleDown, ruleDownLast, ruleUp
+ -- * Navigator rules
+ , ruleUp, ruleDown, ruleDownLast, ruleLeft, ruleRight
) where
import Data.Monoid
+import Ideas.Common.Classes
import Ideas.Common.Rule
import Ideas.Common.Strategy.Abstract
import Ideas.Common.Strategy.Combinators
import Ideas.Common.Traversal.Navigator
import Prelude hiding (repeat, not)
+import qualified Prelude
----------------------------------------------------------------------
-- One-layer combinators
@@ -40,11 +48,11 @@
visit :: (IsStrategy f, IsStrategy g) => Visit -> f a -> g a -> Strategy a
visit v next s = fix $ \a ->
case v of
- VisitFirst -> s |> next <*> a
- VisitOne -> s <|> next <*> a
- VisitSome -> s <*> try (next <*> visit VisitMany next s) <|> next <*> a
- VisitAll -> s <*> (not next |> (next <*> a))
- VisitMany -> try s <*> (not next |> (next <*> a))
+ VisitFirst -> s |> next .*. a
+ VisitOne -> s .|. next .*. a
+ VisitSome -> s .*. try (next .*. visit VisitMany next s) .|. next .*. a
+ VisitAll -> s .*. (not next |> (next .*. a))
+ VisitMany -> try s .*. (not next |> (next .*. a))
----------------------------------------------------------------------
-- Parameterized traversals
@@ -54,7 +62,7 @@
layerWith :: (IsStrategy f, Navigator a) => Info a -> f a -> Strategy a
layerWith tr s =
- goDown <*> findOk <*> visit (getVisit tr) (next <*> findOk) s <*> try ruleUp
+ goDown .*. findOk .*. visit (getVisit tr) (next .*. findOk) s .*. try ruleUp
where
(next, goDown)
| getReversed tr = (ruleLeft, ruleDownLast)
@@ -63,7 +71,7 @@
findOk =
case getFilters tr of
[] -> succeed
- ps -> fix $ \a -> check (\x -> all ($ x) ps) |> (next <*> a)
+ ps -> fix $ \a -> check (\x -> all ($ x) ps) |> (next .*. a)
traverse :: (IsStrategy f, Navigator a) => [Option a] -> f a -> Strategy a
traverse = traverseWith . fromOptions
@@ -71,30 +79,30 @@
traverseWith :: (IsStrategy f, Navigator a) => Info a -> f a -> Strategy a
traverseWith tr s =
fix $ \a ->
- case getCombinator tr of
+ case getOp tr of
Sequence
- | getTopDown tr -> s <*> (descend a <|> check isLeaf)
- | otherwise -> (descend a <|> check isLeaf) <*> s
+ | getTopDown tr -> s .*. (descend a .|. check isLeaf)
+ | otherwise -> (descend a .|. check isLeaf) .*. s
OrElse
| getTopDown tr -> s |> descend a
| otherwise -> descend a |> s
Prefer
- | getTopDown tr -> s >|> descend a
- | otherwise -> descend a >|> s
- Choice -> s <|> descend a
+ | getTopDown tr -> s ./. descend a
+ | otherwise -> descend a ./. s
+ Choice -> s .|. descend a
where
descend = layerWith tr
-----------------------------------------------------------------------
-data Combinator = Sequence | OrElse | Choice | Prefer
+data Op = Sequence | OrElse | Choice | Prefer
data Info a = Info
- { getVisit :: Visit
- , getCombinator :: Combinator
- , getFilters :: [a -> Bool]
- , getTopDown :: Bool
- , getReversed :: Bool
+ { getVisit :: Visit
+ , getOp :: Op
+ , getFilters :: [a -> Bool]
+ , getTopDown :: Bool
+ , getReversed :: Bool
}
newtype Option a = O { unO :: Info a -> Info a }
@@ -115,20 +123,20 @@
rightToLeft = O $ \t -> t {getReversed = True}
full, spine, stop, once :: Option a
-full = setCombinator Sequence `mappend` setVisit VisitAll
-spine = setCombinator Sequence `mappend` setVisit VisitOne
-stop = setCombinator OrElse `mappend` setVisit VisitAll
-once = setCombinator OrElse `mappend` setVisit VisitOne
+full = setOp Sequence `mappend` setVisit VisitAll
+spine = setOp Sequence `mappend` setVisit VisitOne
+stop = setOp OrElse `mappend` setVisit VisitAll
+once = setOp OrElse `mappend` setVisit VisitOne
leftmost, rightmost :: Option a
-leftmost = leftToRight <> setCombinator OrElse
-rightmost = rightToLeft <> setCombinator OrElse
+leftmost = leftToRight <> setOp OrElse
+rightmost = rightToLeft <> setOp OrElse
setVisit :: Visit -> Option a
setVisit v = O $ \t -> t {getVisit = v}
-setCombinator :: Combinator -> Option a
-setCombinator c = O $ \t -> t {getCombinator = c}
+setOp :: Op -> Option a
+setOp c = O $ \t -> t {getOp = c}
traversalFilter :: (a -> Bool) -> Option a
traversalFilter ok = O $ \t -> t {getFilters = ok:getFilters t}
@@ -151,22 +159,27 @@
oncetd = traverse [once, topdown]
oncetdPref :: (IsStrategy f, Navigator a) => f a -> Strategy a
-oncetdPref = traverse [setCombinator Prefer, once, topdown]
+oncetdPref = traverse [setOp Prefer, once, topdown]
oncebu :: (IsStrategy f, Navigator a) => f a -> Strategy a
oncebu = traverse [once, bottomup]
oncebuPref :: (IsStrategy f, Navigator a) => f a -> Strategy a
-oncebuPref = traverse [setCombinator Prefer, once, bottomup]
+oncebuPref = traverse [setOp Prefer, once, bottomup]
leftmostbu :: (IsStrategy f, Navigator a) => f a -> Strategy a
-leftmostbu = traverse [setCombinator OrElse, setVisit VisitFirst, bottomup]
+leftmostbu = traverse [setOp OrElse, setVisit VisitFirst, bottomup]
leftmosttd :: (IsStrategy f, Navigator a) => f a -> Strategy a
-leftmosttd = traverse [setCombinator OrElse, setVisit VisitFirst, topdown]
+leftmosttd = traverse [setOp OrElse, setVisit VisitFirst, topdown]
somewhere :: (IsStrategy f, Navigator a) => f a -> Strategy a
somewhere = traverse []
+
+-- as long as the predicate does not hold, go to the next layer
+somewhereWhen :: (IsStrategy g, Navigator a) => (a -> Bool) -> g a -> Strategy a
+somewhereWhen p s = fix $ \this ->
+ check p .*. s .|. check (Prelude.not . p) .*. layer [] this
----------------------------------------------------------------------
-- fixpoint traverses
diff --git a/src/Ideas/Common/Traversal/Iterator.hs b/src/Ideas/Common/Traversal/Iterator.hs
--- a/src/Ideas/Common/Traversal/Iterator.hs
+++ b/src/Ideas/Common/Traversal/Iterator.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Iterator.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Iterator.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Traversal.Iterator
( -- * Iterator type class
diff --git a/src/Ideas/Common/Traversal/Navigator.hs b/src/Ideas/Common/Traversal/Navigator.hs
--- a/src/Ideas/Common/Traversal/Navigator.hs
+++ b/src/Ideas/Common/Traversal/Navigator.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Navigator.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Navigator.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Traversal.Navigator
( -- * Location information
diff --git a/src/Ideas/Common/Traversal/Tests.hs b/src/Ideas/Common/Traversal/Tests.hs
--- a/src/Ideas/Common/Traversal/Tests.hs
+++ b/src/Ideas/Common/Traversal/Tests.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Tests.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Tests.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Traversal.Tests
( testIterator, testNavigator, tests
diff --git a/src/Ideas/Common/Traversal/Utils.hs b/src/Ideas/Common/Traversal/Utils.hs
--- a/src/Ideas/Common/Traversal/Utils.hs
+++ b/src/Ideas/Common/Traversal/Utils.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Utils.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Utils.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Traversal.Utils
( -- * Update type class
diff --git a/src/Ideas/Common/Utils.hs b/src/Ideas/Common/Utils.hs
--- a/src/Ideas/Common/Utils.hs
+++ b/src/Ideas/Common/Utils.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- A collection of general utility functions
--
-----------------------------------------------------------------------------
--- $Id: Utils.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Utils.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Utils
( Some(..), ShowString(..), readInt, readM
diff --git a/src/Ideas/Common/Utils/QuickCheck.hs b/src/Ideas/Common/Utils/QuickCheck.hs
--- a/src/Ideas/Common/Utils/QuickCheck.hs
+++ b/src/Ideas/Common/Utils/QuickCheck.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Extensions to the QuickCheck library
--
-----------------------------------------------------------------------------
--- $Id: QuickCheck.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: QuickCheck.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Utils.QuickCheck
( module Test.QuickCheck
diff --git a/src/Ideas/Common/Utils/StringRef.hs b/src/Ideas/Common/Utils/StringRef.hs
--- a/src/Ideas/Common/Utils/StringRef.hs
+++ b/src/Ideas/Common/Utils/StringRef.hs
@@ -1,9 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -15,7 +14,7 @@
-- Virutal Machine (LVM) identifiers.
--
-----------------------------------------------------------------------------
--- $Id: StringRef.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: StringRef.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Utils.StringRef
( StringRef, stringRef, toString, tableStatus
diff --git a/src/Ideas/Common/Utils/TestSuite.hs b/src/Ideas/Common/Utils/TestSuite.hs
--- a/src/Ideas/Common/Utils/TestSuite.hs
+++ b/src/Ideas/Common/Utils/TestSuite.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -14,7 +14,7 @@
-- is a monoid.
--
-----------------------------------------------------------------------------
--- $Id: TestSuite.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: TestSuite.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Utils.TestSuite
( -- * TestSuite
diff --git a/src/Ideas/Common/Utils/Uniplate.hs b/src/Ideas/Common/Utils/Uniplate.hs
--- a/src/Ideas/Common/Utils/Uniplate.hs
+++ b/src/Ideas/Common/Utils/Uniplate.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- class and its utility plus constructor functions)
--
-----------------------------------------------------------------------------
--- $Id: Uniplate.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Uniplate.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.Utils.Uniplate
( -- * Uniplate type class and utility functions
diff --git a/src/Ideas/Common/View.hs b/src/Ideas/Common/View.hs
--- a/src/Ideas/Common/View.hs
+++ b/src/Ideas/Common/View.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -13,7 +13,7 @@
-- in Interactive Exercise Assistants"
--
-----------------------------------------------------------------------------
--- $Id: View.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: View.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Common.View
( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
diff --git a/src/Ideas/Encoding/DecoderJSON.hs b/src/Ideas/Encoding/DecoderJSON.hs
--- a/src/Ideas/Encoding/DecoderJSON.hs
+++ b/src/Ideas/Encoding/DecoderJSON.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Services using JSON notation
--
-----------------------------------------------------------------------------
--- $Id: DecoderJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: DecoderJSON.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Encoding.DecoderJSON
( JSONDecoder, jsonDecoder
@@ -94,7 +94,7 @@
decoderFor $ \json ->
case json of
Array [a] -> setInput a >> decodeState
- Array [String _code, pref, term, jsonContext] -> do
+ Array (String _code : pref : term : jsonContext : rest) -> do
pts <- decodePaths // pref
a <- decodeTerm // term
env <- decodeEnvironment // jsonContext
@@ -102,7 +102,15 @@
ctx = navigateTowards loc $ deleteRef locRef $
setEnvironment env $ inContext ex a
prfx = replayPaths pts (strategy ex) ctx
- return $ makeState ex prfx ctx
+ case rest of
+ [] -> return $ makeState ex prfx ctx
+ [Array [String user, String session, String startterm]] ->
+ return (makeState ex prfx ctx)
+ { stateUser = Just user
+ , stateSession = Just session
+ , stateStartTerm = Just startterm
+ }
+ _ -> fail $ "invalid state" ++ show json
_ -> fail $ "invalid state" ++ show json
envToLoc :: Environment -> Location
diff --git a/src/Ideas/Encoding/DecoderXML.hs b/src/Ideas/Encoding/DecoderXML.hs
--- a/src/Ideas/Encoding/DecoderXML.hs
+++ b/src/Ideas/Encoding/DecoderXML.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Services using XML notation
--
-----------------------------------------------------------------------------
--- $Id: DecoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: DecoderXML.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Encoding.DecoderXML
( XMLDecoder, xmlDecoder
@@ -20,7 +20,7 @@
import Control.Monad
import Data.Char
-import Ideas.Common.Library hiding ((<|>))
+import Ideas.Common.Library
import Ideas.Common.Traversal.Navigator
import Ideas.Encoding.Encoder
import Ideas.Encoding.OpenMathSupport
diff --git a/src/Ideas/Encoding/Encoder.hs b/src/Ideas/Encoding/Encoder.hs
--- a/src/Ideas/Encoding/Encoder.hs
+++ b/src/Ideas/Encoding/Encoder.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Evaluator.hs 6535 2014-05-14 11:05:06Z bastiaan $
+-- $Id: Encoder.hs 8747 2015-10-15 14:54:48Z bastiaan $
module Ideas.Encoding.Encoder
( -- * Converter type class
@@ -126,6 +126,10 @@
arr f = Enc $ \_ -> return . f
first f = Enc $ \xs (a, b) -> runEnc f xs a >>= \c -> return (c, b)
+instance Alternative (Encoder a s) where
+ empty = mzero
+ (<|>) = mplus
+
instance Monad (Encoder a s) where
return a = Enc $ \_ _ -> return a
fail s = Enc $ \_ _ -> fail s
@@ -243,6 +247,17 @@
-- Error monad (helper)
newtype Error a = Error { runError :: Either String a }
+
+instance Functor Error where
+ fmap = (<$>)
+
+instance Applicative Error where
+ pure = return
+ (<*>) = ap
+
+instance Alternative Error where
+ empty = mzero
+ (<|>) = mplus
instance Monad Error where
fail = Error . Left
diff --git a/src/Ideas/Encoding/EncoderHTML.hs b/src/Ideas/Encoding/EncoderHTML.hs
--- a/src/Ideas/Encoding/EncoderHTML.hs
+++ b/src/Ideas/Encoding/EncoderHTML.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Encoding in HTML
--
-----------------------------------------------------------------------------
--- $Id: EncoderHTML.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: EncoderHTML.hs 8745 2015-10-15 14:45:46Z bastiaan $
module Ideas.Encoding.EncoderHTML (htmlEncoder, htmlEncoderAt) where
@@ -21,6 +21,7 @@
import Data.Maybe
import Data.Ord
import Ideas.Common.Library hiding (alternatives)
+import Ideas.Common.Strategy.Symbol
import Ideas.Common.Utils
import Ideas.Common.Utils.TestSuite
import Ideas.Encoding.Encoder
@@ -456,8 +457,9 @@
, showEnv env1 -- local environment
, showEnv env2 -- global environment (diff)
]
+ textLines = mconcat . intersperse br . map string . lines
forTerm a =
- divClass "term" $ string $ prettyPrinterContext ex a
+ divClass "term" $ textLines $ prettyPrinterContext ex a
in htmlDerivationWith before forStep forTerm (diffEnvironment d)
htmlState :: LinkManager -> HTMLEncoder a (State a)
@@ -530,11 +532,13 @@
ctx = stateContext st
prSteps = fst $ replayPath path (strategy ex) ctx
-htmlStep :: Step a -> HTMLBuilder
-htmlStep (Enter l) = spanClass "step-enter" $ string $ "enter " ++ show l
-htmlStep (Exit l) = spanClass "step-exit" $ string $ "exit " ++ show l
-htmlStep (RuleStep _ r) = let s = if isMinor r then "minor" else "major"
- in spanClass ("step-"++s) $ string $ showId r
+htmlStep :: Rule a -> HTMLBuilder
+htmlStep r =
+ case (isEnterRule r, isExitRule r) of
+ (Just l, _) -> spanClass "step-enter" $ string $ "enter " ++ show l
+ (_, Just l) -> spanClass "step-exit" $ string $ "exit " ++ show l
+ _ -> let s = if isMinor r then "minor" else "major"
+ in spanClass ("step-"++s) $ string $ showId r
htmlDerivationWith :: HTMLBuilder -> (s -> HTMLBuilder) -> (t -> HTMLBuilder) -> Derivation s t -> HTMLBuilder
htmlDerivationWith before forStep forTerm d =
@@ -568,6 +572,8 @@
htmlDiagnosis :: LinkManager -> DomainReasoner -> HTMLEncoder a (Diagnosis a)
htmlDiagnosis lm dr = encoderFor $ \diagnosis ->
case diagnosis of
+ SyntaxError s ->
+ spanClass "error" $ string s
Buggy _ r ->
spanClass "error" $ string $ "Not equivalent: buggy rule " ++ show r
NotEquivalent s ->
diff --git a/src/Ideas/Encoding/EncoderJSON.hs b/src/Ideas/Encoding/EncoderJSON.hs
--- a/src/Ideas/Encoding/EncoderJSON.hs
+++ b/src/Ideas/Encoding/EncoderJSON.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,11 +12,12 @@
-- Services using JSON notation
--
-----------------------------------------------------------------------------
--- $Id: EncoderJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: EncoderJSON.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Encoding.EncoderJSON (jsonEncoder) where
-import Ideas.Common.Library hiding (exerciseId, (<|>), (<*>))
+import Data.Maybe
+import Ideas.Common.Library hiding (exerciseId)
import Ideas.Common.Utils (Some(..), distinct)
import Ideas.Encoding.Encoder
import Ideas.Service.State
@@ -96,15 +97,17 @@
encodeState :: JSONEncoder a (State a)
encodeState = encoderFor $ \st ->
- let ctx = stateContext st
- make pp env = Array
+ let ctx = stateContext st
+ get f = String (fromMaybe "" (f st))
+ make pp env = Array $
[ String $ showId (exercise st)
, String $ if withoutPrefix st
then "NoPrefix"
else show (statePrefix st)
, pp
, env
- ]
+ ] ++ if isNothing (stateUser st) then [] else
+ [ Array [get stateUser, get stateSession, get stateStartTerm] ]
in make <$> (encodeContext // ctx) <*> (encodeStateEnvironment // ctx)
encodeStateEnvironment :: JSONEncoder a (Context a)
@@ -158,6 +161,8 @@
encodeDiagnosis :: JSONEncoder a (Diagnose.Diagnosis a)
encodeDiagnosis = encoderFor $ \diagnosis ->
case diagnosis of
+ Diagnose.SyntaxError s ->
+ pure $ Object [("syntaxerror", String s)]
Diagnose.NotEquivalent s ->
if null s then pure (Object [("notequiv", Null)])
else make "notequiv" [fromReason s]
diff --git a/src/Ideas/Encoding/EncoderXML.hs b/src/Ideas/Encoding/EncoderXML.hs
--- a/src/Ideas/Encoding/EncoderXML.hs
+++ b/src/Ideas/Encoding/EncoderXML.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Services using XML notation
--
-----------------------------------------------------------------------------
--- $Id: EncoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: EncoderXML.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Encoding.EncoderXML
( XMLEncoder
@@ -192,6 +192,7 @@
encodeDiagnosis :: XMLEncoder a (Diagnosis a)
encodeDiagnosis = encoderFor $ \diagnosis ->
case diagnosis of
+ SyntaxError s -> element "syntaxerror" [string s]
Buggy env r -> element "buggy"
[encodeEnvironment // env, "ruleid" .=. showId r]
NotEquivalent s ->
diff --git a/src/Ideas/Encoding/Evaluator.hs b/src/Ideas/Encoding/Evaluator.hs
--- a/src/Ideas/Encoding/Evaluator.hs
+++ b/src/Ideas/Encoding/Evaluator.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs, RankNTypes #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,35 +10,60 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Evaluator.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Evaluator.hs 8743 2015-10-14 19:48:13Z bastiaan $
-module Ideas.Encoding.Evaluator
- ( Evaluator(..), evalService
- ) where
+module Ideas.Encoding.Evaluator (Evaluator(..), evalService) where
+import Ideas.Common.Library
import Ideas.Encoding.Encoder
+import Ideas.Main.Logging
+import Ideas.Service.Diagnose
import Ideas.Service.Types
data Evaluator a b c = Evaluator (TypedDecoder a b) (TypedEncoder a c)
-evalService :: Options a -> Evaluator a b c -> Service -> b -> IO c
-evalService opts f = eval opts f . serviceFunction
+data EvalResult a c = EvalResult
+ { inputValues :: [TypedValue (Type a)]
+ , outputValue :: TypedValue (Type a)
+ , evalResult :: c
+ }
-eval :: Options a -> Evaluator a b c -> TypedValue (Type a) -> b -> IO c
-eval opts f@(Evaluator dec enc) tv@(val ::: tp) b =
- case tp of
- -- handle exceptions
- Const String :|: t ->
- either fail (\a -> eval opts f (a ::: t) b) val
- -- uncurry function if possible
- t1 :-> t2 :-> t3 ->
- eval opts f (uncurry val ::: Pair t1 t2 :-> t3) b
- t1 :-> t2 -> do
- a <- run (dec t1) opts b
- eval opts f (val a ::: t2) b
- -- perform IO
- IO t -> do
- a <- val
- eval opts f (a ::: t) b
- _ ->
- run enc opts tv
+values :: EvalResult a c -> [TypedValue (Type a)]
+values result = outputValue result : inputValues result
+
+logType :: LogRef -> EvalResult a c -> Type a b -> (b -> Record -> Record) -> IO ()
+logType logRef res tp f =
+ case concatMap (findValuesOfType tp) (values res) of
+ [] -> return ()
+ hd:_ -> changeLog logRef (f hd)
+
+evalService :: LogRef -> Options a -> Evaluator a b c -> Service -> b -> IO c
+evalService logRef opts f srv b = do
+ res <- eval opts f b (serviceFunction srv)
+ logType logRef res tState addState
+ logType logRef res tRule $ \rl r -> r {ruleid = showId rl}
+ logType logRef res tDiagnosis $ \d r -> r {serviceinfo = show d}
+ return (evalResult res)
+
+eval :: Options a -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c)
+eval opts (Evaluator dec enc) b = rec
+ where
+ rec tv@(val ::: tp) =
+ case tp of
+ -- handle exceptions
+ Const String :|: t ->
+ either fail (\a -> rec (a ::: t)) val
+ -- uncurry function if possible
+ t1 :-> t2 :-> t3 ->
+ rec (uncurry val ::: Pair t1 t2 :-> t3)
+ t1 :-> t2 -> do
+ a <- run (dec t1) opts b
+ res <- rec (val a ::: t2)
+ return res { inputValues = (a ::: t1) : inputValues res }
+ -- perform IO
+ IO t -> do
+ a <- val
+ rec (a ::: t)
+ _ -> do
+ c <- run enc opts tv
+ return $ EvalResult [] tv c
diff --git a/src/Ideas/Encoding/LinkManager.hs b/src/Ideas/Encoding/LinkManager.hs
--- a/src/Ideas/Encoding/LinkManager.hs
+++ b/src/Ideas/Encoding/LinkManager.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Manages links to information
--
-----------------------------------------------------------------------------
--- $Id: LinkManager.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: LinkManager.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Encoding.LinkManager
( LinkManager(..)
diff --git a/src/Ideas/Encoding/ModeJSON.hs b/src/Ideas/Encoding/ModeJSON.hs
--- a/src/Ideas/Encoding/ModeJSON.hs
+++ b/src/Ideas/Encoding/ModeJSON.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,10 +11,11 @@
-- Services using JSON notation
--
-----------------------------------------------------------------------------
--- $Id: ModeJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: ModeJSON.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Encoding.ModeJSON (processJSON) where
+import Control.Monad
import Data.Char
import Ideas.Common.Library hiding (exerciseId)
import Ideas.Common.Utils (Some(..), timedSeconds)
@@ -22,16 +23,19 @@
import Ideas.Encoding.Encoder (makeOptions)
import Ideas.Encoding.EncoderJSON
import Ideas.Encoding.Evaluator
+import Ideas.Main.Logging (LogRef, changeLog, errormsg)
import Ideas.Service.DomainReasoner
import Ideas.Service.Request
import Ideas.Text.JSON
-processJSON :: Maybe Int -> Maybe String -> DomainReasoner -> String -> IO (Request, String, String)
-processJSON maxTime cgiBin dr input = do
+processJSON :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
+processJSON maxTime cgiBin dr logRef input = do
json <- either fail return (parseJSON input)
req <- jsonRequest cgiBin json
resp <- jsonRPC json $ \fun arg ->
- maybe id timedSeconds maxTime (myHandler dr req fun arg)
+ maybe id timedSeconds maxTime (myHandler dr logRef req fun arg)
+ unless (responseError resp == Null) $
+ changeLog logRef (\r -> r {errormsg = show (responseError resp)})
let f = if compactOutput req then compactJSON else show
out = addVersion (version dr) (toJSON resp)
return (req, f out, "application/json")
@@ -59,38 +63,38 @@
jsonRequest :: Monad m => Maybe String -> JSON -> m Request
jsonRequest cgiBin json = do
- srv <- case lookupM "method" json of
- Just (String s) -> return (Just (newId s))
- Nothing -> return Nothing
- _ -> fail "Invalid method"
let exId = lookupM "params" json >>= extractExerciseId
- enc <- case lookupM "encoding" json of
- Nothing -> return []
- Just (String s) -> readEncoding s
- _ -> fail "Invalid encoding"
- src <- case lookupM "source" json of
- Nothing -> return Nothing
- Just (String s) -> return (Just s)
- _ -> fail "Invalid source"
- let uid = case lookupM "id" json of
- Just (String s) -> Just s
- Just (Number (I n)) -> Just (show n)
- _ -> Nothing
+ srv <- stringOption "method" json newId
+ src <- stringOption "source" json id
+ rinf <- stringOption "requestinfo" json id
+ enc <- stringOptionM "encoding" json [] readEncoding
+ sch <- stringOptionM "logging" json Nothing (liftM Just . readSchema)
return emptyRequest
- { serviceId = srv
- , exerciseId = exId
- , user = uid
- , source = src
- , cgiBinary = cgiBin
- , dataformat = JSON
- , encoding = enc
+ { serviceId = srv
+ , exerciseId = exId
+ , source = src
+ , cgiBinary = cgiBin
+ , requestInfo = rinf
+ , logSchema = sch
+ , dataformat = JSON
+ , encoding = enc
}
-myHandler :: DomainReasoner -> Request -> RPCHandler
-myHandler dr request fun json = do
+stringOption :: Monad m => String -> JSON -> (String -> a) -> m (Maybe a)
+stringOption attr json f = stringOptionM attr json Nothing (return . Just . f)
+
+stringOptionM :: Monad m => String -> JSON -> a -> (String -> m a) -> m a
+stringOptionM attr json a f =
+ case lookupM attr json of
+ Just (String s) -> f s
+ Just _ -> fail $ "Invalid value for " ++ attr ++ " (expecting string)"
+ Nothing -> return a
+
+myHandler :: DomainReasoner -> LogRef -> Request -> RPCHandler
+myHandler dr logRef request fun json = do
srv <- findService dr (newId fun)
Some options <- makeOptions dr request
- evalService options jsonEvaluator srv json
+ evalService logRef options jsonEvaluator srv json
jsonEvaluator :: Evaluator a JSON JSON
jsonEvaluator = Evaluator jsonDecoder jsonEncoder
diff --git a/src/Ideas/Encoding/ModeXML.hs b/src/Ideas/Encoding/ModeXML.hs
--- a/src/Ideas/Encoding/ModeXML.hs
+++ b/src/Ideas/Encoding/ModeXML.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Services using XML notation
--
-----------------------------------------------------------------------------
--- $Id: ModeXML.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: ModeXML.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Encoding.ModeXML (processXML) where
@@ -25,6 +25,7 @@
import Ideas.Encoding.EncoderHTML
import Ideas.Encoding.EncoderXML
import Ideas.Encoding.Evaluator
+import Ideas.Main.Logging (LogRef, changeLog, errormsg)
import Ideas.Service.DomainReasoner
import Ideas.Service.Request
import Ideas.Text.HTML
@@ -32,11 +33,11 @@
import Prelude hiding (catch)
import System.IO.Error hiding (catch)
-processXML :: Maybe Int -> Maybe String -> DomainReasoner -> String -> IO (Request, String, String)
-processXML maxTime cgiBin dr input = do
+processXML :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
+processXML maxTime cgiBin dr logRef input = do
xml <- either fail return (parseXML input)
req <- xmlRequest cgiBin xml
- resp <- maybe id timedSeconds maxTime (xmlReply dr req xml)
+ resp <- maybe id timedSeconds maxTime (xmlReply dr logRef req xml)
`catch` handler
let showXML | compactOutput req = compactXML
| otherwise = show
@@ -46,7 +47,7 @@
in return (req, showXML out, "application/xml")
where
handler :: IOException -> IO XML
- handler = return . resultError . ioeGetErrorString
+ handler = resultError logRef . ioeGetErrorString
addVersion :: String -> XML -> XML
addVersion s xml =
@@ -63,31 +64,28 @@
return emptyRequest
{ serviceId = fmap newId $ findAttribute "service" xml
, exerciseId = extractExerciseId xml
- , user = findAttribute "userid" xml
, source = findAttribute "source" xml
- , feedbackScript = findAttribute "script" xml
, cgiBinary = cgiBin
+ , requestInfo = findAttribute "requestinfo" xml
+ , logSchema = findAttribute "logging" xml >>= readSchema
+ , feedbackScript = findAttribute "script" xml
, dataformat = XML
, encoding = enc
}
-xmlReply :: DomainReasoner -> Request -> XML -> IO XML
-xmlReply dr request xml = do
+xmlReply :: DomainReasoner -> LogRef -> Request -> XML -> IO XML
+xmlReply dr logRef request xml = do
srv <- case serviceId request of
Just a -> findService dr a
Nothing -> fail "No service"
Some options <- makeOptions dr request
- -- HTML evaluator
if htmlOutput request
- then do
- res <- evalService options (htmlEvaluator dr) srv xml
- return (toXML res)
+ -- HTML evaluator
+ then liftM toXML $ evalService logRef options (htmlEvaluator dr) srv xml
-- xml evaluator
- else do
- res <- evalService options xmlEvaluator srv xml
- return (resultOk res)
+ else liftM resultOk $ evalService logRef options xmlEvaluator srv xml
extractExerciseId :: Monad m => XML -> m Id
extractExerciseId = liftM newId . findAttribute "exerciseid"
@@ -97,10 +95,12 @@
("result" .=. "ok")
<> body
-resultError :: String -> XML
-resultError txt = makeXML "reply" $
- ("result" .=. "error")
- <> tag "message" (string txt)
+resultError :: LogRef -> String -> IO XML
+resultError logRef msg = do
+ changeLog logRef (\r -> r {errormsg = msg})
+ return $ makeXML "reply" $
+ ("result" .=. "error")
+ <> tag "message" (string msg)
------------------------------------------------------------
diff --git a/src/Ideas/Encoding/OpenMathSupport.hs b/src/Ideas/Encoding/OpenMathSupport.hs
--- a/src/Ideas/Encoding/OpenMathSupport.hs
+++ b/src/Ideas/Encoding/OpenMathSupport.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: OpenMathSupport.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: OpenMathSupport.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Encoding.OpenMathSupport
( -- * Conversion functions to/from OpenMath
diff --git a/src/Ideas/Encoding/RulePresenter.hs b/src/Ideas/Encoding/RulePresenter.hs
--- a/src/Ideas/Encoding/RulePresenter.hs
+++ b/src/Ideas/Encoding/RulePresenter.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: RulePresenter.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: RulePresenter.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Encoding.RulePresenter (ruleToHTML) where
diff --git a/src/Ideas/Encoding/RulesInfo.hs b/src/Ideas/Encoding/RulesInfo.hs
--- a/src/Ideas/Encoding/RulesInfo.hs
+++ b/src/Ideas/Encoding/RulesInfo.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: RulesInfo.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: RulesInfo.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Encoding.RulesInfo
( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap
diff --git a/src/Ideas/Encoding/StrategyInfo.hs b/src/Ideas/Encoding/StrategyInfo.hs
--- a/src/Ideas/Encoding/StrategyInfo.hs
+++ b/src/Ideas/Encoding/StrategyInfo.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,94 +11,60 @@
-- Converting a strategy to XML, and the other way around.
--
-----------------------------------------------------------------------------
--- $Id: StrategyInfo.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: StrategyInfo.hs 8743 2015-10-14 19:48:13Z bastiaan $
-module Ideas.Encoding.StrategyInfo (strategyToXML, xmlToStrategy) where
+module Ideas.Encoding.StrategyInfo (strategyToXML) where
-import Control.Monad
-import Ideas.Common.Library hiding (Remove, Collapse, Hide, (:=))
+import Ideas.Common.CyclicTree
+import Ideas.Common.Id
import Ideas.Common.Strategy.Abstract
-import Ideas.Common.Strategy.Core
-import Ideas.Common.Utils (readInt)
+import Ideas.Common.Strategy.Configuration
+import Ideas.Common.Strategy.StrategyTree (StrategyTree)
import Ideas.Text.XML
-----------------------------------------------------------------------
-- Strategy to XML
strategyToXML :: IsStrategy f => f a -> XML
-strategyToXML = coreToXML . toCore . toStrategy
+strategyToXML = strategyTreeToXML . toStrategyTree
nameAttr :: Id -> XMLBuilder
nameAttr info = "name" .=. showId info
-coreToXML :: Core a -> XML
-coreToXML core = makeXML "label" $
- case core of
- Label l a -> nameAttr l <> coreBuilder a
- _ -> coreBuilder core
+strategyTreeToXML :: StrategyTree a -> XML
+strategyTreeToXML tree = makeXML "label" $
+ case isLabel tree of
+ Just (l, a) -> nameAttr l <> strategyTreeBuilder a
+ _ -> strategyTreeBuilder tree
-coreBuilder :: Core a -> XMLBuilder
-coreBuilder core =
- case core of
- _ :*: _ -> asList "sequence" isSequence
- _ :|: _ -> asList "choice" isChoice
- _ :>|> _ -> asList "preference" isPreference
- _ :|>: _ -> asList "orelse" isOrElse
- _ :%: _ -> asList "interleave" isInterleave
- a :@: b -> tag "alternate" (coreBuilder a <> coreBuilder b)
- Label l (Rule r) | getId l == getId r
- -> tag "rule" (nameAttr l)
- Label l a -> tag "label" (nameAttr l <> coreBuilder a)
- Atomic a -> tag "atomic" (coreBuilder a)
- Not a -> tag "not" (coreBuilder a)
- Remove a -> cfgItem "removed" (coreBuilder a)
- Collapse a -> cfgItem "collapsed" (coreBuilder a)
- Hide a -> cfgItem "hidden" (coreBuilder a)
- Let ds a -> tag "let" (decls ds <> coreBuilder a)
- Rule r -> tag "rule" ("name" .=. show r)
- Var n -> tag "var" ("var" .=. show n)
- Succeed -> emptyTag "succeed"
- Fail -> emptyTag "fail"
- where
- asList s g = element s (map coreBuilder (collect g core))
- decls ds = mconcat [ tag "decl" (("var" .=. show n) <> coreBuilder a)
- | (n, a) <- ds
- ]
+strategyTreeBuilder :: StrategyTree a -> XMLBuilder
+strategyTreeBuilder = fold emptyAlg
+ { fNode = \def xs ->
+ case xs of
+ [x] | isConfigId def
+ -> addProperty (show def) x
+ _ -> tag (show def) (mconcat xs)
+ , fLeaf = \r ->
+ tag "rule" ("name" .=. show r)
+ , fLabel = \l a ->
+ tag "label" (nameAttr l <> a)
+ , fRec = \n a ->
+ tag "rec" (("var" .=. show n) <> a)
+ , fVar = \n ->
+ tag "var" ("var" .=. show n)
+ }
-cfgItem :: String -> XMLBuilder -> XMLBuilder
-cfgItem s a =
+addProperty :: String -> XMLBuilder -> XMLBuilder
+addProperty s a =
case fromBuilder a of
Just e | name e `elem` ["label", "rule"] ->
builder e { attributes = attributes e ++ [s := "true"] }
_ -> tag s a
-collect :: (a -> Maybe (a, a)) -> a -> [a]
-collect f = ($ []) . rec
- where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a)
-
-isSequence :: Core a -> Maybe (Core a, Core a)
-isSequence (a :*: b) = Just (a, b)
-isSequence _ = Nothing
-
-isChoice :: Core a -> Maybe (Core a, Core a)
-isChoice (a :|: b) = Just (a, b)
-isChoice _ = Nothing
-
-isPreference :: Core a -> Maybe (Core a, Core a)
-isPreference (a :>|> b) = Just (a, b)
-isPreference _ = Nothing
-
-isOrElse :: Core a -> Maybe (Core a, Core a)
-isOrElse (a :|>: b) = Just (a, b)
-isOrElse _ = Nothing
-
-isInterleave :: Core a -> Maybe (Core a, Core a)
-isInterleave (a :%: b) = Just (a, b)
-isInterleave _ = Nothing
-
-----------------------------------------------------------------------
-- XML to strategy
+{-
xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) -> XML -> m (Strategy a)
xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g
where
@@ -111,17 +77,17 @@
n <- findAttribute "name" xml
-- let boolAttr s = fromMaybe False (findBool s xml)
return (newId n)
-{-
+
findBool :: Monad m => String -> XML -> m Bool
findBool attr xml = do
s <- findAttribute attr xml
case map toLower s of
"true" -> return True
"false" -> return False
- _ -> fail "not a boolean" -}
+ _ -> fail "not a boolean"
readStrategy :: Monad m => (XML -> m Id) -> (Id -> m (Rule a)) -> XML -> m (Core a)
-readStrategy toLabel findRule xml = do
+readStrategy toLabel findRule xml = error "not implemented" do
xs <- mapM (readStrategy toLabel findRule) (children xml)
let s = name xml
case lookup s table of
@@ -139,7 +105,7 @@
| null xs = return Fail
| otherwise = return (foldr1 (:|>:) xs)
buildInterleave _ xs
- | null xs = return Succeed
+ | null xs = return succeedCore
| otherwise = return (foldr1 (:%:) xs)
buildLabel x = do
info <- toLabel xml
@@ -147,7 +113,7 @@
buildRule = do
info <- toLabel xml
r <- findRule info
- return (Label info (Rule r))
+ return (Label info (Sym r))
buildVar = do
s <- findAttribute "var" xml
i <- maybe (fail "var: not an int") return (readInt s)
@@ -167,9 +133,11 @@
, ("orelse", buildOrElse)
, ("interleave", buildInterleave)
, ("label", join2 comb1 buildLabel)
- , ("atomic", comb1 Atomic)
+ -- , ("atomic", comb1 Atomic)
, ("rule", join2 comb0 buildRule)
, ("var", join2 comb0 buildVar)
- , ("succeed", comb0 Succeed)
- , ("fail", comb0 Fail)
- ]
+-- , ("succeed", comb0 Succeed)
+ --, ("fail", comb0 Fail)
+ ]
+
+-}
diff --git a/src/Ideas/Main/BlackBoxTests.hs b/src/Ideas/Main/BlackBoxTests.hs
--- a/src/Ideas/Main/BlackBoxTests.hs
+++ b/src/Ideas/Main/BlackBoxTests.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: BlackBoxTests.hs 7528 2015-04-08 09:44:10Z bastiaan $
+-- $Id: BlackBoxTests.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Main.BlackBoxTests (blackBoxTests) where
@@ -20,6 +20,7 @@
import Ideas.Common.Utils.TestSuite
import Ideas.Encoding.ModeJSON
import Ideas.Encoding.ModeXML
+import Ideas.Main.Logging
import Ideas.Service.DomainReasoner
import Ideas.Service.Request
import System.Directory
@@ -55,8 +56,8 @@
hSetBinaryMode h1 True
txt <- hGetContents h1
out <- case format of
- JSON -> liftM snd3 (processJSON Nothing Nothing dr txt)
- XML -> liftM snd3 (processXML Nothing Nothing dr txt)
+ JSON -> liftM snd3 (processJSON Nothing Nothing dr noLogRef txt)
+ XML -> liftM snd3 (processXML Nothing Nothing dr noLogRef txt)
withFile expPath ReadMode $ \h2 -> do
hSetBinaryMode h2 True
expt <- hGetContents h2
diff --git a/src/Ideas/Main/Default.hs b/src/Ideas/Main/Default.hs
--- a/src/Ideas/Main/Default.hs
+++ b/src/Ideas/Main/Default.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Main module for feedback services
--
-----------------------------------------------------------------------------
--- $Id: Default.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Default.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Main.Default
( defaultMain, defaultCGI
@@ -23,14 +23,12 @@
import Control.Exception
import Control.Monad
import Data.Maybe
-import Data.Time
import Ideas.Common.Utils (useFixedStdGen, Some(..))
import Ideas.Common.Utils.TestSuite
import Ideas.Encoding.ModeJSON (processJSON)
import Ideas.Encoding.ModeXML (processXML)
import Ideas.Main.BlackBoxTests
import Ideas.Main.Documentation
-import Ideas.Main.LoggingDatabase
import Ideas.Main.Options hiding (fullVersion)
import Ideas.Service.DomainReasoner
import Ideas.Service.FeedbackScript.Analysis
@@ -41,6 +39,7 @@
import Prelude hiding (catch)
import System.IO
import System.IO.Error (ioeGetErrorString)
+import qualified Ideas.Main.Logging as Log
defaultMain :: DomainReasoner -> IO ()
defaultMain dr = do
@@ -52,17 +51,25 @@
-- Invoked as a cgi binary
defaultCGI :: DomainReasoner -> IO ()
defaultCGI dr = runCGI $ handleErrors $ do
+ -- create a record for logging
+ logRef <- liftIO Log.newLogRef
-- query environment
- startTime <- liftIO getCurrentTime
- addr <- remoteAddr -- the IP address of the remote host
- cgiBin <- scriptName -- get name of binary
- input <- inputOrDefault
+ addr <- remoteAddr -- the IP address of the remote host
+ cgiBin <- scriptName -- get name of binary
+ input <- inputOrDefault
-- process request
(req, txt, ctp) <- liftIO $
- process dr (Just cgiBin) input
+ process dr logRef (Just cgiBin) input
-- log request to database
- when (useLogging req) $
- liftIO $ logMessage req input txt addr startTime
+ when (useLogging req) $ liftIO $ do
+ Log.changeLog logRef $ \r -> Log.addRequest req r
+ { Log.ipaddress = addr
+ , Log.version = shortVersion
+ , Log.input = input
+ , Log.output = txt
+ }
+ Log.logRecord (getSchema req) logRef
+
-- write header and output
setHeader "Content-type" ctp
-- Cross-Origin Resource Sharing (CORS) prevents browser warnings
@@ -106,9 +113,18 @@
-- process input file
InputFile file ->
withBinaryFile file ReadMode $ \h -> do
- input <- hGetContents h
- (_, txt, _) <- process dr Nothing input
+ logRef <- liftIO Log.newLogRef
+ input <- hGetContents h
+ (req, txt, _) <- process dr logRef Nothing input
putStrLn txt
+ when (PrintLog `elem` flags) $ do
+ Log.changeLog logRef $ \r -> Log.addRequest req r
+ { Log.ipaddress = "command-line"
+ , Log.version = shortVersion
+ , Log.input = input
+ , Log.output = txt
+ }
+ Log.printLog logRef
-- blackbox tests
Test dir -> do
tests <- blackBoxTests dr dir
@@ -120,14 +136,16 @@
-- feedback scripts
MakeScriptFor s -> makeScriptFor dr s
AnalyzeScript file -> parseAndAnalyzeScript dr file
+ PrintLog -> return ()
-process :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
-process dr cgiBin input = do
+process :: DomainReasoner -> Log.LogRef -> Maybe String -> String -> IO (Request, String, String)
+process dr logRef cgiBin input = do
format <- discoverDataFormat input
- run format (Just 5) cgiBin dr input
- `catch` \ioe ->
+ run format (Just 5) cgiBin dr logRef input
+ `catch` \ioe -> do
let msg = "Error: " ++ ioeGetErrorString ioe
- in return (emptyRequest, msg, "text/plain")
+ Log.changeLog logRef (\r -> r { Log.errormsg = msg })
+ return (emptyRequest, msg, "text/plain")
where
run XML = processXML
run JSON = processJSON
diff --git a/src/Ideas/Main/Documentation.hs b/src/Ideas/Main/Documentation.hs
--- a/src/Ideas/Main/Documentation.hs
+++ b/src/Ideas/Main/Documentation.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Manages links to information
--
-----------------------------------------------------------------------------
--- $Id: Documentation.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Documentation.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Main.Documentation (makeDocumentation) where
diff --git a/src/Ideas/Main/Logging.hs b/src/Ideas/Main/Logging.hs
new file mode 100644
--- /dev/null
+++ b/src/Ideas/Main/Logging.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer : bastiaan.heeren@ou.nl
+-- Stability : provisional
+-- Portability : portable (depends on ghc)
+--
+-- Facilities to create a log database
+--
+-----------------------------------------------------------------------------
+-- $Id: Logging.hs 8743 2015-10-14 19:48:13Z bastiaan $
+
+module Ideas.Main.Logging
+ ( Record(..), addRequest, addState
+ , LogRef, newLogRef, noLogRef, changeLog
+ , logEnabled, logRecord, printLog
+ ) where
+
+import Data.IORef
+import Data.Maybe
+import Data.Time
+import Ideas.Service.Request (Request, Schema(..))
+import Ideas.Service.State
+import qualified Ideas.Service.Request as R
+
+#ifdef DB
+import Data.List
+import Database.HDBC
+import Database.HDBC.Sqlite3 (connectSqlite3)
+#endif
+
+type Diff = NominalDiffTime
+type Time = UTCTime
+
+-- | The Record datatype is based on the Ideas Request Logging Schema version 2.
+data Record = Record
+ { -- request attributes
+ service :: String -- name of feedback service
+ , exerciseid :: String -- exercise identifier
+ , source :: String -- tool/learning environment that makes request
+ , script :: String -- name of feedback script (for textual feedback)
+ , requestinfo :: String -- additional information from client (only for logging)
+ -- request format
+ , dataformat :: String -- xml, json
+ , encoding :: String -- options for encoding (e.g. OpenMath, string)
+ , -- grouping requests
+ userid :: String -- user identifier (e.g. student number)
+ , sessionid :: String -- session identifier (grouping requests for one task)
+ , taskid :: String -- task identifier (default: start term)
+ -- meta-information
+ , time :: Time -- date and time of request
+ , responsetime :: Diff -- time needed for processing request
+ , ipaddress :: String -- IP address of client
+ , binary :: String -- name of (cgi) binary that is being executed
+ , version :: String -- version (and revision) information
+ , errormsg :: String -- internal error message (default: empty string)
+ -- service info
+ , serviceinfo :: String -- summary of reply (customized for each service)
+ , ruleid :: String -- rule identifier (customized for each service)
+ -- raw data
+ , input :: String -- raw input (request)
+ , output :: String -- raw output (reply)
+ }
+ deriving Show
+
+record :: Record
+record = Record "" "" "" "" "" "" "" "" "" "" t0 0 "" "" "" "" "" "" "" ""
+ where t0 = UTCTime (toEnum 0) 0
+
+makeRecord :: IO Record
+makeRecord = do
+ now <- getCurrentTime
+ return record { time = now }
+
+-- | Add record information from the Request datatype
+addRequest :: Request -> Record -> Record
+addRequest req r = r
+ { service = maybe (service r) show (R.serviceId req)
+ , exerciseid = maybe (exerciseid r) show (R.exerciseId req)
+ , source = fromMaybe (source r) (R.source req)
+ , script = fromMaybe (script r) (R.feedbackScript req)
+ , requestinfo = fromMaybe (requestinfo r) (R.requestInfo req)
+ , dataformat = show (R.dataformat req)
+ , encoding = show (R.encoding req)
+ , binary = fromMaybe (binary r) (R.cgiBinary req)
+ }
+
+-- | Add record information from the state (userid, sessionid, taskid)
+addState :: State a -> Record -> Record
+addState st r = r
+ { userid = fromMaybe (userid r) (stateUser st)
+ , sessionid = fromMaybe (sessionid r) (stateSession st)
+ , taskid = fromMaybe (taskid r) (stateStartTerm st)
+ }
+
+---------------------------------------------------------------------
+
+newtype LogRef = L { mref :: Maybe (IORef Record) }
+
+noLogRef :: LogRef
+noLogRef = L Nothing
+
+newLogRef :: IO LogRef
+newLogRef = do
+ r <- makeRecord
+ ref <- newIORef r
+ return (L (Just ref))
+
+getRecord :: LogRef -> IO Record
+getRecord = maybe (return record) readIORef . mref
+
+changeLog :: LogRef -> (Record -> Record) -> IO ()
+changeLog = maybe (\_ -> return ()) modifyIORef . mref
+
+printLog :: LogRef -> IO ()
+printLog logRef = do
+ putStrLn "-- log information"
+ getRecord logRef >>= print
+
+--------------------------------------------------------------------------------
+
+logEnabled :: Bool
+logRecord :: Schema -> LogRef -> IO ()
+
+#ifdef DB
+logEnabled = True
+logRecord schema logRef =
+ case schema of
+ V1 -> connectSqlite3 "service.db" >>= logRecordWith V1 logRef
+ V2 -> connectSqlite3 "requests.db" >>= logRecordWith V2 logRef
+ NoLogging -> return ()
+#else
+-- without logging
+logEnabled = False
+logRecord _ _ = return ()
+#endif
+
+--------------------------------------------------------------------------------
+
+#ifdef DB
+nameOfTable :: Schema -> String
+nameOfTable V1 = "log"
+nameOfTable _ = "requests"
+
+columnsInTable :: Schema -> Record -> [SqlValue]
+columnsInTable V1 = values_v1
+columnsInTable _ = values_v2
+
+values_v1 :: Record -> [SqlValue]
+values_v1 r =
+ let get f = toSql (f r)
+ in [ get service, get exerciseid, get source, get dataformat, get encoding
+ , get input, get output, get ipaddress, get time, get responsetime
+ ]
+
+values_v2 :: Record -> [SqlValue]
+values_v2 r =
+ let get f = toSql (f r)
+ in [ get service, get exerciseid, get source, get script, get requestinfo
+ , get dataformat, get encoding, get userid, get sessionid, get taskid
+ , get time, get responsetime, get ipaddress, get binary, get version
+ , get errormsg, get serviceinfo, get ruleid, get input, get output
+ ]
+
+logRecordWith :: IConnection c => Schema -> LogRef -> c -> IO ()
+logRecordWith schema logRef conn = do
+ -- calculate duration
+ r <- getRecord logRef
+ end <- getCurrentTime
+ let diff = diffUTCTime end (time r)
+ -- insert data into database
+ insertRecord schema r {responsetime = diff} conn
+ -- close the connection to the database
+ disconnect conn
+ `catchSql` \err ->
+ putStrLn $ "Error in logging to database: " ++ show err
+
+insertRecord :: IConnection c => Schema -> Record -> c -> IO ()
+insertRecord schema r conn =
+ let cols = columnsInTable schema r
+ pars = "(" ++ intercalate "," (replicate (length cols) "?") ++ ")"
+ stm = "INSERT INTO " ++ nameOfTable schema ++ " VALUES " ++ pars
+ in run conn stm cols >> commit conn
+#endif
diff --git a/src/Ideas/Main/LoggingDatabase.hs b/src/Ideas/Main/LoggingDatabase.hs
deleted file mode 100644
--- a/src/Ideas/Main/LoggingDatabase.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer : alex.gerdes@ou.nl
--- Stability : provisional
--- Portability : portable (depends on ghc)
---
--- Facilities to create a log database
---
------------------------------------------------------------------------------
--- $Id: LoggingDatabase.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Main.LoggingDatabase (logMessage, logEnabled) where
-
-import Data.Time
-import Ideas.Service.Request
-#ifdef DB
-import Data.Maybe
-import Database.HDBC
-import Database.HDBC.Sqlite3 (connectSqlite3)
-
-logEnabled :: Bool
-logEnabled = True
-
--- | Log a message to the database (a Sqlite database).
-logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
-logMessage req input output ipaddress begin = do
- -- make a connection with the database
- conn <- connectSqlite3 "service.db"
-
- -- check if the database exists, if not make one
- --tables <- getTables conn
- --if not (elem "log" tables) then run conn createStmt [] else return 0
-
- -- calculate duration
- end <- getCurrentTime
- let diff = diffUTCTime end begin
-
- -- insert data into database
- run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)"
- [ toSql $ maybe "unknown" show (serviceId req)
- , toSql $ maybe "unknown" show (exerciseId req)
- , toSql $ fromMaybe "unknown" (source req)
- , toSql $ show (dataformat req)
- , toSql $ show (encoding req)
- , toSql $ input
- , toSql $ output
- , toSql $ ipaddress
- , toSql $ begin
- , toSql $ diff
- ]
- commit conn
-
- -- close the connection to the database
- disconnect conn
- `catchSql` \err -> do putStrLn $ "Error in logging to database: " ++ show err
-
-{-
--- | Log table schema
-createStmt = "CREATE TABLE log ( service VARCHAR(250)"
- ++ ", exerciseId VARCHAR(250)"
- ++ ", source VARCHAR(250)"
- ++ ", dataformat VARCHAR(250)"
- ++ ", encoding VARCHAR(250)"
- ++ ", input VARCHAR(250)"
- ++ ", output VARCHAR(250)"
- ++ ", ipaddress VARCHAR(20)"
- ++ ", time TIME"
- ++ ", responsetime TIME)"
--}
-#else
-logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
-logMessage _ _ _ _ _ = return ()
-
-logEnabled :: Bool
-logEnabled = False
-#endif
diff --git a/src/Ideas/Main/Options.hs b/src/Ideas/Main/Options.hs
--- a/src/Ideas/Main/Options.hs
+++ b/src/Ideas/Main/Options.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
@@ -11,7 +11,7 @@
-- Options and command-line flags for services
--
-----------------------------------------------------------------------------
--- $Id: Options.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Options.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Main.Options
( Flag(..), getFlags
@@ -19,15 +19,17 @@
) where
import Data.Maybe
-import Ideas.Main.LoggingDatabase (logEnabled)
+import Ideas.Main.Logging (logEnabled)
import Ideas.Main.Revision
import System.Console.GetOpt
import System.Environment
import System.Exit
-data Flag = Version | Help | InputFile String
+data Flag = Version | Help | PrintLog
+ | InputFile String
| MakePages FilePath | Test FilePath
| MakeScriptFor String | AnalyzeScript FilePath
+
deriving Eq
header :: String
@@ -55,13 +57,14 @@
options :: [OptDescr Flag]
options =
- [ Option [] ["version"] (NoArg Version) "show version number"
- , Option "?" ["help"] (NoArg Help) "show options"
- , Option "f" ["file"] fileArg "use input FILE as request"
- , Option "" ["make-pages"] pagesArg "generate pages for exercises and services"
- , Option "" ["test"] testArg "run tests on directory (default: 'test')"
- , Option "" ["make-script"] makeScrArg "generate feedback script for exercise"
- , Option "" ["analyze-script"] analyzeScrArg "analyze feedback script and report errors"
+ [ Option [] ["version"] (NoArg Version) "show version number"
+ , Option "?" ["help"] (NoArg Help) "show options"
+ , Option "" ["print-log"] (NoArg PrintLog) "print log information (for debugging)"
+ , Option "f" ["file"] fileArg "use input FILE as request"
+ , Option "" ["make-pages"] pagesArg "generate pages for exercises and services"
+ , Option "" ["test"] testArg "run tests on directory (default: 'test')"
+ , Option "" ["make-script"] makeScrArg "generate feedback script for exercise"
+ , Option "" ["analyze-script"] analyzeScrArg "analyze feedback script and report errors"
]
fileArg, testArg, pagesArg, makeScrArg, analyzeScrArg :: ArgDescr Flag
diff --git a/src/Ideas/Main/Revision.hs b/src/Ideas/Main/Revision.hs
--- a/src/Ideas/Main/Revision.hs
+++ b/src/Ideas/Main/Revision.hs
@@ -2,10 +2,10 @@
module Ideas.Main.Revision where
ideasVersion :: String
-ideasVersion = "1.3"
+ideasVersion = "1.4"
ideasRevision :: Int
-ideasRevision = 7519
+ideasRevision = 8775
ideasLastChanged :: String
-ideasLastChanged = "wo, 08 apr 2015"
+ideasLastChanged = "vr, 23 okt 2015"
diff --git a/src/Ideas/Service/BasicServices.hs b/src/Ideas/Service/BasicServices.hs
--- a/src/Ideas/Service/BasicServices.hs
+++ b/src/Ideas/Service/BasicServices.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: BasicServices.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: BasicServices.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.BasicServices
( -- * Basic Services
@@ -30,20 +30,20 @@
import qualified Ideas.Common.Classes as Apply
import qualified Ideas.Common.Library as Library
-generate :: StdGen -> Exercise a -> Maybe Difficulty -> Either String (State a)
-generate rng ex md =
+generate :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe String -> IO (State a)
+generate rng ex md userId =
case randomTerm rng ex md of
- Just a -> return (emptyState ex a)
- Nothing -> Left "No random term"
+ Just a -> startState ex userId a
+ Nothing -> fail "No random term"
-create :: Exercise a -> String -> Either String (State a)
-create ex input =
- case parser ex input of
- Left err -> Left err
- Right a
- | evalPredicate (Library.ready ex) a -> Left "Is ready"
- | evalPredicate (Library.suitable ex) a -> Right (emptyState ex a)
- | otherwise -> Left "Not suitable"
+create :: Exercise a -> String -> Maybe String -> IO (State a)
+create ex input userId =
+ case parser ex input of
+ Left err -> fail err
+ Right a
+ | evalPredicate (Library.ready ex) a -> fail "Is ready"
+ | evalPredicate (Library.suitable ex) a -> startState ex userId a
+ | otherwise -> fail "Not suitable"
-- TODO: add a location to each step
solution :: Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a))
@@ -56,8 +56,8 @@
-- restriction should probably be relaxed later on.
Just cfg | isEmptyPrefix prfx ->
let newStrategy = configure cfg (strategy ex)
- newExercise = ex {strategy = newStrategy}
- in rec timeout d0 (emptyStateContext newExercise (stateContext state))
+ newPrefix = emptyPrefix newStrategy (stateContext state)
+ in rec timeout d0 state { statePrefix = newPrefix }
_ -> rec timeout d0 state
where
d0 = emptyDerivation state
@@ -86,7 +86,7 @@
| otherwise = Right $
noDuplicates $ map make $ firsts state
where
- make ((s, ctx), st) = ((stepRule s, location ctx, stepEnvironment s), st)
+ make ((s, ctx, env), st) = ((s, location ctx, env), st)
noDuplicates [] = []
noDuplicates (x:xs) = x : noDuplicates (filter (not . eq x) xs)
@@ -116,7 +116,7 @@
ys = f (top (stateContext state))
f c = g c ++ concatMap f (downs c)
- g c = [ (r, location new, makeNoState ex new)
+ g c = [ (r, location new, state { statePrefix = noPrefix, stateContext = new })
| r <- ruleset ex
, (r, location c) `notElem` ps
, new <- applyAll r c
@@ -146,7 +146,7 @@
ca = setLocation loc (stateContext state)
applyOff = -- scenario 2: off-strategy
case transApplyWith env (transformation r) ca of
- (new, _):_ -> Right (makeNoState (exercise state) new)
+ (new, _):_ -> Right (state {stateContext = new, statePrefix = noPrefix})
[] -> Left ("Cannot apply " ++ show r)
stepsremaining :: State a -> Either String Int
diff --git a/src/Ideas/Service/Diagnose.hs b/src/Ideas/Service/Diagnose.hs
--- a/src/Ideas/Service/Diagnose.hs
+++ b/src/Ideas/Service/Diagnose.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,15 +12,15 @@
-- Diagnose a term submitted by a student
--
-----------------------------------------------------------------------------
--- $Id: Diagnose.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Diagnose.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Service.Diagnose
- ( Diagnosis(..), tDiagnosis, diagnose, restartIfNeeded, newState
+ ( Diagnosis(..), tDiagnosis, diagnose
, difference, differenceEqual
) where
import Data.Function
-import Data.List (sortBy)
+import Data.List (intercalate, sortBy)
import Data.Maybe
import Ideas.Common.Library hiding (ready)
import Ideas.Service.BasicServices hiding (apply)
@@ -32,9 +32,8 @@
-- Result types for diagnose service
data Diagnosis a
- = Buggy Environment (Rule (Context a))
--- | Missing
--- | IncorrectPart [a]
+ = SyntaxError String
+ | Buggy Environment (Rule (Context a))
| NotEquivalent String
| Similar Bool (State a)
| WrongRule Bool (State a) (Maybe (Rule (Context a)))
@@ -47,22 +46,20 @@
instance Show (Diagnosis a) where
show diagnosis =
case diagnosis of
- Buggy as r -> "Buggy rule " ++ show (show r) ++ showArgs as
- Unknown _ _ -> "Unknown step"
--- Missing -> "Missing solutions"
--- IncorrectPart xs -> "Incorrect parts (" ++ show (length xs) ++ " items)"
- NotEquivalent s -> if null s then "Unknown mistake" else s
- Similar _ _ -> "Very similar"
- WrongRule _ _ mr -> "Wrong rule selected" ++
- maybe "" (\r -> ", " ++ showId r ++ "recognized") mr
- Expected _ _ r -> "Rule " ++ show (show r) ++ ", expected by strategy"
- Detour _ _ _ r -> "Rule " ++ show (show r) ++ ", not following strategy"
- Correct _ _ -> "Unknown step"
+ SyntaxError s -> f "SyntaxError" [s]
+ Buggy _ r -> f "Buggy" [show r]
+ NotEquivalent s -> f "NotEquivalent" [ s | not (null s) ]
+ Similar _ _ -> "Similar"
+ WrongRule _ _ mr -> f "WrongRule" [ show r | r <- maybeToList mr ]
+ Expected _ _ r -> f "Expected" [show r]
+ Detour _ _ _ r -> f "Detour" [show r]
+ Correct _ _ -> "Correct"
+ Unknown _ _ -> "Unknown"
where
- showArgs as
- | noBindings as = ""
- | otherwise = " (" ++ show as ++ ")"
-
+ f s xs
+ | null xs = s
+ | otherwise = s ++ "(" ++ intercalate "," xs ++ ")"
+{-
newState :: Diagnosis a -> Maybe (State a)
newState diagnosis =
case diagnosis of
@@ -74,7 +71,7 @@
Detour _ s _ _ -> Just s
Correct _ s -> Just s
Unknown _ s -> Just s
-
+-}
----------------------------------------------------------------
-- The diagnose service
@@ -118,11 +115,11 @@
Correct (finished restarted) restarted
where
ex = exercise state
- restarted = restartIfNeeded (makeNoState ex new)
+ restarted = restart state {stateContext = new}
similar = similarity ex (stateContext state) new
expected = do
- let xs = either (const []) id $ allfirsts (restartIfNeeded state)
+ let xs = either (const []) id $ allfirsts state
p (_, ns) = similarity ex new (stateContext ns) -- use rule recognizer?
listToMaybe (filter p xs)
@@ -143,40 +140,27 @@
----------------------------------------------------------------
-- Helpers
--- If possible (and if needed), restart the strategy
--- Make sure that the new state has a prefix
--- When resetting the prefix, also make sure that the context is refreshed
-restartIfNeeded :: State a -> State a
-restartIfNeeded state
- | withoutPrefix state && canBeRestarted ex =
- emptyState ex (stateTerm state)
- | otherwise = state
- where
- ex = exercise state
-
tDiagnosis :: Type a (Diagnosis a)
tDiagnosis = Tag "Diagnosis" $ Iso (f <-> g) tp
where
- tp = (tPair tEnvironment tRule :|: (tString :|: tTuple3 tBool tState (tMaybe tRule)))
+ tp = (tString :|: tPair tEnvironment tRule :|: (tString :|: tTuple3 tBool tState (tMaybe tRule)))
:|: tPair tBool tState :|: tTuple3 tBool tState tRule
:|: tTuple4 tBool tState tEnvironment tRule :|: tPair tBool tState :|: tPair tBool tState
- f (Left (Left (as, r))) = Buggy as r
- -- f (Left (Right (Left ()))) = Missing
- -- f (Left (Right (Right (Left xs)))) = IncorrectPart xs
- f (Left (Right (Left s))) = NotEquivalent s
- f (Left (Right (Right (b, s, mr)))) = WrongRule b s mr
+ f (Left (Left s)) = SyntaxError s
+ f (Left (Right (Left (as, r)))) = Buggy as r
+ f (Left (Right (Right (Left s)))) = NotEquivalent s
+ f (Left (Right (Right (Right (b, s, mr))))) = WrongRule b s mr
f (Right (Left (b, s))) = Similar b s
f (Right (Right (Left (b, s, r)))) = Expected b s r
f (Right (Right (Right (Left (b, s, as, r))))) = Detour b s as r
f (Right (Right (Right (Right (Left (b, s)))))) = Correct b s
f (Right (Right (Right (Right (Right (b, s)))))) = Unknown b s
- g (Buggy as r) = Left (Left (as, r))
- -- g Missing = Left (Right (Left ()))
- -- g (IncorrectPart xs) = Left (Right (Right (Left xs)))
- g (NotEquivalent s) = Left (Right (Left s))
- g (WrongRule b s mr) = Left (Right (Right (b, s, mr)))
+ g (SyntaxError s) = Left (Left s)
+ g (Buggy as r) = Left (Right (Left (as, r)))
+ g (NotEquivalent s) = Left (Right (Right (Left s)))
+ g (WrongRule b s mr) = Left (Right (Right (Right (b, s, mr))))
g (Similar b s) = Right (Left (b, s))
g (Expected b s r) = Right (Right (Left (b, s, r)))
g (Detour b s as r) = Right (Right (Right (Left (b, s, as, r))))
diff --git a/src/Ideas/Service/DomainReasoner.hs b/src/Ideas/Service/DomainReasoner.hs
--- a/src/Ideas/Service/DomainReasoner.hs
+++ b/src/Ideas/Service/DomainReasoner.hs
@@ -1,8 +1,7 @@
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: DomainReasoner.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: DomainReasoner.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.DomainReasoner
( DomainReasoner(..), tDomainReasoner, newDomainReasoner
diff --git a/src/Ideas/Service/FeedbackScript/Analysis.hs b/src/Ideas/Service/FeedbackScript/Analysis.hs
--- a/src/Ideas/Service/FeedbackScript/Analysis.hs
+++ b/src/Ideas/Service/FeedbackScript/Analysis.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Analysis of a feedbackscript
--
-----------------------------------------------------------------------------
--- $Id: Analysis.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Analysis.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.FeedbackScript.Analysis
( -- Analysis functions
diff --git a/src/Ideas/Service/FeedbackScript/Parser.hs b/src/Ideas/Service/FeedbackScript/Parser.hs
--- a/src/Ideas/Service/FeedbackScript/Parser.hs
+++ b/src/Ideas/Service/FeedbackScript/Parser.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Simple parser for feedback scripts
--
-----------------------------------------------------------------------------
--- $Id: Parser.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Parser.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.FeedbackScript.Parser
( parseScript, parseScriptSafe, Script
diff --git a/src/Ideas/Service/FeedbackScript/Run.hs b/src/Ideas/Service/FeedbackScript/Run.hs
--- a/src/Ideas/Service/FeedbackScript/Run.hs
+++ b/src/Ideas/Service/FeedbackScript/Run.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Run a feedbackscript
--
-----------------------------------------------------------------------------
--- $Id: Run.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Run.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.FeedbackScript.Run
( Script
@@ -126,6 +126,7 @@
feedbackDiagnosis :: Diagnosis a -> Environment a -> Script -> Text
feedbackDiagnosis diagnosis env =
case diagnosis of
+ SyntaxError s -> const (makeText s)
Buggy _ r -> makeWrong "buggy" env {recognized = Just r}
NotEquivalent s -> makeNotEq s "noteq" env
Expected _ _ r -> makeOk "ok" env {recognized = Just r}
diff --git a/src/Ideas/Service/FeedbackScript/Syntax.hs b/src/Ideas/Service/FeedbackScript/Syntax.hs
--- a/src/Ideas/Service/FeedbackScript/Syntax.hs
+++ b/src/Ideas/Service/FeedbackScript/Syntax.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Abstract syntax for feedback scripts, and pretty-printer (Show instance)
--
-----------------------------------------------------------------------------
--- $Id: Syntax.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Syntax.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.FeedbackScript.Syntax
( Script, makeScript, scriptDecls, makeText, textItems
diff --git a/src/Ideas/Service/FeedbackText.hs b/src/Ideas/Service/FeedbackText.hs
--- a/src/Ideas/Service/FeedbackText.hs
+++ b/src/Ideas/Service/FeedbackText.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: FeedbackText.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: FeedbackText.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.FeedbackText
( Message, tMessage, accept, text
@@ -76,6 +76,7 @@
feedbacktext :: Script -> State a -> Context a -> Maybe Id -> (Message, State a)
feedbacktext script old new motivationId =
case diagnosis of
+ SyntaxError s -> (M (Just False) (makeText s), old)
Buggy _ _ -> (msg False, old)
NotEquivalent _ -> (msg False, old)
Expected _ s _ -> (msg True, s)
diff --git a/src/Ideas/Service/ProblemDecomposition.hs b/src/Ideas/Service/ProblemDecomposition.hs
--- a/src/Ideas/Service/ProblemDecomposition.hs
+++ b/src/Ideas/Service/ProblemDecomposition.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: ProblemDecomposition.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: ProblemDecomposition.hs 8745 2015-10-15 14:45:46Z bastiaan $
module Ideas.Service.ProblemDecomposition
( problemDecomposition, Reply(..), Answer, tAnswer, tReply
@@ -18,6 +18,7 @@
import Data.Maybe
import Ideas.Common.Library
+import Ideas.Common.Strategy.Symbol
import Ideas.Common.Utils (fst3)
import Ideas.Service.State
import Ideas.Service.Types
@@ -38,12 +39,17 @@
(newCtx, _, newPrefix) = head witnesses
newLocation = nextTaskLocation strat sloc $
fromMaybe topId $ nextMajorForPrefix newPrefix
- newState = makeState ex newPrefix newCtx
-
+ newState = state
+ { statePrefix = newPrefix
+ , stateContext = newCtx
+ }
_ -> Incorrect isEquiv newLocation expState arguments
where
newLocation = subTaskLocation strat sloc loc
- expState = makeState ex pref expected
+ expState = state
+ { statePrefix = pref
+ , stateContext = expected
+ }
isEquiv = maybe False (equivalence ex expected . fromAnswer) maybeAnswer
(expected, answerSteps, pref) = head answers
(loc, arguments) = fromMaybe (topId, mempty) $
@@ -59,20 +65,22 @@
| otherwise = statePrefix state
-- | Continue with a prefix until a certain strategy location is reached.
-runPrefixLocation :: Id -> Prefix a -> [(a, [Step a], Prefix a)]
+runPrefixLocation :: Id -> Prefix a -> [(a, [(Rule a, Environment)], Prefix a)]
runPrefixLocation loc = rec []
where
rec acc p = do
- ((st, a), q) <- firsts p
- if isLoc st then return (a, reverse (st:acc), q)
- else rec (st:acc) q
+ ((st, a, env), q) <- firsts p
+ if isLoc st then return (a, reverse ((st, env):acc), q)
+ else rec ((st, env):acc) q
- isLoc (Exit l) = l == loc
- isLoc (RuleStep _ r) = getId r == loc
- isLoc _ = False
+ isLoc r =
+ case (isEnterRule r, isExitRule r) of
+ (Just _, _) -> False
+ (_, Just l) -> l == loc
+ _ -> getId r == loc
-firstMajorInSteps :: [Step a] -> Maybe (Id, Environment)
-firstMajorInSteps (RuleStep env r:_) | isMajor r = Just (getId r, env)
+firstMajorInSteps :: [(Rule a, Environment)] -> Maybe (Id, Environment)
+firstMajorInSteps ((r, env):_) | isMajor r = Just (getId r, env)
firstMajorInSteps (_:xs) = firstMajorInSteps xs
firstMajorInSteps [] = Nothing
@@ -80,11 +88,12 @@
nextMajorForPrefix = listToMaybe . rec
where
rec prfx = do
- ((st, _), p) <- firsts prfx
- case st of
- Enter l -> [l]
- RuleStep _ r | isMajor r -> [getId r]
- _ -> rec p
+ ((r, _, _), p) <- firsts prfx
+ case isEnterRule r of
+ Just l -> [l]
+ Nothing
+ | isMajor r -> [getId r]
+ | otherwise -> rec p
------------------------------------------------------------------------
-- Data types for replies
diff --git a/src/Ideas/Service/Request.hs b/src/Ideas/Service/Request.hs
--- a/src/Ideas/Service/Request.hs
+++ b/src/Ideas/Service/Request.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Request.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Request.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Service.Request where
@@ -22,16 +22,32 @@
data Request = Request
{ serviceId :: Maybe Id
, exerciseId :: Maybe Id
- , user :: Maybe String
, source :: Maybe String
, feedbackScript :: Maybe String
+ , requestInfo :: Maybe String
, cgiBinary :: Maybe String
+ , logSchema :: Maybe Schema
, dataformat :: DataFormat
, encoding :: [Encoding]
}
emptyRequest :: Request
-emptyRequest = Request Nothing Nothing Nothing Nothing Nothing Nothing XML []
+emptyRequest = Request Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing XML []
+
+data Schema = V1 | V2 | NoLogging deriving (Show, Eq)
+
+getSchema :: Request -> Schema
+getSchema = fromMaybe V1 . logSchema -- log schema V1 is the default
+
+readSchema :: Monad m => String -> m Schema
+readSchema s0
+ | s == "v1" = return V1
+ | s == "v2" = return V2
+ | s `elem` ["false", "no"] = return NoLogging
+ | otherwise = fail "Unknown schema"
+ where
+ s = map toLower (filter isAlphaNum s0)
data DataFormat = XML | JSON
deriving Show -- needed for LoggingDatabase
diff --git a/src/Ideas/Service/ServiceList.hs b/src/Ideas/Service/ServiceList.hs
--- a/src/Ideas/Service/ServiceList.hs
+++ b/src/Ideas/Service/ServiceList.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: ServiceList.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: ServiceList.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Service.ServiceList (serviceList, metaServiceList) where
@@ -36,7 +36,7 @@
, equivalenceS, similarityS, suitableS, finishedS, readyS
, stepsremainingS, allapplicationsS
, applyS, generateS, createS, applicableS
- , examplesS, exampleS, submitS, diagnoseS
+ , examplesS, exampleS, submitS, diagnoseS, diagnoseStringS
, findbuggyrulesS, problemdecompositionS
-- textual services
, onefirsttextS, submittextS
@@ -47,7 +47,7 @@
metaServiceList dr =
[ indexS dr, servicelistS dr, serviceinfoS dr, exerciselistS dr
, rulelistS, ruleinfoS, rulesinfoS, strategyinfoS, exerciseinfoS
- , stateinfoS, examplederivationsS, testreportS
+ , stateinfoS, examplederivationsS, testreportS, logS
]
------------------------------------------------------
@@ -140,13 +140,13 @@
generateS = makeService "basic.generate"
"Given an exercise code and a difficulty level (optional), this service \
\returns an initial state with a freshly generated expression." $
- generate ::: tStdGen .-> tExercise .-> tMaybe tDifficulty .-> tError tState
+ generate ::: tStdGen .-> tExercise .-> tMaybe tDifficulty .-> tMaybe tUserId .-> tIO tState
createS :: Service
createS = makeService "basic.create"
"Given an expression, this service \
\returns an initial state with the original given expression." $
- create ::: tExercise .-> tString .-> tError tState
+ create ::: tExercise .-> tString .-> tMaybe tUserId .-> tIO tState
examplesS :: Service
examplesS = makeService "basic.examples"
@@ -162,12 +162,12 @@
\with an exercise. These are the examples that appear at the page generated \
\for each exercise. Also see the generate service, which returns a random \
\start term." $
- f ::: tExercise .-> tInt .-> tError tState
+ f ::: tExercise .-> tInt .-> tMaybe tUserId .-> tIO tState
where
- f ex nr =
- case drop nr (examplesContext ex) of
- [] -> Left "No such example"
- (_,c ):_ -> Right (emptyStateContext ex c)
+ f ex nr userId =
+ case drop nr (examples ex) of
+ [] -> fail "No such example"
+ (_,a):_ -> startState ex userId a
findbuggyrulesS :: Service
findbuggyrulesS = makeService "basic.findbuggyrules"
@@ -195,6 +195,19 @@
\applied)." $
Diagnose.diagnose ::: tState .-> tContext .-> tMaybe tId .-> Diagnose.tDiagnosis
+diagnoseStringS :: Service
+diagnoseStringS = makeService "basic.diagnose-string"
+ "See diagnose service, but also returns a SyntaxError for invalid input." $
+ diagnoseString ::: tState .-> tString .-> tMaybe tId .-> Diagnose.tDiagnosis
+
+diagnoseString :: State a -> String -> Maybe Id -> Diagnose.Diagnosis a
+diagnoseString st s mot =
+ case parser ex s of
+ Left msg -> Diagnose.SyntaxError msg
+ Right ca -> Diagnose.diagnose st (inContext ex ca) mot
+ where
+ ex = exercise st
+
------------------------------------------------------
-- Problem decomposition service
@@ -298,7 +311,7 @@
microstepsS = makeService "meta.microsteps" "Next (minor) steps." $
(map f . microsteps) ::: tState .-> tList (tPair (tTuple3 tRule tLocation tEnvironment) tState)
where
- f ((s, ctx), st) = ((stepRule s, location ctx, stepEnvironment s), st)
+ f ((s, ctx, env), st) = ((s, location ctx, env), st)
examplederivationsS :: Service
examplederivationsS = makeService "meta.examplederivations"
@@ -308,4 +321,11 @@
testreportS :: Service
testreportS = makeService "meta.testreport"
"Show test report for an exercise." $
- (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: tStdGen .-> tExercise .-> tIO tTestSuiteResult
+ (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: tStdGen .-> tExercise .-> tIO tTestSuiteResult
+
+logS :: Service
+logS = makeService "meta.log"
+ "Feedback service for logging events: the reply is always empty. The \
+ \optional input state can be used to record userid, sessionid, and \
+ \taskid."
+ (const () ::: tMaybe tState .-> tUnit)
diff --git a/src/Ideas/Service/State.hs b/src/Ideas/Service/State.hs
--- a/src/Ideas/Service/State.hs
+++ b/src/Ideas/Service/State.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -13,34 +13,44 @@
-- derivation.
--
-----------------------------------------------------------------------------
--- $Id: State.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: State.hs 8745 2015-10-15 14:45:46Z bastiaan $
module Ideas.Service.State
( -- * Exercise state
- State, makeState, makeNoState, emptyStateContext, emptyState
+ State, startState, makeState, makeNoState, emptyStateContext, emptyState
, exercise, statePrefix, stateContext, stateTerm
+ , stateUser, stateSession, stateStartTerm, restart
, withoutPrefix, stateLabels, suitable, finished, firsts, microsteps
) where
-import Data.Function
+import Control.Monad
+import Data.Char
import Data.List
import Data.Maybe
import Ideas.Common.Library hiding (suitable, ready, (:~>))
-import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.Prefix
import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Strategy.Symbol
+import System.Random
data State a = State
- { exercise :: Exercise a
- , statePrefix :: Prefix (Context a)
- , stateContext :: Context a
+ { exercise :: Exercise a
+ , statePrefix :: Prefix (Context a)
+ , stateContext :: Context a
+ , stateUser :: Maybe String
+ , stateSession :: Maybe String
+ , stateStartTerm :: Maybe String
}
instance Show (State a) where
show s = unlines $ "State {" : map (" "++) xs ++ ["}"]
where
- xs = [ "exercise = " ++ showId s
- , "prefix = " ++ show (statePrefix s)
- , "term = " ++ prettyPrinterContext (exercise s) (stateContext s)
+ xs = [ "exercise = " ++ showId s
+ , "prefix = " ++ show (statePrefix s)
+ , "term = " ++ prettyPrinterContext (exercise s) (stateContext s)
+ , "user = " ++ show (stateUser s)
+ , "session = " ++ show (stateSession s)
+ , "startterm = " ++ show (stateStartTerm s)
]
instance HasId (State a) where
@@ -53,22 +63,19 @@
s { stateContext = setEnvironment env (stateContext s) }
instance Firsts (State a) where
- type Elem (State a) = (Step (Context a), Context a)
+ type Elem (State a) = (Rule (Context a), Context a, Environment)
- firsts st = firstsOrdered cmp st
- where
- cmp = ruleOrdering (exercise st) `on` (stepRule . fst)
+ ready = ready . majorPrefix . statePrefix
+ firsts = firstsWith (majorPrefix . statePrefix)
- menu st = fmap f (menu (majorPrefix (statePrefix st)))
- where
- f Done = Done
- f (info :~> p) = info :~> State (exercise st) p (snd info)
+microsteps :: State a -> [((Rule (Context a), Context a, Environment), State a)]
+microsteps = firstsWith statePrefix
-microsteps :: State a -> [((Step (Context a), Context a), State a)]
-microsteps st = concatMap f (bests (menu (statePrefix st)))
+firstsWith :: (State a -> Prefix (Context a)) -> State a -> [((Rule (Context a), Context a, Environment), State a)]
+firstsWith getPrefix st = map f (firstsOrdered cmp (getPrefix st))
where
- f Done = []
- f (info :~> p) = [(info, State (exercise st) p (snd info))]
+ cmp = ruleOrdering (exercise st)
+ f ((r, a, env), pr) = ((r, a, env), st {statePrefix = pr, stateContext = a})
stateTerm :: State a -> a
stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext
@@ -76,7 +83,7 @@
-----------------------------------------------------------
makeState :: Exercise a -> Prefix (Context a) -> Context a -> State a
-makeState = State
+makeState ex prf ctx = State ex prf ctx Nothing Nothing Nothing
-- State without a prefix
makeNoState :: Exercise a -> Context a -> State a
@@ -90,6 +97,28 @@
emptyState :: Exercise a -> a -> State a
emptyState ex = emptyStateContext ex . inContext ex
+startState :: Exercise a -> Maybe String -> a -> IO (State a)
+startState ex userId a = do
+ sid <- newSessionId
+ return (emptyStateContext ex (inContext ex a))
+ { stateUser = userId
+ , stateSession = Just sid
+ , stateStartTerm = Just (prettyPrinter ex a)
+ }
+
+-- Restart the strategy: make sure that the new state has a prefix
+-- When resetting the prefix, also make sure that the context is refreshed
+restart :: State a -> State a
+restart state
+ | canBeRestarted ex = state
+ { stateContext = ctx
+ , statePrefix = emptyPrefix (strategy ex) ctx
+ }
+ | otherwise = state
+ where
+ ex = exercise state
+ ctx = inContext ex (stateTerm state)
+
withoutPrefix :: State a -> Bool
withoutPrefix = null . prefixPaths . statePrefix
@@ -105,4 +134,14 @@
ex = exercise st
make path =
let (xs, _) = replayPath path (strategy ex) (stateContext st)
- in nub [l | Enter l <- xs] \\ [l | Exit l <- xs]
+ in nub (mapMaybe isEnterRule xs) \\ mapMaybe isExitRule xs
+
+-- | Produces a 80 bit random number, represented as 20 hexadecimal digits
+newSessionId :: IO String
+newSessionId = replicateM 20 $ do
+ n <- randomRIO (0 :: Int, 15)
+ return (hex n)
+ where
+ hex :: Int -> Char
+ hex n | n < 10 = chr (n+48)
+ | otherwise = chr (n+87)
diff --git a/src/Ideas/Service/Submit.hs b/src/Ideas/Service/Submit.hs
--- a/src/Ideas/Service/Submit.hs
+++ b/src/Ideas/Service/Submit.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- Diagnose a term submitted by a student. Deprecated (see diagnose service).
--
-----------------------------------------------------------------------------
--- $Id: Submit.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Submit.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Service.Submit
( submit, Result(..), tResult
@@ -35,6 +35,7 @@
fromDiagnose :: Diagnosis a -> Result a
fromDiagnose diagnosis =
case diagnosis of
+ Diagnose.SyntaxError s -> NotEquivalent s -- should not happen
Diagnose.Buggy _ r -> Buggy [r]
Diagnose.NotEquivalent s -> NotEquivalent s
Diagnose.Similar _ s -> Ok [] s
diff --git a/src/Ideas/Service/Types.hs b/src/Ideas/Service/Types.hs
--- a/src/Ideas/Service/Types.hs
+++ b/src/Ideas/Service/Types.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, FlexibleContexts #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Types.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Types.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Service.Types
( -- * Services
@@ -20,11 +20,13 @@
, TypeRep(..), Const(..), Type, TypedValue(..)
, Equal(..), ShowF(..), equalM
-- * Constructing types
- , tEnvironment, tLocation, tRule, tTuple3, tTuple4, tTuple5, tPair
+ , tEnvironment, tLocation, tRule, tUnit, tTuple3, tTuple4, tTuple5, tPair
, tStrategy, tTree, tState, tBool, tMaybe, tString, tList
- , tId, tService, tSomeExercise, tText, tDifficulty, tContext
+ , tId, tService, tSomeExercise, tText, tDifficulty, tUserId ,tContext
, tDerivation, tError, (.->), tIO, tExercise, tTestSuiteResult, tStdGen
, tScript, tExamples, tStrategyCfg, tInt
+ -- * Searching a typed value
+ , findValuesOfType
) where
import Control.Monad
@@ -280,6 +282,9 @@
tList :: Type a t -> Type a [t]
tList = List
+tUnit :: Type a ()
+tUnit = Unit
+
tPair :: Type a t1 -> Type a t2 -> Type a (t1, t2)
tPair = Pair
@@ -330,6 +335,9 @@
where
f = fromMaybe Medium . readDifficulty
+tUserId :: Type a String
+tUserId = Tag "UserId" tString
+
tStdGen :: Type a StdGen
tStdGen = Const StdGen
@@ -358,4 +366,23 @@
g (Node a xs) = (a, xs)
tTestSuiteResult :: Type a TestSuite.Result
-tTestSuiteResult = Const Result
+tTestSuiteResult = Const Result
+
+-------------------------------------
+
+findValuesOfType :: Type a t -> TypedValue (Type a) -> [t]
+findValuesOfType thisType = rec
+ where
+ rec tv@(a ::: tp) =
+ case equal tp thisType of
+ Just f -> [f a]
+ Nothing -> recDown tv
+
+ recDown (a ::: tp) =
+ case tp of
+ Iso iso t -> rec (to iso a ::: t)
+ Tag _ t -> rec (a ::: t)
+ List t -> concatMap (\b -> rec (b ::: t)) a
+ Pair t1 t2 -> rec (fst a ::: t1) ++ rec (snd a ::: t2)
+ t1 :|: t2 -> either (\b -> rec (b ::: t1)) (\b -> rec (b ::: t2)) a
+ _ -> []
diff --git a/src/Ideas/Text/HTML.hs b/src/Ideas/Text/HTML.hs
--- a/src/Ideas/Text/HTML.hs
+++ b/src/Ideas/Text/HTML.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- See http://www.w3.org/TR/html4/
--
-----------------------------------------------------------------------------
--- $Id: HTML.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: HTML.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.HTML
( HTMLPage, HTMLBuilder
diff --git a/src/Ideas/Text/JSON.hs b/src/Ideas/Text/JSON.hs
--- a/src/Ideas/Text/JSON.hs
+++ b/src/Ideas/Text/JSON.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,14 +12,15 @@
-- JSON. JSON is a lightweight alternative for XML.
--
-----------------------------------------------------------------------------
--- $Id: JSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: JSON.hs 8743 2015-10-14 19:48:13Z bastiaan $
module Ideas.Text.JSON
( JSON(..), Key, Number(..) -- types
, InJSON(..) -- type class
, lookupM
, parseJSON, compactJSON -- parser and pretty-printers
- , jsonRPC, RPCHandler, propEncoding
+ , jsonRPC, RPCHandler, RPCResponse(..)
+ , propEncoding
) where
import Control.Exception
@@ -89,9 +90,9 @@
escape :: String -> String
escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM
where
- f '\n' = "\\\\n"
+ f '\n' = "\\n"
f '\r' = "" -- carriage return (DOS files)
- f '\t' = "\\\\t"
+ f '\t' = "\\t"
f '"' = "\\\""
f '\\' = "\\\\"
f c = [c]
diff --git a/src/Ideas/Text/OpenMath/FMP.hs b/src/Ideas/Text/OpenMath/FMP.hs
--- a/src/Ideas/Text/OpenMath/FMP.hs
+++ b/src/Ideas/Text/OpenMath/FMP.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Formal mathematical properties (FMP)
--
-----------------------------------------------------------------------------
--- $Id: FMP.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: FMP.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.OpenMath.FMP where
diff --git a/src/Ideas/Text/OpenMath/Object.hs b/src/Ideas/Text/OpenMath/Object.hs
--- a/src/Ideas/Text/OpenMath/Object.hs
+++ b/src/Ideas/Text/OpenMath/Object.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -10,7 +10,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Object.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Object.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.OpenMath.Object
( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
diff --git a/src/Ideas/Text/OpenMath/Symbol.hs b/src/Ideas/Text/OpenMath/Symbol.hs
--- a/src/Ideas/Text/OpenMath/Symbol.hs
+++ b/src/Ideas/Text/OpenMath/Symbol.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Symbol.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Symbol.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.OpenMath.Symbol where
diff --git a/src/Ideas/Text/OpenMath/Tests.hs b/src/Ideas/Text/OpenMath/Tests.hs
--- a/src/Ideas/Text/OpenMath/Tests.hs
+++ b/src/Ideas/Text/OpenMath/Tests.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -9,7 +9,7 @@
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
--- $Id: Tests.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Tests.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.OpenMath.Tests (propEncoding) where
diff --git a/src/Ideas/Text/Parsing.hs b/src/Ideas/Text/Parsing.hs
--- a/src/Ideas/Text/Parsing.hs
+++ b/src/Ideas/Text/Parsing.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Utility functions for parsing with Parsec library
--
-----------------------------------------------------------------------------
--- $Id: Parsing.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Parsing.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.Parsing
( module Export
diff --git a/src/Ideas/Text/UTF8.hs b/src/Ideas/Text/UTF8.hs
--- a/src/Ideas/Text/UTF8.hs
+++ b/src/Ideas/Text/UTF8.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Support for the UTF8 encoding
--
-----------------------------------------------------------------------------
--- $Id: UTF8.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: UTF8.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.UTF8
( encode, encodeM, decode, decodeM
diff --git a/src/Ideas/Text/XML.hs b/src/Ideas/Text/XML.hs
--- a/src/Ideas/Text/XML.hs
+++ b/src/Ideas/Text/XML.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -12,7 +12,7 @@
-- functions defined elsewhere.
--
-----------------------------------------------------------------------------
--- $Id: XML.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: XML.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.XML
( XML, Attr, AttrList, Element(..), InXML(..)
diff --git a/src/Ideas/Text/XML/Document.hs b/src/Ideas/Text/XML/Document.hs
--- a/src/Ideas/Text/XML/Document.hs
+++ b/src/Ideas/Text/XML/Document.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Datatype for representing XML documents
--
-----------------------------------------------------------------------------
--- $Id: Document.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Document.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.XML.Document
( Name, Attributes, Attribute(..), Reference(..), Parameter(..)
diff --git a/src/Ideas/Text/XML/Interface.hs b/src/Ideas/Text/XML/Interface.hs
--- a/src/Ideas/Text/XML/Interface.hs
+++ b/src/Ideas/Text/XML/Interface.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Collection of common operation on XML documents
--
-----------------------------------------------------------------------------
--- $Id: Interface.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Interface.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.XML.Interface
( Element(..), Content, Attribute(..), Attributes
diff --git a/src/Ideas/Text/XML/Parser.hs b/src/Ideas/Text/XML/Parser.hs
--- a/src/Ideas/Text/XML/Parser.hs
+++ b/src/Ideas/Text/XML/Parser.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -13,7 +13,7 @@
-- http://www.w3.org/TR/2006/REC-xml-20060816
--
-----------------------------------------------------------------------------
--- $Id: Parser.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Parser.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.XML.Parser (document, extParsedEnt, extSubset) where
diff --git a/src/Ideas/Text/XML/Unicode.hs b/src/Ideas/Text/XML/Unicode.hs
--- a/src/Ideas/Text/XML/Unicode.hs
+++ b/src/Ideas/Text/XML/Unicode.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--- Copyright 2015, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
+-- Copyright 2015, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
@@ -11,7 +11,7 @@
-- Support for Unicode
--
-----------------------------------------------------------------------------
--- $Id: Unicode.hs 7524 2015-04-08 07:31:15Z bastiaan $
+-- $Id: Unicode.hs 8740 2015-10-14 19:26:22Z bastiaan $
module Ideas.Text.XML.Unicode
( isExtender, isLetter, isDigit, isCombiningChar
diff --git a/src/Network/CGI.hs b/src/Network/CGI.hs
--- a/src/Network/CGI.hs
+++ b/src/Network/CGI.hs
@@ -104,8 +104,8 @@
import Network.Multipart
import Network.Multipart.Header
import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, escapeURIString, isUnescapedInURI)
-import qualified Data.Map as Map
import System.IO (stdin, stdout)
+import qualified Data.Map as Map
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS
diff --git a/src/Network/CGI/Compat.hs b/src/Network/CGI/Compat.hs
--- a/src/Network/CGI/Compat.hs
+++ b/src/Network/CGI/Compat.hs
@@ -27,7 +27,7 @@
import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle)
import System.IO (Handle, hPutStrLn, stdin, stdout, hGetLine, hClose, IOMode(ReadWriteMode))
import qualified Data.Map as Map
-
+
import System.IO.Error (isEOFError)
import Data.ByteString.Lazy.Char8 (ByteString)