packages feed

ideas 1.3 → 1.8

raw patch · 138 files changed

Files

+ CHANGELOG.txt view
@@ -0,0 +1,94 @@+Changelog ideas-1.7 => ideas-1.8++* support for automatically generated (generic) IsTerm instances+* introducing Examples data type for exercise records (unifying expr lists/generators)+* redesigning xml interface (with proper character escaping)+* adding literal xml to service types+* introducing ToXML and ToHTML type classes+* new command-line option for rerunning inputs in database+* solution service variant with parameterized max number of steps+* adding instance for IsTerm (a, b, c)+* extending derivation interface (in Ideas.Common.Derivation)+* refactoring logging interface and database name+* new general Decoding module in utils; refactored encoders/decoders+* moving unicode decoding from parseXML/parseJSON to Main.Default++Changelog ideas-1.6 => ideas.1.7++* replacing network.cgi package by WAI+* adding support for MathML+* adding constraints (to exercises) for constraint-based tutoring+* adding support for W3CSS (css classes and templates)+* restyling html output+* set busy timeout on database connection (when logging requests)+* changing name of logging database for v2 schema, and make v2 the default+* logging is now by default enabled: see 'logging' flag in cabal package+* improving performance of rulesinfo service+* merging duplicate attributes in xml/html+* simplifying the computation of the difference between terms+* extending xml-encoder with cases for lists, attributes and content data+* adding missing strategy combinators preference and orelse+* adding instances for type class Different+* improving Show instance for Context+* show logging enabled/disabled in html output++Changelog ideas-1.5 => ideas.1.6++* dynamic strategy combinator that uses the current object/term+* more instances for IsTerm (Maybe, Bool, Map, Set)+* exercise-specific properties (that can be parameterized over its type)+* support for encoding exercise terms in JSON (using an exercise property)+* basic support for Latex and MathJax (in html output)+* extended 'apply' feedback service with buggy rules and restarts+* redesigned (parameterized) transformations+* reimplemented strategy combinator split, based on %>>+* new function defaultMainWith, which takes options+* added 'onefinal' feedback service, which returns a final term in context+* layered design for sub-directories: renaming/moving some modules +  (e.g. Ideas.Utils.Prelude)+* Typeable constraint now properly encapsulated in Ref type+* removing (static) documentation generation (unused feature)+* removing Common.Algebra modules (now in the Math domain reasoner)+* fixed escaping of characters in xml+* fixed recognition of exercise IDs in ModeJSON+* fixed processing of Null in EncoderJSON+* fixed rule ordering in function ruleset+ +Changelog ideas-1.4 => ideas.1.5++* upgrade to ghc-7.10+* reintroducing dependency on standard cgi library+* adding missing instances for Term and ShowString+* new option for JSON mode: exercise terms can be encoded in JSON+* switched to QuickCheck's random number generator QCGen+* requests can fix the random seed+* added Term to service types, encoders and decoders+* JSON-Int can be used for decoded environments+* new implementation for interleave and atomic prefix combinators (more lazy)+* bug fix: "no prefix" now handled by json decoder+++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
− CREDITS.txt 
@@ -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
LICENSE.txt view
@@ -1,674 +1,202 @@-                    GNU GENERAL PUBLIC LICENSE
-                       Version 3, 29 June 2007
 
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-                            Preamble
-
-  The GNU 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.
 
-    <one line to give the program's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
+   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 <http://www.gnu.org/licenses/>.
+   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.
 
-    <program>  Copyright (C) <year>  <name of author>
-    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
-    This is free software, and you are welcome to redistribute it
-    under certain conditions; type `show c' for details.
+   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.gnu.org/licenses/>.
+       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
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+   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.
+ NOTICE.txt view
@@ -0,0 +1,39 @@+Copyright 2019 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/+       +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, +   Marcell van Geest, Jordy van Dortmont, Jorn van Wijk, Alejandro Serrano Mena,+   Niels Steenbergen, Wink van Zon
ideas.cabal view
@@ -1,175 +1,191 @@-name:                   ideas-version:                1.3-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. --category:               Education-copyright:              (c) 2015-license:                GPL-license-file:           LICENSE.txt-author:                 Bastiaan Heeren, Alex Gerdes, Johan Jeuring-maintainer:             bastiaan.heeren@ou.nl-stability:              provisional-extra-source-files:     CREDITS.txt-build-type:             Simple-cabal-version:          >= 1.8.0.2-tested-with:            GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.3--source-repository head-  type:     svn-  location: https://ideas.cs.uu.nl/svn/Feedback/trunk/------------------------------------------------------------------------------------Library-  ghc-options:       -Wall-  hs-source-dirs:    src-  Build-Depends:     base >= 4.2 && < 5, -                     QuickCheck >= 2.4.1 && < 2.7, -                     Diff,-                     containers, -                     random, -                     uniplate, -                     time, -                     filepath,-                     directory,-                     parsec,-                     wl-pprint,-                     array,-                     mtl == 2.1.*,-                     network < 2.6,-                     exceptions,-                     multipart,-                     bytestring,-                     old-time,-                     old-locale,-                     xhtml--  Exposed-modules:-    Ideas.Common.Algebra.Boolean-    Ideas.Common.Algebra.BooleanLaws-    Ideas.Common.Algebra.Field-    Ideas.Common.Algebra.FieldLaws-    Ideas.Common.Algebra.Group-    Ideas.Common.Algebra.GroupLaws-    Ideas.Common.Algebra.Law-    Ideas.Common.Algebra.SmartGroup-    Ideas.Common.Classes-    Ideas.Common.Context-    Ideas.Common.Derivation-    Ideas.Common.DerivationTree-    Ideas.Common.Environment-    Ideas.Common.Exercise-    Ideas.Common.ExerciseTests-    Ideas.Common.Id-    Ideas.Common.Library-    Ideas.Common.Predicate-    Ideas.Common.Rewriting-    Ideas.Common.Rewriting.AC-    Ideas.Common.Rewriting.Confluence-    Ideas.Common.Rewriting.Difference-    Ideas.Common.Rewriting.RewriteRule-    Ideas.Common.Rewriting.Substitution-    Ideas.Common.Rewriting.Term-    Ideas.Common.Rewriting.Unification-    Ideas.Common.Rule-    Ideas.Common.Rule.Abstract-    Ideas.Common.Rule.EnvironmentMonad-    Ideas.Common.Rule.Parameter-    Ideas.Common.Rule.Recognizer-    Ideas.Common.Rule.Transformation-    Ideas.Common.Strategy-    Ideas.Common.Strategy.Abstract-    Ideas.Common.Strategy.Choice-    Ideas.Common.Strategy.Combinators-    Ideas.Common.Strategy.Configuration-    Ideas.Common.Strategy.Core-    Ideas.Common.Strategy.Derived-    Ideas.Common.Strategy.Location-    Ideas.Common.Strategy.Parsing-    Ideas.Common.Strategy.Process-    Ideas.Common.Strategy.Sequence-    Ideas.Common.Strategy.Traversal-    Ideas.Common.Traversal.Iterator-    Ideas.Common.Traversal.Navigator-    Ideas.Common.Traversal.Tests-    Ideas.Common.Traversal.Utils-    Ideas.Common.Utils-    Ideas.Common.Utils.QuickCheck-    Ideas.Common.Utils.StringRef-    Ideas.Common.Utils.TestSuite-    Ideas.Common.Utils.Uniplate-    Ideas.Common.View-    Ideas.Encoding.DecoderJSON-    Ideas.Encoding.DecoderXML-    Ideas.Encoding.Encoder-    Ideas.Encoding.EncoderHTML-    Ideas.Encoding.EncoderJSON-    Ideas.Encoding.EncoderXML-    Ideas.Encoding.Evaluator-    Ideas.Encoding.LinkManager-    Ideas.Encoding.ModeJSON-    Ideas.Encoding.ModeXML-    Ideas.Encoding.OpenMathSupport-    Ideas.Encoding.RulePresenter-    Ideas.Encoding.RulesInfo-    Ideas.Encoding.StrategyInfo-    Ideas.Main.BlackBoxTests-    Ideas.Main.Default-    Ideas.Main.Documentation-    Ideas.Main.LoggingDatabase-    Ideas.Main.Options-    Ideas.Main.Revision-    Ideas.Service.BasicServices-    Ideas.Service.Diagnose-    Ideas.Service.DomainReasoner-    Ideas.Service.FeedbackScript.Analysis-    Ideas.Service.FeedbackScript.Parser-    Ideas.Service.FeedbackScript.Run-    Ideas.Service.FeedbackScript.Syntax-    Ideas.Service.FeedbackText-    Ideas.Service.ProblemDecomposition-    Ideas.Service.Request-    Ideas.Service.ServiceList-    Ideas.Service.State-    Ideas.Service.Submit-    Ideas.Service.Types-    Ideas.Text.HTML-    Ideas.Text.JSON-    Ideas.Text.OpenMath.Dictionary.Arith1-    Ideas.Text.OpenMath.Dictionary.Calculus1-    Ideas.Text.OpenMath.Dictionary.Fns1-    Ideas.Text.OpenMath.Dictionary.Linalg2-    Ideas.Text.OpenMath.Dictionary.List1-    Ideas.Text.OpenMath.Dictionary.Logic1-    Ideas.Text.OpenMath.Dictionary.Nums1-    Ideas.Text.OpenMath.Dictionary.Quant1-    Ideas.Text.OpenMath.Dictionary.Relation1-    Ideas.Text.OpenMath.Dictionary.Transc1-    Ideas.Text.OpenMath.FMP-    Ideas.Text.OpenMath.Object-    Ideas.Text.OpenMath.Symbol-    Ideas.Text.OpenMath.Tests-    Ideas.Text.Parsing-    Ideas.Text.UTF8-    Ideas.Text.XML-    Ideas.Text.XML.Document-    Ideas.Text.XML.Interface-    Ideas.Text.XML.Parser-    Ideas.Text.XML.Unicode--  Other-modules:-    Network.CGI-    Network.CGI.Accept-    Network.CGI.Compat-    Network.CGI.Cookie-    Network.CGI.Monad-    Network.CGI.Protocol-----------------------------------------------------------------------------------+name:                   ideas
+version:                1.8
+synopsis:               Feedback services for intelligent tutoring systems
+homepage:               http://ideas.cs.uu.nl/
+description:
+
+  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) 2019
+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:     NOTICE.txt, CHANGELOG.txt
+build-type:             Simple
+cabal-version:          >= 1.8.0.2
+tested-with:            GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2
+
+source-repository head
+  type:     git
+  location: https://github.com/ideas-edu/ideas.git
+
+flag logging
+  description: enable support for logging interactions to a sqlite3 database
+  default: True
+
+--------------------------------------------------------------------------------
+
+Library
+  if flag(logging) {
+    cpp-options:     -DDB
+    Build-Depends:   HDBC, HDBC-sqlite3
+  }
+
+  ghc-options:       -Wall
+  hs-source-dirs:    src
+  Build-Depends:
+     base >= 4.8 && < 5,
+     blaze-builder >= 0.4,
+     bytestring,
+     case-insensitive,
+     QuickCheck >= 2.8 && < 2.12,
+     Diff,
+     containers,
+     directory,
+     filepath,
+     http-types,
+     mtl,
+     network,
+     parsec,
+     random,
+     streaming-commons < 0.2,
+     time,
+     uniplate, 
+     wai,
+     wl-pprint
+
+  if !impl(ghc >= 8.0)
+    Build-Depends: semigroups == 0.18.*
+
+  Exposed-modules:
+    Ideas.Common.Classes
+    Ideas.Common.Constraint
+    Ideas.Common.Context
+    Ideas.Common.Derivation
+    Ideas.Common.DerivationTree
+    Ideas.Common.Environment
+    Ideas.Common.Examples
+    Ideas.Common.Exercise
+    Ideas.Common.ExerciseTests
+    Ideas.Common.Id
+    Ideas.Common.Library
+    Ideas.Common.Predicate
+    Ideas.Common.Rewriting
+    Ideas.Common.Rewriting.AC
+    Ideas.Common.Rewriting.AutoTerm
+    Ideas.Common.Rewriting.Confluence
+    Ideas.Common.Rewriting.Difference
+    Ideas.Common.Rewriting.RewriteRule
+    Ideas.Common.Rewriting.Substitution
+    Ideas.Common.Rewriting.Term
+    Ideas.Common.Rewriting.Unification
+    Ideas.Common.Rule
+    Ideas.Common.Rule.Abstract
+    Ideas.Common.Rule.Parameter
+    Ideas.Common.Rule.Recognizer
+    Ideas.Common.Rule.Transformation
+    Ideas.Common.Strategy
+    Ideas.Common.Strategy.Abstract
+    Ideas.Common.Strategy.Choice
+    Ideas.Common.Strategy.Combinators
+    Ideas.Common.Strategy.Configuration
+    Ideas.Common.Strategy.CyclicTree
+    Ideas.Common.Strategy.Derived
+    Ideas.Common.Strategy.Legacy
+    Ideas.Common.Strategy.Location
+    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
+    Ideas.Common.Traversal.Tests
+    Ideas.Common.Traversal.Utils
+    Ideas.Common.View
+    Ideas.Encoding.DecoderJSON
+    Ideas.Encoding.DecoderXML
+    Ideas.Encoding.Encoder
+    Ideas.Encoding.EncoderHTML
+    Ideas.Encoding.EncoderJSON
+    Ideas.Encoding.EncoderXML
+    Ideas.Encoding.Evaluator
+    Ideas.Encoding.LinkManager
+    Ideas.Encoding.Logging
+    Ideas.Encoding.ModeJSON
+    Ideas.Encoding.ModeXML
+    Ideas.Encoding.OpenMathSupport
+    Ideas.Encoding.Options
+    Ideas.Encoding.Request
+    Ideas.Encoding.RulePresenter
+    Ideas.Encoding.RulesInfo
+    Ideas.Encoding.StrategyInfo
+    Ideas.Main.CGI
+    Ideas.Main.CmdLineOptions
+    Ideas.Main.Default
+    Ideas.Main.Revision
+    Ideas.Service.BasicServices
+    Ideas.Service.Diagnose
+    Ideas.Service.DomainReasoner
+    Ideas.Service.FeedbackScript.Analysis
+    Ideas.Service.FeedbackScript.Parser
+    Ideas.Service.FeedbackScript.Run
+    Ideas.Service.FeedbackScript.Syntax
+    Ideas.Service.FeedbackText
+    Ideas.Service.ProblemDecomposition
+    Ideas.Service.ServiceList
+    Ideas.Service.State
+    Ideas.Service.Submit
+    Ideas.Service.Types
+    Ideas.Text.HTML
+    Ideas.Text.HTML.Templates
+    Ideas.Text.HTML.W3CSS
+    Ideas.Text.JSON
+    Ideas.Text.Latex
+    Ideas.Text.MathML
+    Ideas.Text.OpenMath.Dictionary.Arith1
+    Ideas.Text.OpenMath.Dictionary.Calculus1
+    Ideas.Text.OpenMath.Dictionary.Fns1
+    Ideas.Text.OpenMath.Dictionary.Linalg2
+    Ideas.Text.OpenMath.Dictionary.List1
+    Ideas.Text.OpenMath.Dictionary.Logic1
+    Ideas.Text.OpenMath.Dictionary.Nums1
+    Ideas.Text.OpenMath.Dictionary.Quant1
+    Ideas.Text.OpenMath.Dictionary.Relation1
+    Ideas.Text.OpenMath.Dictionary.Transc1
+    Ideas.Text.OpenMath.FMP
+    Ideas.Text.OpenMath.Object
+    Ideas.Text.OpenMath.Symbol
+    Ideas.Text.OpenMath.Tests
+    Ideas.Text.UTF8
+    Ideas.Text.XML
+    Ideas.Text.XML.Document
+    Ideas.Text.XML.Parser
+    Ideas.Text.XML.Unicode
+    Ideas.Utils.BlackBoxTests
+    Ideas.Utils.Decoding
+    Ideas.Utils.Parsing
+    Ideas.Utils.Prelude
+    Ideas.Utils.QuickCheck
+    Ideas.Utils.StringRef
+    Ideas.Utils.TestSuite
+    Ideas.Utils.Typeable
+    Ideas.Utils.Uniplate
+
+--------------------------------------------------------------------------------
− src/Ideas/Common/Algebra/Boolean.hs 
@@ -1,165 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
---  $Id: Boolean.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.Boolean
-   ( -- * Boolean algebra
-     BoolValue(..), Boolean(..)
-   , ands, ors, implies, equivalent
-     -- * CoBoolean (matching)
-   , CoBoolean(..), conjunctions, disjunctions
-     -- * Monoids monoid
-   , DualMonoid(..), And(..), Or(..)
-   ) where
-
-import Control.Applicative
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Classes
-import Test.QuickCheck
-
---------------------------------------------------------
--- Boolean algebra
-
--- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse
-class BoolValue a where
-   true     :: a
-   false    :: a
-   fromBool :: Bool -> a
-   isTrue   :: a -> Bool
-   isFalse  :: a -> Bool
-   -- default definitions
-   true  = fromBool True
-   false = fromBool False
-   fromBool b = if b then true else false
-
-class BoolValue a => Boolean a where
-   (<&&>)     :: a -> a -> a
-   (<||>)     :: a -> a -> a
-   complement :: a -> a
-
-instance BoolValue Bool where
-   fromBool = id
-   isTrue   = id
-   isFalse  = not
-
-instance BoolValue b => BoolValue (a -> b) where
-   fromBool x = const (fromBool x)
-   isTrue  = error "not implemented"
-   isFalse = error "not implemented"
-
-instance Boolean Bool where
-   (<&&>)     = (&&)
-   (<||>)     = (||)
-   complement = not
-
-instance Boolean b => Boolean (a -> b) where
-   f <&&> g   = \x -> f x <&&> g x
-   f <||> g   = \x -> f x <||> g x
-   complement = (.) complement
-
-ands :: Boolean a => [a] -> a -- or use mconcat with And monoid
-ands xs | null xs   = true
-        | otherwise = foldr1 (<&&>) xs
-
-ors :: Boolean a => [a] -> a
-ors xs | null xs   = false
-       | otherwise = foldr1 (<||>) xs
-
-implies :: Boolean a => a -> a -> a
-implies a b = complement a <||> b
-
-equivalent :: Boolean a => a -> a -> a
-equivalent a b = (a <&&> b) <||> (complement a <&&> complement b)
-
---------------------------------------------------------
--- CoBoolean (matching)
-
-class BoolValue a => CoBoolean a where
-   isAnd        :: a -> Maybe (a, a)
-   isOr         :: a -> Maybe (a, a)
-   isComplement :: a -> Maybe a
-
-instance CoBoolean a => CoMonoid (And a) where
-   isEmpty  = isTrue . fromAnd
-   isAppend = fmap (mapBoth And) . isAnd . fromAnd
-
-instance CoBoolean a => CoMonoidZero (And a) where
-   isMonoidZero = isFalse . fromAnd
-
-instance CoBoolean a => CoMonoid (Or a) where
-   isEmpty  = isFalse . fromOr
-   isAppend = fmap (mapBoth Or) . isOr . fromOr
-
-instance CoBoolean a => CoMonoidZero (Or a) where
-   isMonoidZero = isTrue . fromOr
-
-conjunctions :: CoBoolean a => a -> [a]
-conjunctions = map fromAnd . associativeList . And
-
-disjunctions :: CoBoolean a => a -> [a]
-disjunctions = map fromOr . associativeList . Or
-
---------------------------------------------------------
--- Dual monoid for a monoid (and for or, and vice versa)
-
-class MonoidZero a => DualMonoid a where
-   (><)      :: a -> a -> a
-   dualCompl :: a -> a
-
---------------------------------------------------------
--- And monoid
-
-newtype And a = And {fromAnd :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor And where -- could be derived
-   fmap f = And . f . fromAnd
-
-instance Applicative And where
-   pure            = And
-   And f <*> And a = And (f a)
-
-instance Boolean a => Monoid (And a) where
-   mempty  = pure true
-   mappend = liftA2 (<&&>)
-
-instance Boolean a => MonoidZero (And a) where
-   mzero = pure false
-
-instance Boolean a => DualMonoid (And a) where
-   (><)      = liftA2 (<||>)
-   dualCompl = liftA complement
-
---------------------------------------------------------
--- Or monoid
-
-newtype Or a  = Or {fromOr :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor Or where -- could be derived
-   fmap f = Or . f . fromOr
-
-instance Applicative Or where
-   pure          = Or
-   Or f <*> Or a = Or (f a)
-
-instance Boolean a => Monoid (Or a) where
-   mempty  = pure false
-   mappend = liftA2 (<||>)
-
-instance Boolean a => MonoidZero (Or a) where
-   mzero = pure true
-
-instance Boolean a => DualMonoid (Or a) where
-   (><)      = liftA2 (<&&>)
-   dualCompl = liftA complement
− src/Ideas/Common/Algebra/BooleanLaws.hs 
@@ -1,109 +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)
---
------------------------------------------------------------------------------
---  $Id: BooleanLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.BooleanLaws
-   ( -- * Boolean laws
-     andOverOrLaws, orOverAndLaws
-   , complementAndLaws, complementOrLaws
-   , absorptionAndLaws, absorptionOrLaws
-   , deMorganAnd, deMorganOr
-   , doubleComplement, complementTrue, complementFalse
-   , booleanLaws
-     -- * Law transformer
-   , fromAndLaw, fromOrLaw
-     -- * Properties
-   , propsBoolean
-   ) where
-
-import Ideas.Common.Algebra.Boolean
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Algebra.GroupLaws
-import Ideas.Common.Algebra.Law
-import Test.QuickCheck hiding ((><))
-
---------------------------------------------------------
--- Boolean laws
-
-andOverOrLaws, orOverAndLaws :: Boolean a => [Law a]
-andOverOrLaws = map fromAndLaw dualDistributive
-orOverAndLaws = map fromOrLaw  dualDistributive
-
-complementAndLaws, complementOrLaws :: Boolean a => [Law a]
-complementAndLaws = map fromAndLaw dualComplement
-complementOrLaws  = map fromOrLaw  dualComplement
-
-absorptionAndLaws, absorptionOrLaws :: Boolean a => [Law a]
-absorptionAndLaws = map fromAndLaw dualAbsorption
-absorptionOrLaws  = map fromOrLaw  dualAbsorption
-
-deMorganAnd, deMorganOr :: Boolean a => Law a
-deMorganAnd = fromAndLaw deMorgan
-deMorganOr  = fromOrLaw  deMorgan
-
-doubleComplement :: Boolean a => Law a
-doubleComplement = law "double-complement" $ \a ->
-   complement (complement a) :==: a
-
-complementTrue, complementFalse :: Boolean a => Law a
-complementTrue  = fromAndLaw dualTrueFalse
-complementFalse = fromOrLaw  dualTrueFalse
-
-booleanLaws :: Boolean a => [Law a]
-booleanLaws =
-   map fromAndLaw (idempotent : zeroLaws ++ commutativeMonoidLaws) ++
-   map fromOrLaw  (idempotent : zeroLaws ++ commutativeMonoidLaws) ++
-   andOverOrLaws ++ orOverAndLaws ++ complementAndLaws ++ complementOrLaws ++
-   absorptionAndLaws ++ absorptionOrLaws ++
-   [deMorganAnd, deMorganOr, doubleComplement, complementTrue, complementFalse]
-
---------------------------------------------------------
--- Dual laws
-
-dualDistributive :: DualMonoid a => [Law a]
-dualDistributive =
-   [leftDistributiveFor (<>) (><), rightDistributiveFor (<>) (><)]
-
-dualAbsorption :: DualMonoid a => [Law a]
-dualAbsorption =
-   [ law "absorption" $ \a b -> a `f` (a `g` b) :==: a
-   | f <- [(<>), flip (<>)]
-   , g <- [(><), flip (><)]
-   ]
-
-dualComplement :: DualMonoid a => [Law a]
-dualComplement =
-   [ law "complement" $ \a -> dualCompl a <> a :==: mzero
-   , law "complement" $ \a -> a <> dualCompl a :==: mzero
-   ]
-
-dualTrueFalse :: DualMonoid a => Law a
-dualTrueFalse = law "true-false" $ dualCompl mempty :==: mzero
-
-deMorgan :: DualMonoid a => Law a
-deMorgan = law "demorgan" $ \a b ->
-   dualCompl (a <> b) :==: dualCompl a >< dualCompl b
-
---------------------------------------------------------
--- And laws
-
-fromAndLaw :: Law (And a) -> Law a
-fromAndLaw = mapLaw And fromAnd
-
-fromOrLaw :: Law (Or a) -> Law a
-fromOrLaw = mapLaw Or fromOr
-
---------------------------------------------------------
--- Tests for Bool instance
-
-propsBoolean :: [Property]
-propsBoolean = map property (booleanLaws :: [Law Bool])
− src/Ideas/Common/Algebra/Field.hs 
@@ -1,233 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
---  $Id: Field.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.Field
-   ( -- * Semi-ring
-     SemiRing(..)
-     -- * Ring
-   , Ring(..)
-     -- * Field
-   , Field(..)
-     -- * Additive monoid
-   , Additive(..)
-     -- * Multiplicative monoid
-   , Multiplicative(..)
-     -- * Datatype for safe numeric operators
-   , SafeNum, safeNum
-     -- * CoSemiRing, CoRing, and CoField (for matching)
-   , CoSemiRing(..), CoRing(..), CoField(..)
-   ) where
-
-import Control.Monad
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Classes (mapBoth)
-import Test.QuickCheck
-import qualified Control.Applicative as A
-
---------------------------------------------------------
--- Semi-ring
-
-infixl 6 <+>
-infixl 7 <*>
-
-class SemiRing a where
-   -- additive
-   (<+>) :: a -> a -> a
-   zero  :: a
-   sum   :: [a] -> a
-   -- multiplicative
-   (<*>)   :: a -> a -> a
-   one     :: a
-   product :: [a] -> a
-   -- default implementation
-   sum     [] = zero
-   sum     xs = foldl1 (<+>) xs
-   product [] = one
-   product xs = foldl1 (<*>) xs
-
---------------------------------------------------------
--- Ring
-
-infixl 6 <->
-
--- Minimal complete definition: plusInverse or <->
-class SemiRing a => Ring a where
-   plusInverse :: a -> a
-   (<->)       :: a -> a -> a
-   -- default definitions
-   plusInverse = (zero <->)
-   a <-> b     = a <+> plusInverse b
-
---------------------------------------------------------
--- Field
-
-infixl 7 </>
-
--- Minimal complete definition: mulInverse or </>
-class Ring a => Field a where
-   timesInverse :: a -> a
-   (</>)        :: a -> a -> a
-   -- default definitions
-   timesInverse = (one </>)
-   a </> b      = a <*> timesInverse b
-
---------------------------------------------------------
--- Additive monoid
-
-newtype Additive a = Additive {fromAdditive :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor Additive where -- could be derived
-   fmap f = Additive . f . fromAdditive
-
-instance A.Applicative Additive where
-   pure = Additive
-   Additive f <*> Additive a = Additive (f a)
-
-instance SemiRing a => Monoid (Additive a) where
-   mempty  = A.pure zero
-   mappend = A.liftA2 (<+>)
-
-instance Ring a => Group (Additive a) where
-   inverse   = A.liftA plusInverse
-   appendInv = A.liftA2 (<->)
-
---------------------------------------------------------
--- Multiplicative monoid
-
-newtype Multiplicative a = Multiplicative {fromMultiplicative :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor Multiplicative where -- could be derived
-   fmap f = Multiplicative . f . fromMultiplicative
-
-instance A.Applicative Multiplicative where
-   pure = Multiplicative
-   Multiplicative f <*> Multiplicative a = Multiplicative (f a)
-
-instance SemiRing a => Monoid (Multiplicative a) where
-   mempty  = A.pure one
-   mappend = A.liftA2 (<*>)
-
-instance Field a => Group (Multiplicative a) where
-   inverse   = A.liftA timesInverse
-   appendInv = A.liftA2 (</>)
-
-instance SemiRing a => MonoidZero (Multiplicative a) where
-   mzero = Multiplicative zero
-
---------------------------------------------------------
--- Datatype for safe numeric operators
-
-data SafeNum a = Ok a | Exception String
-
-safeNum :: SafeNum a -> Either String a
-safeNum (Ok a)        = Right a
-safeNum (Exception s) = Left s
-
-instance Arbitrary a => Arbitrary (SafeNum a) where
-   arbitrary = liftM return arbitrary
-
-instance Eq a => Eq (SafeNum a) where
-   Ok a == Ok b = a == b
-   _    == _    = True
-
-instance Ord a => Ord (SafeNum a) where
-   Ok a `compare` Ok b = a `compare` b
-   _    `compare` _    = EQ
-
-instance Show a => Show (SafeNum a) where
-   show = either ("Exception: " ++) show . safeNum
-
-instance Functor SafeNum where
-   fmap f = either Exception (return . f) . safeNum
-
-instance Monad SafeNum where
-   return  = Ok
-   fail    = Exception
-   m >>= f = either Exception f (safeNum m)
-
-instance Num a => Num (SafeNum a) where
-   (+) = liftM2 (+)
-   (*) = liftM2 (*)
-   (-) = liftM2 (-)
-   negate = liftM negate
-   abs    = liftM abs
-   signum = liftM signum
-   fromInteger = return . fromInteger
-
-instance (Eq a, Fractional a) => Fractional (SafeNum a) where
-   a / b = liftM2 (/) a (safeDivisor b)
-   recip = liftM recip . safeDivisor
-   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 ->
-   if a == 0 then fail "division by zero" else return a
-
-------------------------------------------------------------
-
-class CoSemiRing a where
-   -- additive
-   isPlus  :: a -> Maybe (a, a)
-   isZero  :: a -> Bool
-   -- multiplicative
-   isTimes :: a -> Maybe (a, a)
-   isOne   :: a -> Bool
-
--- Minimal complete definition: plusInverse or <->
-class CoSemiRing a => CoRing a where
-   isNegate :: a -> Maybe a
-   isMinus  :: a -> Maybe (a, a)
-   -- default definition
-   isMinus _ = Nothing
-
-class CoRing a => CoField a where
-   isRecip    :: a -> Maybe a
-   isDivision :: a -> Maybe (a, a)
-   -- default definition
-   isDivision _ = Nothing
-
-instance CoSemiRing a => CoMonoid (Additive a) where
-   isEmpty  = isZero . fromAdditive
-   isAppend = fmap (mapBoth Additive) . isPlus . fromAdditive
-
-instance CoRing a => CoGroup (Additive a) where
-   isInverse   = fmap Additive . isNegate . fromAdditive
-   isAppendInv = fmap (mapBoth Additive) . isMinus . fromAdditive
-
-instance CoSemiRing a => CoMonoid (Multiplicative a) where
-   isEmpty  = isOne . fromMultiplicative
-   isAppend = fmap (mapBoth Multiplicative) . isTimes . fromMultiplicative
-
-instance CoField a => CoGroup (Multiplicative a) where
-   isInverse   = fmap Multiplicative . isRecip . fromMultiplicative
-   isAppendInv = fmap (mapBoth Multiplicative) . isDivision . fromMultiplicative
-
-instance CoSemiRing a => CoMonoidZero (Multiplicative a) where
-   isMonoidZero = isZero . fromMultiplicative
− src/Ideas/Common/Algebra/FieldLaws.hs 
@@ -1,112 +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)
---
------------------------------------------------------------------------------
---  $Id: FieldLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.FieldLaws
-   ( -- * Semi-ring laws
-     leftDistributive, rightDistributive
-   , distributiveLaws, semiRingLaws
-     -- * Ring laws
-   , leftNegateTimes, rightNegateTimes
-   , negateTimesLaws, ringLaws, commutativeRingLaws
-   , distributiveSubtractionLaws
-     -- * Field laws
-   , exchangeInverses, fieldLaws
-     -- * Laws for additive monoid
-   , fromAdditiveLaw
-     -- * Laws for multiplicative monoid
-   , fromMultiplicativeLaw
-     -- * Properties
-   , propsField
-   ) where
-
-import Ideas.Common.Algebra.Field
-import Ideas.Common.Algebra.GroupLaws
-import Ideas.Common.Algebra.Law
-import Test.QuickCheck
-
---------------------------------------------------------
--- Semi-ring laws
-
-leftDistributive :: SemiRing a => Law a
-leftDistributive = leftDistributiveFor (<*>) (<+>)
-
-rightDistributive :: SemiRing a => Law a
-rightDistributive = rightDistributiveFor (<*>) (<+>)
-
-distributiveLaws :: SemiRing a => [Law a]
-distributiveLaws = [leftDistributive, rightDistributive]
-
-semiRingLaws :: SemiRing a => [Law a]
-semiRingLaws =
-   map fromAdditiveLaw commutativeMonoidLaws ++
-   map fromMultiplicativeLaw monoidZeroLaws ++
-   distributiveLaws
-
---------------------------------------------------------
--- Ring laws
-
-leftNegateTimes :: Ring a => Law a
-leftNegateTimes = law "left-negate-times" $ \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)
-
-negateTimesLaws :: Ring a => [Law a]
-negateTimesLaws = [leftNegateTimes, rightNegateTimes]
-
-ringLaws :: Ring a => [Law a]
-ringLaws =
-   map fromAdditiveLaw abelianGroupLaws ++
-   map fromMultiplicativeLaw monoidZeroLaws ++
-   distributiveLaws ++ negateTimesLaws
-
-commutativeRingLaws :: Ring a => [Law a]
-commutativeRingLaws =
-   fromMultiplicativeLaw commutative : ringLaws
-
-distributiveSubtractionLaws :: Ring a => [Law a]
-distributiveSubtractionLaws =
-   [leftDistributiveFor (<*>) (<->), rightDistributiveFor (<*>) (<->)]
-
---------------------------------------------------------
--- Field laws
-
-exchangeInverses :: Field a => Law a
-exchangeInverses = law "exchange-inverses" $ \a ->
-   timesInverse (plusInverse a) :==: plusInverse (timesInverse a)
-
-fieldLaws :: Field a => [Law a]
-fieldLaws =
-   map fromAdditiveLaw abelianGroupLaws ++
-   map fromMultiplicativeLaw abelianGroupLaws ++
-   distributiveLaws ++ negateTimesLaws ++ [exchangeInverses]
-
---------------------------------------------------------
--- Laws for additive monoid
-
-fromAdditiveLaw :: Law (Additive a) -> Law a
-fromAdditiveLaw = mapLaw Additive fromAdditive
-
---------------------------------------------------------
--- Laws for multiplicative monoid
-
-fromMultiplicativeLaw :: Law (Multiplicative a) -> Law a
-fromMultiplicativeLaw = mapLaw Multiplicative fromMultiplicative
-
---------------------------------------------------------
--- Properties
-
-propsField :: [Property]
-propsField = map property (fieldLaws :: [Law (SafeNum Rational)])
− src/Ideas/Common/Algebra/Group.hs 
@@ -1,199 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
---  $Id: Group.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.Group
-   ( -- * Monoids
-     Monoid(..), (<>)
-     -- * Groups
-   , Group(..), (<>-)
-     -- * Monoids with a zero element
-   , MonoidZero(..), WithZero, fromWithZero
-     -- * CoMonoid, CoGroup, and CoMonoidZero (for matching)
-   , CoMonoid(..), CoGroup(..), CoMonoidZero(..)
-   , associativeList
-   ) where
-
-import Control.Applicative
-import Control.Monad (liftM2)
-import Data.Foldable (Foldable)
-import Data.Maybe
-import Data.Monoid
-import Data.Traversable (Traversable, traverse)
-import Ideas.Common.Classes
-import qualified Data.Set as S
-
---------------------------------------------------------
--- Groups
-
--- | Minimal complete definition: inverse or appendInverse
-class Monoid a => Group a where
-   inverse   :: a -> a
-   appendInv :: a -> a -> a
-   -- default definitions
-   inverse = (mempty <>-)
-   appendInv a b = a <> inverse b
-
-infixl 6 <>-
-
-(<>-) :: Group a => a -> a -> a
-(<>-) = appendInv
-
---------------------------------------------------------
--- Monoids with a zero element
--- This element could be the additive identity from a (semi-)ring for
--- the multiplicative monoid
-
-class Monoid a => MonoidZero a where
-   mzero :: a
-
--- Type that adds a zero element
-newtype WithZero a = WZ { fromWithZero :: Maybe a }
-   deriving (Eq, Ord, Functor, Foldable, Applicative)
-
-instance Monoid a => Monoid (WithZero a) where
-   mempty = WZ (Just mempty)
-   mappend x y = WZ (liftM2 mappend (fromWithZero x) (fromWithZero y))
-
-instance Monoid a => MonoidZero (WithZero a) where
-   mzero = WZ Nothing
-
-instance Traversable WithZero where
-   traverse f = liftA WZ . traverse f . fromWithZero
-
---------------------------------------------------------
--- Groups
-
-class CoMonoid a where
-   isEmpty  :: a -> Bool
-   isAppend :: a -> Maybe (a, a)
-
-class CoMonoid a => CoGroup a where
-   isInverse   :: a -> Maybe a
-   isAppendInv :: a -> Maybe (a, a)
-   -- default definition
-   isAppendInv = const Nothing
-
-class CoMonoid a => CoMonoidZero a where
-   isMonoidZero :: a -> Bool
-
-fromSemiGroup :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b
-fromSemiGroup f = rec
- where
-   rec a = maybe (f a) make (isAppend a)
-   make (x, y) = rec x <> rec y
-{-
-fromMonoid :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b
-fromMonoid f = fromSemiGroup $ \a ->
-   if isEmpty a then mempty else f a
-
-fromGroup :: (CoGroup a, Group b) => (a -> b) -> a -> b
-fromGroup f = rec
- where
-   rec = fromMonoid $ \a ->
-      case isInverse a of
-         Just x  -> inverse (rec x)
-         Nothing ->
-            case isAppendInverse a of
-               Just (x, y) -> rec x <>- rec y
-               Nothing     -> f a
-
-fromMonoidZero :: (CoMonoidZero a, MonoidZero b) => (a -> b) -> a -> b
-fromMonoidZero f = fromMonoid $ \a ->
-   if isZero a then zero else f a
-
-----------------------
--}
-associativeList :: CoMonoid a => a -> [a]
-associativeList = fromSemiGroup singleton
-{-
-monoidList :: CoMonoid a => a -> [a]
-monoidList = fromMonoid singleton
-
--- For commutative (and associative) monoids
-monoidMultiSet :: (CoMonoid a, Ord a) => a -> MultiSet a
-monoidMultiSet = fromMonoid singleton
-
--- For associative, commutative, idempotent (ACI) monoids
-monoidSet :: (CoMonoid a, Ord a) => a -> S.Set a
-monoidSet = fromMonoid singleton
-
-groupSequence :: (CoGroup a, Eq a) => a -> GroupSequence a
-groupSequence = fromGroup singleton
-
-abelianMultiSet :: (CoGroup a, Ord a) => a -> MultiSet a
-abelianMultiSet = fromGroup singleton
-
-monoidZeroList :: CoMonoidZero a => a -> WithZero [a]
-monoidZeroList = fromMonoidZero (pure . singleton)
-
-----------------------
-
-newtype MultiSet a = MS (M.Map a Int)
-
-instance Collection MultiSet where
-   singleton a = MS (M.singleton a 1)
-
-instance Ord a => Monoid (MultiSet a) where
-   mempty  = MS mempty
-   mappend (MS m1) (MS m2) = MS (M.unionWith (+) m1 m2)
-
-instance Ord a => Group (MultiSet a) where
-   inverse (MS m) = MS (fmap negate m)
-
-----------------------
-
-newtype GroupSequence a = GS (Q.Seq (a, Bool))
-
-instance Collection GroupSequence where
-   singleton a = GS (Q.singleton (a, False))
-
-instance Eq a => Monoid (GroupSequence a) where
-   mempty = GS mempty
-   mappend (GS xs) (GS ys) =
-      case (Q.viewr xs, Q.viewl ys) of
-         (as Q.:> (a, ai), (b, bi) Q.:< bs) | a == b && ai /= bi ->
-            mappend (GS as) (GS bs)
-         _ -> GS (xs <> ys)
-
-instance Eq a => Group (GroupSequence a) where
-   inverse (GS xs) = GS (fmap (second not) xs) -- actually: reverse order!!
--}
-----------------------
-
-instance CoMonoid [a] where
-   isEmpty = null
-   isAppend (x:xs@(_:_)) = Just ([x], xs)
-   isAppend _            = Nothing
-
-instance CoMonoid (S.Set a) where
-   isEmpty = S.null
-   isAppend s
-      | S.size s > 1 = Just (mapFirst S.singleton (S.deleteFindMin s))
-      | otherwise    = Nothing
-
-{-
-instance CoMonoid (Q.Seq a) where
-   isEmpty = Q.null
-   isAppend xs
-      | n > 1     = Just (Q.splitAt (n `div` 2) xs)
-      | otherwise = Nothing
-    where
-      n = Q.length xs
--}
-instance CoMonoid a => CoMonoid (WithZero a) where
-   isEmpty    = maybe False isEmpty . fromWithZero
-   isAppend a = fromWithZero a >>= fmap (mapBoth pure) . isAppend
-
-instance CoMonoid a => CoMonoidZero (WithZero a) where
-   isMonoidZero = isNothing . fromWithZero
− src/Ideas/Common/Algebra/GroupLaws.hs 
@@ -1,151 +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)
---
------------------------------------------------------------------------------
---  $Id: GroupLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.GroupLaws
-   ( -- * Monoid laws
-     associative, leftIdentity
-   , rightIdentity, identityLaws, monoidLaws, commutativeMonoidLaws
-   , idempotent
-     -- * Group laws
-   , leftInverse, rightInverse, doubleInverse
-   , inverseIdentity, inverseDistrFlipped, inverseLaws, groupLaws
-   , appendInverseLaws
-     -- * Abelian group laws
-   , commutative, inverseDistr, abelianGroupLaws
-     -- * Laws for monoids with a zero element
-   , leftZero, rightZero, zeroLaws, monoidZeroLaws
-     -- * Generalized laws
-   , associativeFor, commutativeFor, idempotentFor
-   , leftDistributiveFor, rightDistributiveFor
-   ) where
-
-import Data.Monoid
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Algebra.Law
-
---------------------------------------------------------
--- Monoids
-
-associative :: Monoid a => Law a
-associative = associativeFor (<>)
-
-leftIdentity :: Monoid a => Law a
-leftIdentity = law "left-identity" $ \a -> mempty <> a :==: a
-
-rightIdentity :: Monoid a => Law a
-rightIdentity = law "right-identity" $ \a -> a <> mempty :==: a
-
-identityLaws :: Monoid a => [Law a]
-identityLaws = [leftIdentity, rightIdentity]
-
-monoidLaws :: Monoid a => [Law a]
-monoidLaws = associative : identityLaws
-
-commutativeMonoidLaws :: Monoid a => [Law a]
-commutativeMonoidLaws = monoidLaws ++ [commutative]
-
--- | Not all monoids are idempotent (see: idempotentFor)
-idempotent :: Monoid a => Law a
-idempotent = idempotentFor (<>)
-
---------------------------------------------------------
--- Groups
-
-leftInverse :: Group a => Law a
-leftInverse = law "left-inverse" $ \a -> inverse a <> a :==: mempty
-
-rightInverse :: Group a => Law a
-rightInverse = law "right-inverse" $ \a -> a <> inverse a :==: mempty
-
-doubleInverse :: Group a => Law a
-doubleInverse = law "double-inverse" $ \a -> inverse (inverse a) :==: a
-
-inverseIdentity :: Group a => Law a
-inverseIdentity = law "inverse-identity" $ inverse mempty :==: mempty
-
-inverseDistrFlipped :: Group a => Law a
-inverseDistrFlipped = law "inverse-distr-flipped" $ \a b ->
-   inverse (a <> b) :==: inverse b <> inverse a
-
-inverseLaws :: Group a => [Law a]
-inverseLaws = [leftInverse, rightInverse]
-
-groupLaws :: Group a => [Law a]
-groupLaws = monoidLaws ++ inverseLaws ++
-   [doubleInverse, inverseIdentity, inverseDistrFlipped]
-
-appendInverseLaws :: Group a => [Law a]
-appendInverseLaws =
-   [ make 1 $ \a b   ->           a <>- b :==: a <> inverse b
-   , make 2 $ \a     ->           a <>- a :==: mempty
-   , make 3 $ \a     ->      a <>- mempty :==: a
-   , make 4 $ \a     ->      mempty <>- a :==: inverse a
-   , make 5 $ \a b c ->    a <>- (b <> c) :==: (a <>- b) <>- c
-   , make 6 $ \a b c ->   a <>- (b <>- c) :==: (a <>- b) <> c
-   , make 7 $ \a b c ->    a <> (b <>- c) :==: (a <> b) <>- c
-   , make 8 $ \a b   ->   a <>- inverse b :==: a <> b
-   , make 9 $ \a b   -> inverse (a <>- b) :==: inverse a <> b
-   ]
- where
-    make n = law ("append-inverse-law" ++ show (n :: Int))
-
---------------------------------------------------------
--- Abelian groups
-
-commutative :: Monoid a => Law a
-commutative = commutativeFor (<>)
-
-inverseDistr :: Group a => Law a
-inverseDistr = law "inverse-distr" $ \a b ->
-    inverse (a <> b) :==: (inverse a <> inverse b)
-
-abelianGroupLaws :: Group a => [Law a]
-abelianGroupLaws = groupLaws ++ [commutative, inverseDistr]
-
---------------------------------------------------------
--- Monoids with a zero element
--- This element could be the additive identity from a (semi-)ring for
--- the multiplicative monoid
-
-leftZero :: MonoidZero a => Law a
-leftZero = law "left-zero" $ \a -> mzero <> a :==: mzero
-
-rightZero:: MonoidZero a => Law a
-rightZero = law "right-zero" $ \a -> a <> mzero :==: mzero
-
-zeroLaws :: MonoidZero a => [Law a]
-zeroLaws = [leftZero, rightZero]
-
-monoidZeroLaws :: MonoidZero a => [Law a]
-monoidZeroLaws = monoidLaws ++ zeroLaws
-
---------------------------------------------------------
--- Generalized laws
-
-associativeFor :: (a -> a -> a) -> Law a
-associativeFor (?) = law "associative" $ \a b c ->
-   a ? (b ? c) :==: (a ? b) ? c
-
-commutativeFor :: (a -> a -> a) -> Law a
-commutativeFor (?) = law "commutative" $ \a b -> a ? b :==: b ? a
-
-idempotentFor :: (a -> a -> a) -> Law a
-idempotentFor (?) = law "idempotent" $ \a -> a ? a :==: a
-
-leftDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a
-leftDistributiveFor (<*>) (<+>) = law "left-distributive" $ \a b c ->
-   a <*> (b <+> c) :==: (a <*> b) <+> (a <*> c)
-
-rightDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a
-rightDistributiveFor (<*>) (<+>) = law "right-distributive" $ \a b c ->
-   (a <+> b) <*> c :==: (a <*> c) <+> (b <*> c)
− src/Ideas/Common/Algebra/Law.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
------------------------------------------------------------------------------
--- 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)
---
------------------------------------------------------------------------------
---  $Id: Law.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.Law
-   ( Law, LawSpec((:==:)), law, mapLaw
-   , propertyLaw, rewriteLaw
-   ) where
-
-import Ideas.Common.Rewriting
-import Test.QuickCheck
-
-infix 1 :==:
-
-data Law a = Law String (LawSpec a)
-
-instance Show (Law a) where
-   show (Law s _) = s
-
-data LawSpec a = Abs (a -> LawSpec a) | a :==: a
-
-law :: LawBuilder l a => String -> l -> Law a
-law s l = Law s (lawSpec l)
-
-class LawBuilder l a | l -> a where
-   lawSpec :: l -> LawSpec a
-
-instance LawBuilder (LawSpec a) a where
-   lawSpec = id
-
-instance LawBuilder b a => LawBuilder (a -> b) a where
-   lawSpec f = Abs (lawSpec . f)
-
-instance (Show a, Eq a, Arbitrary a) => Testable (Law a) where
-   property = propertyLaw (==)
-
-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
-
-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)
-
-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
-
-getLawSpec :: Law a -> LawSpec a
-getLawSpec (Law _ l) = l
− src/Ideas/Common/Algebra/SmartGroup.hs 
@@ -1,200 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
---  $Id: SmartGroup.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Algebra.SmartGroup
-   ( -- * Smart datatypes
-     Smart(..), SmartZero(..), SmartGroup(..)
-     --- * Smart field
-   , SmartField(..), (.+.), (.-.), neg, (.*.), (./.)
-     -- * Smart booleans
-   , (.&&.), (.||.)
-   ) where
-
-import Control.Applicative
-import Control.Monad (mplus)
-import Data.Maybe
-import Ideas.Common.Algebra.Boolean
-import Ideas.Common.Algebra.Field hiding ((<*>))
-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)
-
-instance Functor Smart where -- could be derived
-   fmap f = Smart . f . fromSmart
-
-instance Applicative Smart where
-   pure = Smart
-   Smart f <*> Smart a = Smart (f a)
-
-instance (CoMonoid a, Monoid a) => Monoid (Smart a) where
-   mempty = Smart mempty
-   mappend a b
-      | isEmpty a = b
-      | isEmpty b = a
-      | otherwise = liftA2 (<>) a b
-
---------------------------------------------------------------
-
-newtype SmartZero a = SmartZero {fromSmartZero :: a}
-   deriving (Show, Eq, Ord, MonoidZero, CoMonoid, CoMonoidZero)
-
-instance Functor SmartZero where -- could be derived
-   fmap f = SmartZero . f . fromSmartZero
-
-instance Applicative SmartZero where
-   pure = SmartZero
-   SmartZero f <*> SmartZero a = SmartZero (f a)
-
-instance (CoMonoidZero a, MonoidZero a) => Monoid (SmartZero a) where
-   mempty = SmartZero mempty
-   mappend a b
-      | isMonoidZero a || isMonoidZero b = mzero
-      | otherwise = liftA2 (<>) a b
-
---------------------------------------------------------------
-
-newtype SmartGroup a = SmartGroup {fromSmartGroup :: a}
-   deriving (Show, Eq, Ord, CoMonoid, CoGroup, CoMonoidZero, MonoidZero)
-
-instance Functor SmartGroup where -- could be derived
-   fmap f = SmartGroup . f . fromSmartGroup
-
-instance Applicative SmartGroup where
-   pure = SmartGroup
-   SmartGroup f <*> SmartGroup a = SmartGroup (f a)
-
-instance (CoGroup a, Group a) => Monoid (SmartGroup a) where
-   mempty  = SmartGroup mempty
-   mappend a b
-      | isEmpty a = b
-      | otherwise = fromMaybe (liftA2 (<>) a b) (matchGroup alg b)
-    where
-      alg = (a, \x y -> (a <> x) <> y, \x -> a <>- x, \x y -> (a <> x) <>- y)
-
-instance (CoGroup a, Group a) => Group (SmartGroup a) where
-   inverse a = fromMaybe (liftA inverse a) (matchGroup alg a)
-    where
-      alg = (mempty, \x y -> inverse x <>- y, id, \x y -> inverse x <> y)
-   appendInv a b
-      | isEmpty a = inverse b
-      | otherwise = fromMaybe (liftA2 (<>-) a b) (matchGroup alg b)
-    where
-      alg = (a, \x y -> (a <>- x) <>- y, \x -> a <> x, \x y -> (a <>- x) <> y)
-
---------------------------------------------------------------
-
-type GroupMatch a b = (b, a -> a -> b, a -> b, a -> a -> b)
-
-matchGroup :: CoGroup a => GroupMatch a b -> a -> Maybe b
-matchGroup (emp, app, inv, appinv) a =
-   (if isEmpty a then Just emp else Nothing) `mplus`
-   fmap (uncurry app) (isAppend a)  `mplus`
-   fmap inv (isInverse a) `mplus`
-   fmap (uncurry appinv) (isAppendInv a)
-
---------------------------------------------------------------
--- Smart Field
-
-newtype SmartField a = SmartField {fromSmartField :: a}
-   deriving (CoSemiRing, CoRing, CoField)
-
-instance Functor SmartField where -- could be derived
-   fmap f = SmartField . f . fromSmartField
-
-instance Applicative SmartField where
-   pure = SmartField
-   SmartField f <*> SmartField a = SmartField (f a)
-
-instance (CoField a, Field a) => SemiRing (SmartField a) where
-   zero = SmartField zero
-   one  = SmartField one
-   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)
-      | 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
-
-instance (CoField a, Field a) => Ring (SmartField a) where
-   plusInverse = SmartField . fromAdditive . fromSmartGroup . inverse
-               . SmartGroup . Additive . fromSmartField
-   SmartField a <-> SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
-      SmartGroup (Additive a) <>- SmartGroup (Additive b)
-
-instance (CoField a, Field a) => Field (SmartField a) where
-   timesInverse a
-      | 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)
-      | isOne b = a
-      | Just (x, y) <- isDivision a = x </> (y Field.<*> b)
-      | otherwise = liftA2 (</>) a b
-
-------------------------------------------------------------------
-
-infixl 7 .*., ./.
-infixl 6 .-., .+.
-
-(.+.) :: (CoField a, Field a) => a -> a -> a
-a .+. b = fromSmartField $ SmartField a <+> SmartField b
-
-(.-.) :: (CoField a, Field a) => a -> a -> a
-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
-
-(./.) :: (CoField a, Field a) => a -> a -> a
-a ./. b = fromSmartField $ SmartField a </> SmartField b
-
--- myrecip :: (CoField a, Field a) => a -> a
--- myrecip = fromSmartField . timesInverse . SmartField
-
---------------------------------------------------------------
--- Smart booleans
-
-instance BoolValue a => BoolValue (Smart a) where
-   fromBool = Smart   . fromBool
-   isTrue   = isTrue  . fromSmart
-   isFalse  = isFalse . fromSmart
-
-instance (Boolean a, CoBoolean a) => Boolean (Smart a) where
-   a <&&> b = fmap fromAnd $ fromSmartZero $
-      SmartZero (fmap And a) <> SmartZero (fmap And b)
-   a <||> b = fmap fromOr $ fromSmartZero $
-      SmartZero (fmap Or a) <> SmartZero (fmap Or b)
-   complement (Smart a)
-      | isTrue  a = false
-      | isFalse a = true
-      | otherwise = Smart $ fromMaybe (complement a) (isComplement a)
-
-infixr 4 .||.
-infixr 5 .&&.
-
-(.&&.), (.||.) :: (Boolean a, CoBoolean a) => a -> a -> a
-a .&&. b = fromSmart $ Smart a <&&> Smart b
-a .||. b = fromSmart $ Smart a <||> Smart b
src/Ideas/Common/Classes.hs view
@@ -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 2019, 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,21 @@ -- Type classes and instances.
 --
 -----------------------------------------------------------------------------
---  $Id: Classes.hs 7524 2015-04-08 07:31:15Z 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(..)
+     -- * Boolean Algebra
+   , BoolValue(..), Boolean(..)
+   , ands, ors, implies, equivalent
      -- * Buggy and Minor properties
    , Buggy(..), Minor(..)
    ) where
@@ -111,6 +115,68 @@ 
 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
+
+--------------------------------------------------------
+-- Boolean algebra
+
+-- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse
+class BoolValue a where
+   true     :: a
+   false    :: a
+   fromBool :: Bool -> a
+   isTrue   :: a -> Bool
+   isFalse  :: a -> Bool
+   -- default definitions
+   true  = fromBool True
+   false = fromBool False
+   fromBool b = if b then true else false
+
+class BoolValue a => Boolean a where
+   (<&&>)     :: a -> a -> a
+   (<||>)     :: a -> a -> a
+   complement :: a -> a
+
+instance BoolValue Bool where
+   fromBool = id
+   isTrue   = id
+   isFalse  = not
+
+instance BoolValue b => BoolValue (a -> b) where
+   fromBool x = const (fromBool x)
+   isTrue  = error "not implemented"
+   isFalse = error "not implemented"
+
+instance Boolean Bool where
+   (<&&>)     = (&&)
+   (<||>)     = (||)
+   complement = not
+
+instance Boolean b => Boolean (a -> b) where
+   f <&&> g   = \x -> f x <&&> g x
+   f <||> g   = \x -> f x <||> g x
+   complement = (.) complement
+
+ands :: Boolean a => [a] -> a -- or use mconcat with And monoid
+ands xs | null xs   = true
+        | otherwise = foldr1 (<&&>) xs
+
+ors :: Boolean a => [a] -> a
+ors xs | null xs   = false
+       | otherwise = foldr1 (<||>) xs
+
+implies :: Boolean a => a -> a -> a
+implies a b = complement a <||> b
+
+equivalent :: Boolean a => a -> a -> a
+equivalent a b = (a <&&> b) <||> (complement a <&&> complement b)
 
 -----------------------------------------------------------
 -- Buggy and Minor properties
+ src/Ideas/Common/Constraint.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Constraints for constraint-based tutors
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Constraint
+  ( Constraint, makeConstraint
+  , isRelevant, isSatisfied, isViolated, getResult
+  , Result(..), relevance
+  ) where
+
+import Control.Applicative
+import Control.Monad
+import Ideas.Common.Id
+import Ideas.Common.View
+
+---------------------------------------------------------------------------
+-- Constraint
+
+data Constraint a = C
+  { constraintId :: Id
+  , getResult    :: a -> Result ()
+  }
+
+instance Show (Constraint a) where
+  show = showId
+
+instance Eq (Constraint a) where
+  r1 == r2 = constraintId r1 == constraintId r2
+
+instance Ord (Constraint a) where
+  compare = compareId
+
+instance HasId (Constraint a) where
+  getId        = constraintId
+  changeId f r = r { constraintId = f (constraintId r) }
+
+instance LiftView Constraint where
+   liftViewIn v (C n f) = C n (maybe Irrelevant (f . fst) . match v)
+
+makeConstraint :: IsId n => n -> (a -> Result ()) -> Constraint a
+makeConstraint = C . newId
+
+--  | Relevance condition
+isRelevant :: Constraint a -> a -> Bool
+isRelevant p a =
+   case getResult p a of
+      Irrelevant -> False
+      _          -> True
+
+-- | Satisfaction condition
+isSatisfied :: Constraint a -> a -> Bool
+isSatisfied p a =
+   case getResult p a of
+      Ok _ -> True
+      _    -> False
+
+-- | Satisfaction condition
+isViolated :: Constraint a -> a -> Maybe String
+isViolated p a =
+   case getResult p a of
+      Error s -> Just s
+      _       -> Nothing
+
+---------------------------------------------------------------------------
+-- Result
+
+data Result a = Irrelevant | Error String | Ok a
+   deriving Show
+
+instance Functor Result where
+   fmap _ Irrelevant  = Irrelevant
+   fmap _ (Error msg) = Error msg
+   fmap f (Ok a)      = Ok (f a)
+
+instance Applicative Result where
+   pure = Ok
+   Irrelevant <*> _          = Irrelevant
+   Error msg  <*> _          = Error msg
+   Ok _       <*> Irrelevant = Irrelevant
+   Ok _       <*> Error msg  = Error msg
+   Ok f       <*> Ok a       = Ok (f a)
+
+instance Alternative Result where
+   empty = Error ""
+   Irrelevant <|> r       = r
+   Error msg  <|> Error _ = Error msg -- left-biased
+   Error _    <|> r       = r
+   Ok a       <|> _       = Ok a
+
+instance Monad Result where
+   return = Ok
+   fail   = Error
+   Irrelevant >>= _ = Irrelevant
+   Error msg  >>= _ = Error msg
+   Ok a       >>= f = f a
+
+instance MonadPlus Result where
+   mzero = empty
+   mplus = (<|>)
+
+-- | Turn errors into irrelevant results
+relevance :: Result a -> Result a
+relevance (Error _) = Irrelevant
+relevance r = r
src/Ideas/Common/Context.hs view
@@ -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 2019, 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,6 @@ -- the 'Navigator' type class (for traversing the term).
 --
 -----------------------------------------------------------------------------
---  $Id: Context.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Context
    ( -- * Abstract data type
@@ -30,20 +29,19 @@    , currentTerm, changeTerm, replaceInContext, currentInContext, changeInContext
    ) where
 
-import Control.Monad
 import Data.Maybe
 import Ideas.Common.Environment
 import Ideas.Common.Id
 import Ideas.Common.Rewriting
 import Ideas.Common.Traversal.Navigator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.Uniplate
 import Ideas.Common.View hiding (left, right)
+import Ideas.Utils.Uniplate
 
 ----------------------------------------------------------
 -- Abstract data type
 
--- | Abstract data type for a context: a context stores an envrionent.
+-- | Abstract data type for a context: a context stores an environment.
 data Context a = C
    { getEnvironment :: Environment
    , getNavigator   :: ContextNavigator a
@@ -54,19 +52,19 @@    currentNavigator . getNavigator . top
 
 fromContextWith :: Monad m => (a -> b) -> Context a -> m b
-fromContextWith f = liftM f . fromContext
+fromContextWith f = fmap f . fromContext
 
 fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c
-fromContextWith2 f a b = liftM2 f (fromContext a) (fromContext b)
+fromContextWith2 f a b = f <$> fromContext a <*> fromContext b
 
 instance Eq a => Eq (Context a) where
-   x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y)
+   x == y = fromMaybe False $ (==) <$> fromContext x <*> fromContext y
 
 instance Show a => Show (Context a) where
    show c@(C env a) =
       let rest | noBindings env = ""
                | otherwise      = "  {" ++ show env ++ "}"
-      in maybe "??" show (currentNavigator a) ++
+      in maybe (maybe "??" show (currentT a)) show (currentNavigator a) ++
          " @ " ++ show (location c) ++ rest
 
 instance Navigator (Context a) where
@@ -104,8 +102,8 @@ 
 liftCN :: Monad m => (forall b . Navigator b => b -> m b)
                   -> Context a -> m (Context a)
-liftCN f (C env (TermNav a)) = liftM (C env . TermNav) (f a)
-liftCN f (C env (Simple a))  = liftM (C env . Simple)  (f a)
+liftCN f (C env (TermNav a)) = C env . TermNav <$> f a
+liftCN f (C env (Simple a))  = C env . Simple  <$> f a
 liftCN _ (C _   (NoNav _))   = fail "noNavigator"
 
 navLocation :: ContextNavigator a -> Location
@@ -128,7 +126,7 @@ currentT _           = Nothing
 
 changeT :: (Term -> Maybe Term) -> ContextNavigator a -> Maybe (ContextNavigator a)
-changeT f (TermNav a) = fmap TermNav (changeM f a)
+changeT f (TermNav a) = TermNav <$> changeM f a
 changeT _ _           = Nothing
 
 castT :: IsTerm b => ContextNavigator a -> Maybe (ContextNavigator b)
@@ -161,7 +159,7 @@ useC = liftViewIn (makeView f g)
  where
    f old@(C env a) = castT a >>= \b -> return (C env b, old)
-   g (C env a, old) = fromMaybe old (liftM (C env) (castT a))
+   g (C env a, old) = maybe old (C env) (castT a)
 
 currentTerm :: Context a -> Maybe Term
 currentTerm = currentT . getNavigator
src/Ideas/Common/Derivation.hs view
@@ -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 2019, 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,21 +12,25 @@ -- and the steps)
 --
 -----------------------------------------------------------------------------
---  $Id: Derivation.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Derivation
    ( -- * Data type
      Derivation
      -- * Constructing a derivation
    , emptyDerivation, prepend, extend
+   , merge, mergeBy, mergeStep
+     -- * Conversion to/from list
+   , derivationToList, derivationFromList
      -- * Querying a derivation
    , isEmpty, derivationLength, terms, steps, triples
    , firstTerm, lastTerm, lastStep, withoutLast
-   , updateSteps, derivationM
+   , updateSteps, derivationM, splitStep
    ) where
 
 import Data.Maybe
+import Data.Monoid
 import Ideas.Common.Classes
+import Ideas.Common.Rewriting
 import qualified Data.Foldable as F
 import qualified Data.Sequence as S
 
@@ -34,6 +38,7 @@ -- Data type definition and instances
 
 data Derivation s a = D a (S.Seq (s, a))
+   deriving Eq
 
 instance (Show s, Show a) => Show (Derivation s a) where
    show (D a xs) = unlines $
@@ -45,6 +50,11 @@ instance BiFunctor Derivation where
    biMap f g (D a xs) = D (g a) (fmap (biMap f g) xs)
 
+instance (IsTerm s, IsTerm a) => IsTerm (Derivation s a) where
+   toTerm = TList . derivationToList toTerm toTerm
+   fromTerm (TList xs) = derivationFromList fromTerm fromTerm xs
+   fromTerm _ = fail "not a derivation"
+
 -----------------------------------------------------------------------------
 -- Constructing a derivation
 
@@ -57,7 +67,32 @@ extend :: Derivation s a -> (s, a) -> Derivation s a
 extend (D a xs) p = D a (xs S.|> p)
 
+merge :: Eq a => Derivation s a -> Derivation s a -> Maybe (Derivation s a)
+merge = mergeBy (==)
+
+mergeBy :: (a -> a -> Bool) -> Derivation s a -> Derivation s a -> Maybe (Derivation s a)
+mergeBy eq d@(D a xs) (D b ys)
+   | eq (lastTerm d) b = Just $ D a (xs <> ys)
+   | otherwise = Nothing
+
+mergeStep :: Derivation s a -> s -> Derivation s a -> Derivation s a
+mergeStep (D a xs) s (D b ys) = D a (xs <> ((s, b) S.<| ys))
+
 -----------------------------------------------------------------------------
+-- Conversion to/from list
+
+derivationToList :: (s -> b) -> (a -> b) -> Derivation s a -> [b]
+derivationToList f g d =
+   g (firstTerm d) : concat [ [f s, g a] | (_, s, a) <- triples d ]
+
+derivationFromList :: Monad m => (b -> m s) -> (b -> m a) -> [b] -> m (Derivation s a)
+derivationFromList f g = rec
+ where
+   rec []  = fail "derivationFromList"
+   rec [b] = emptyDerivation <$> g b
+   rec (b1:b2:bs) = curry prepend <$> g b1 <*> f b2 <*> rec bs
+
+-----------------------------------------------------------------------------
 -- Querying a derivation
 
 -- | Tests whether the derivation is empty
@@ -104,4 +139,12 @@ 
 -- | Apply a monadic function to each term, and to each step
 derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m ()
-derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs)+derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs)
+
+splitStep :: (s -> Bool) -> Derivation s a -> Maybe (Derivation s a, s, Derivation s a)
+splitStep p (D a xs) =
+   case S.viewl xs2 of
+      S.EmptyL -> Nothing
+      (s, b) S.:< ys -> Just (D a xs1, s, D b ys)
+ where
+   (xs1, xs2) = S.breakl (p . fst) xs
src/Ideas/Common/DerivationTree.hs view
@@ -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 2019, 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,6 @@ -- intermediate results as well as annotations for the steps.
 --
 -----------------------------------------------------------------------------
---  $Id: DerivationTree.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.DerivationTree
    ( -- * Data types
src/Ideas/Common/Environment.hs view
@@ -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 2019, 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,10 @@ -- References, bindings, and heterogenous environments
 --
 -----------------------------------------------------------------------------
---  $Id: Environment.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Environment
    ( -- * Reference
-     Ref, Reference(..)
+     Ref, Reference(..), mapRef
      -- * Binding
    , Binding, makeBinding
    , fromBinding, showValue, getTermValue
@@ -29,12 +28,12 @@ import Control.Monad
 import Data.Function
 import Data.List
-import Data.Monoid
-import Data.Typeable
+import Data.Semigroup as Sem
 import Ideas.Common.Id
 import Ideas.Common.Rewriting.Term
-import Ideas.Common.Utils
 import Ideas.Common.View
+import Ideas.Utils.Prelude
+import Ideas.Utils.Typeable
 import qualified Data.Map as M
 
 -----------------------------------------------------------
@@ -42,10 +41,11 @@ 
 -- | A data type for references (without a value)
 data Ref a = Ref
-   { identifier :: Id                -- ^ Identifier
-   , printer    :: a -> String       -- ^ A pretty-printer
-   , parser     :: String -> Maybe a -- ^ A parser
-   , refView    :: View Term a       -- ^ Conversion to/from term
+   { identifier :: Id                -- Identifier
+   , printer    :: a -> String       -- Pretty-printer
+   , parser     :: String -> Maybe a -- Parser
+   , refView    :: View Term a       -- Conversion to/from term
+   , refType    :: IsTypeable a
    }
 
 instance Show (Ref a) where
@@ -58,53 +58,66 @@    getId = identifier
    changeId f d = d {identifier = f (identifier d)}
 
+instance HasTypeable Ref where
+   getTypeable = Just . refType
+
 -- | A type class for types as references
 class (IsTerm a, Typeable a, Show a, Read a) => Reference a where
    makeRef     :: IsId n => n -> Ref a
    makeRefList :: IsId n => n -> Ref [a]
    -- default implementation
-   makeRef n     = Ref (newId n) show readM termView
-   makeRefList n = Ref (newId n) show readM termView
+   makeRef n     = Ref (newId n) show readM termView typeable
+   makeRefList n = Ref (newId n) show readM termView typeable
 
 instance Reference Int
 
 instance Reference Term
 
 instance Reference Char where
-   makeRefList n = Ref (newId n) id Just variableView
+   makeRefList n = Ref (newId n) id Just variableView typeable
 
+instance Reference ShowString
+
 instance Reference a => Reference [a] where
    makeRef = makeRefList
 
 instance (Reference a, Reference b) => Reference (a, b)
 
+mapRef :: Typeable b => Isomorphism a b -> Ref a -> Ref b
+mapRef iso r = r
+   { printer = printer r . to iso
+   , parser  = fmap (from iso) . parser r
+   , refView = refView r >>> toView iso
+   , refType = typeable
+   }
+
 -----------------------------------------------------------
 -- Binding
 
-data Binding = forall a . Typeable a => Binding (Ref a) a
+data Binding = forall a . Binding (Ref a) a
 
 instance Show Binding where
    show a = showId a ++ "=" ++ showValue a
 
 instance Eq Binding where
-   (==) = let f (Binding ref a) = (getId ref, build (refView ref) a)
+   (==) = let f (Binding r a) = (getId r, build (refView r) a)
           in (==) `on` f
 
 instance HasId Binding where
-   getId (Binding ref _ ) = getId ref
-   changeId f (Binding ref a) = Binding (changeId f ref) a
+   getId (Binding r _ ) = getId r
+   changeId f (Binding r a) = Binding (changeId f r) a
 
-makeBinding :: Typeable a => Ref a -> a -> Binding
+makeBinding :: Ref a -> a -> Binding
 makeBinding = Binding
 
 fromBinding :: Typeable a => Binding -> Maybe (Ref a, a)
-fromBinding (Binding ref a) = liftM2 (,) (gcast ref) (cast a)
+fromBinding (Binding r a) = liftM2 (,) (gcastFrom r r) (castFrom r a)
 
 showValue :: Binding -> String
-showValue (Binding ref a) = printer ref a
+showValue (Binding r a) = printer r a
 
 getTermValue :: Binding -> Term
-getTermValue (Binding ref a) = build (refView ref) a
+getTermValue (Binding r a) = build (refView r) a
 
 -----------------------------------------------------------
 -- Heterogeneous environment
@@ -115,9 +128,12 @@ instance Show Environment where
    show = intercalate ", " . map show . bindings
 
+instance Sem.Semigroup Environment where
+   a <> b = Env (envMap a `mappend` envMap b) -- left has presedence
+
 instance Monoid Environment where
-   mempty = Env mempty
-   mappend a b = Env (envMap a `mappend` envMap b) -- left has presedence
+   mempty  = Env mempty
+   mappend = (<>)
 
 instance HasRefs Environment where
    allRefs env = [ Some ref | Binding ref _ <- bindings env ]
@@ -125,22 +141,22 @@ makeEnvironment :: [Binding] -> Environment
 makeEnvironment xs = Env $ M.fromList [ (getId a, a) | a <- xs ]
 
-singleBinding :: Typeable a => Ref a -> a -> Environment
-singleBinding ref = makeEnvironment . return . Binding ref
+singleBinding :: Ref a -> a -> Environment
+singleBinding r = makeEnvironment . return . Binding r
 
 class HasEnvironment env where
    environment    :: env -> Environment
    setEnvironment :: Environment -> env -> env
    deleteRef      :: Ref a -> env -> env
-   insertRef      :: Typeable a => Ref a -> a -> env -> env
-   changeRef      :: Typeable a => Ref a -> (a -> a) -> env -> env
+   insertRef      :: Ref a -> a -> env -> env
+   changeRef      :: Ref a -> (a -> a) -> env -> env
    -- default definitions
    deleteRef a = changeEnv (Env . M.delete (getId a) . envMap)
-   insertRef ref =
+   insertRef r =
       let f b = Env . M.insert (getId b) b . envMap
-      in changeEnv . f . Binding ref
-   changeRef ref f env  =
-      maybe id (insertRef ref . f) (ref ? env) env
+      in changeEnv . f . Binding r
+   changeRef r f env  =
+      maybe id (insertRef r . f) (r ? env) env
 
 -- local helper
 changeEnv :: HasEnvironment env => (Environment -> Environment) -> env -> env
@@ -168,11 +184,11 @@ noBindings :: HasEnvironment env => env -> Bool
 noBindings = M.null . envMap . environment
 
-(?) :: (HasEnvironment env, Typeable a) => Ref a -> env -> Maybe a
+(?) :: HasEnvironment env => Ref a -> env -> Maybe a
 ref ? env = do
    let m = envMap (environment env)
-   Binding _ a <- M.lookup (getId ref) m
-   msum [ cast a                         -- typed value
-        , cast a >>= parser ref          -- value as string
-        , cast a >>= match (refView ref) -- value as term
+   Binding r a <- M.lookup (getId ref) m
+   msum [ castBetween r ref a                  -- typed value
+        , castFrom r a >>= parser ref          -- value as string
+        , castFrom r a >>= match (refView ref) -- value as term
         ]
+ src/Ideas/Common/Examples.hs view
@@ -0,0 +1,226 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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 provides an interface to structure a collection of examples.
+-- Examples can be taken from (lists of) concrete values, or from random
+-- generators. Both types can be marked as test items. Examples can be assigned
+-- a level of difficulty (ranging from very easy to very difficult). Test items
+-- do not have a difficulty level. Examples can be grouped into sub-collections
+-- and assigned an identifier. Use the @Monoid@ operations for combining
+-- examples.
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Examples
+   ( -- * Examples type
+     Examples
+     -- * Constructing examples
+   , example, exampleList, examplesFor, examplesWithDifficulty
+   , random, group, forTesting
+     -- * Assigning difficulty
+   , difficulty, veryEasy, easy, medium, difficult, veryDifficult
+     -- * Transformations and queries
+   , isEmpty, size, flatten, groups
+   , topLevelExamples, topLevelRandoms, topLevelTests, topLevelRandomTests
+   , allExamples, allRandoms, allTests, allRandomTests
+     -- * Difficulty type
+   , Difficulty(..), readDifficulty
+   ) where
+
+import Data.Char
+import Data.Maybe
+import Data.Semigroup
+import Ideas.Common.Id
+import Test.QuickCheck
+
+-----------------------------------------------------------------------------
+-- Examples
+
+data Examples a = Examples
+   { groups :: [(Id, Examples a)] -- ^ Top-level groups
+   , items  :: [Item a]
+   }
+
+instance Semigroup (Examples a) where
+   xs <> ys = Examples (groups xs <> groups ys) (items xs <> items ys)
+
+instance Monoid (Examples a) where
+   mempty  = Examples [] []
+   mappend = (<>)
+
+instance Functor Examples where
+   fmap f (Examples xs ys) = Examples [ (n, fmap f g) | (n, g) <- xs ] (map (fmap f) ys)
+
+data Item a = Example (Maybe Difficulty) a
+            | Random  (Maybe Difficulty) (Gen a)
+            | Test a
+            | RandomTest (Gen a)
+
+instance Functor Item where
+   fmap f (Example d a)  = Example d (f a)
+   fmap f (Test a)       = Test (f a)
+   fmap f (Random d g)   = Random d (fmap f g)
+   fmap f (RandomTest g) = RandomTest (fmap f g)
+
+-- | One example
+example :: a -> Examples a
+example = single . Example Nothing
+
+-- | List of examples
+exampleList :: [a] -> Examples a
+exampleList = Examples [] . map (Example Nothing)
+
+-- | List of examples with the same difficulty
+examplesFor :: Difficulty -> [a] -> Examples a
+examplesFor d = examplesWithDifficulty . zip (repeat d)
+
+-- | List of examples with their own difficulty
+examplesWithDifficulty :: [(Difficulty, a)] -> Examples a
+examplesWithDifficulty = Examples [] . map (uncurry (Example . Just))
+
+-- | Use a random generator (from QuickCheck) as example generator
+random :: Gen a -> Examples a
+random = single . Random Nothing
+
+group :: Id -> Examples a -> Examples a
+group n xs = Examples [(n, xs)] []
+
+-- | Assign difficulty (to all items without a difficulty level)
+difficulty :: Difficulty -> Examples a -> Examples a
+difficulty d = changeItems f
+ where
+   f (Example Nothing a) = Example (Just d) a
+   f (Random Nothing a)  = Random  (Just d) a
+   f x = x
+
+-- | Turn examples (and random generators) into tests (and test generators)
+forTesting :: Examples a -> Examples a
+forTesting = changeItems f
+ where
+   f (Example _ a) = Test a
+   f (Random _ a)  = RandomTest a
+   f x = x
+
+-- Querying
+
+-- | Top-level examples
+topLevelExamples :: Examples a -> [(Maybe Difficulty, a)]
+topLevelExamples = collectItems f
+ where
+   f (Example md a) = Just (md, a)
+   f _ = Nothing
+
+-- | Top-level random generators
+topLevelRandoms :: Examples a -> [(Maybe Difficulty, Gen a)]
+topLevelRandoms = collectItems f
+ where
+   f (Random md g) = Just (md, g)
+   f _ = Nothing
+
+-- | Top-level test cases
+topLevelTests :: Examples a -> [a]
+topLevelTests = collectItems f
+ where
+   f (Test a) = Just a
+   f _ = Nothing
+
+-- | Top-level test generators
+topLevelRandomTests :: Examples a -> [Gen a]
+topLevelRandomTests = collectItems f
+ where
+   f (RandomTest g) = Just g
+   f _ = Nothing
+
+-- | All examples (also in groups)
+allExamples :: Examples a -> [(Maybe Difficulty, a)]
+allExamples = topLevelExamples . flatten
+
+-- | All random generators (also in groups)
+allRandoms :: Examples a -> [(Maybe Difficulty, Gen a)]
+allRandoms = topLevelRandoms . flatten
+
+-- | All test cases (also in groups)
+allTests :: Examples a -> [a]
+allTests = topLevelTests . flatten
+
+-- | All test generators (also in groups)
+allRandomTests :: Examples a -> [Gen a]
+allRandomTests = topLevelRandomTests . flatten
+
+-- | Flatten examples into one collection without subgroups
+flatten :: Examples a -> Examples a
+flatten = Examples [] . getItems
+
+-- | Number of examples, including those in subgroups
+size :: Examples a -> Int
+size = length . getItems
+
+-- | Tests if there ar no examples
+isEmpty :: Examples a -> Bool
+isEmpty = null . getItems
+
+-- local helpers
+single :: Item a -> Examples a
+single x = Examples [] [x]
+
+getItems :: Examples a -> [Item a]
+getItems xs = concatMap (getItems . snd) (groups xs) ++ items xs
+
+changeItems :: (Item a -> Item a) -> Examples a -> Examples a
+changeItems f = rec
+ where
+   rec xs = Examples (map g (groups xs)) (map f (items xs))
+   g (n, ys) = (n, rec ys)
+
+collectItems :: (Item a -> Maybe b) -> Examples a -> [b]
+collectItems f = mapMaybe f . items
+
+-----------------------------------------------------------------------------
+-- Difficulty
+
+data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult
+   deriving (Eq, Ord, Enum)
+
+instance Show Difficulty where
+   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.
+readDifficulty :: String -> Maybe Difficulty
+readDifficulty s =
+   case filter p [VeryEasy .. VeryDifficult] of
+            [a] -> Just a
+            _   -> Nothing
+ where
+   normal = filter isAlpha . map toLower
+   p = (== normal s) . normal . show
+
+veryEasy, easy, medium, difficult, veryDifficult :: Examples a -> Examples a
+veryEasy      = difficulty VeryEasy
+easy          = difficulty Easy
+medium        = difficulty Medium
+difficult     = difficulty Difficult
+veryDifficult = difficulty VeryDifficult
src/Ideas/Common/Exercise.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}
+{-# LANGUAGE Rank2Types, 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 2019, 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,52 +15,51 @@ -- "Ideas.Common.ExerciseTests" module.
 --
 -----------------------------------------------------------------------------
---  $Id: Exercise.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Exercise
    ( -- * Exercise record
      Exercise(..), emptyExercise, makeExercise
      -- * Convenience functions
    , prettyPrinterContext, isReady, isSuitable
-   , ruleset, getRule, ruleOrderingWith
+   , ruleset, getRule, ruleOrderingWith, violations
      -- * Status
    , Status(..), isPublic, isPrivate
      -- * Examples
    , Examples, Difficulty(..), readDifficulty
-   , level, mapExamples, examplesContext
+   , examplesFor, examplesWithDifficulty, examplesContext, examplesAsList
+   , testGenerator, randomTerm, randomTerms
      -- * Context
    , inContext, withoutContext
      -- * Type casting
    , useTypeable, castFrom, castTo
      -- * Exercise properties
-   , setProperty, getProperty
-     -- * Random generators
-   , simpleGenerator, useGenerator, randomTerm, randomTerms
+   , setProperty, getProperty, setPropertyF, getPropertyF
      -- * Derivations
    , showDerivation, showDerivations, printDerivation, printDerivations
    , diffEnvironment, defaultDerivation, allDerivations
    ) where
 
-import Data.Char
-import Data.Data
-import Data.Dynamic
 import Data.List
 import Data.Maybe
 import Data.Ord
 import Ideas.Common.Classes
+import Ideas.Common.Constraint
 import Ideas.Common.Context
 import Ideas.Common.Derivation
 import Ideas.Common.Environment
+import Ideas.Common.Examples
 import Ideas.Common.Id
 import Ideas.Common.Predicate
 import Ideas.Common.Rewriting
 import Ideas.Common.Rule
 import Ideas.Common.Strategy hiding (not, fail, repeat, replicate)
-import Ideas.Common.Utils (ShowString(..))
 import Ideas.Common.View
+import Ideas.Utils.Prelude (ShowString(..))
+import Ideas.Utils.Typeable
 import System.Random
 import Test.QuickCheck hiding (label)
 import Test.QuickCheck.Gen
+import Test.QuickCheck.Random (QCGen)
 import qualified Data.Map as M
 import qualified Ideas.Common.Strategy as S
 
@@ -111,16 +110,15 @@      -- rule can be used (e.g. feedback services onefirst and derivation; other
      -- feedback services return all possible rules).
    , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering
+     -- | Constraints for constraint-based tutors. A constraint contains a
+     -- relevance condition and a satisfaction condition.
+   , constraints  :: [Constraint (Context a)]
      -- | A navigator is needed for traversing the expression and for using the
      -- traversal strategy combinators. By default, an exercise has no
      -- navigator.
    , navigation :: a -> ContextNavigator a
      -- | A finite list of examples, each with an assigned difficulty.
    , examples :: Examples a
-     -- | A generator for random exercises of a certain difficulty.
-   , randomExercise :: Maybe (StdGen -> Maybe Difficulty -> a)
-     -- | An exercise generator for testing purposes (including corner cases).
-   , testGenerator  :: Maybe (Gen a)
      -- | Conversion to and from the (generic) 'Term' datatype. Needed for
      -- representing the expression in the OpenMath standard.
    , hasTermView :: Maybe (View Term a)
@@ -129,7 +127,7 @@    , hasTypeable :: Maybe (IsTypeable a)
      -- | Extra exercise-specific properties, not used by the default
      -- feedback services.
-   , properties :: M.Map String Dynamic -- extra, domain-specific properties
+   , properties :: M.Map Id (Dynamic a) -- extra, domain-specific properties
    }
 
 instance Eq (Exercise a) where
@@ -165,14 +163,13 @@    , properties     = M.empty
      -- strategies and rules
    , strategy       = label "Fail" S.fail
+   , constraints    = []
    , navigation     = noNavigator
    , canBeRestarted = True
    , extraRules     = []
    , ruleOrdering   = compareId
-     -- testing and exercise generation
-   , testGenerator  = Nothing
-   , randomExercise = Nothing
-   , examples       = []
+     -- examples
+   , examples       = mempty
    }
 
 -- | In addition to the defaults of 'emptyExercise', this constructor sets
@@ -202,7 +199,7 @@ 
 -- | Returns a sorted list of rules, without duplicates.
 ruleset :: Exercise a -> [Rule (Context a)]
-ruleset ex = nub (sortBy compareId list)
+ruleset ex = nub (sortBy (ruleOrdering ex) list)
  where
    list = extraRules ex ++ rulesInStrategy (strategy ex)
 
@@ -227,6 +224,14 @@       (Nothing, Just _ ) -> GT
       (Nothing, Nothing) -> compareId r1 r2
 
+-- | Get all constraint violations
+violations :: Exercise a -> Context a -> [(Constraint (Context a), String)]
+violations ex ctx =
+   [ (c, msg)
+   | c <- constraints ex
+   , msg <- maybeToList (isViolated c ctx)
+   ]
+
 -----------------------------------------------------------------------------
 -- Status
 
@@ -249,37 +254,44 @@ -----------------------------------------------------------------------------
 -- Examples
 
-type Examples a = [(Difficulty, a)]
-
-data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult
-   deriving (Eq, Ord, Enum, Data, Typeable)
+-- | Returns the examples of an exercise class lifted to a context.
+examplesContext :: Exercise a -> Examples (Context a)
+examplesContext ex = fmap (inContext ex) (examples ex)
 
-instance Show Difficulty where
-   show = (xs !!) . fromEnum
-    where
-      xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"]
+examplesAsList :: Exercise a -> [a]
+examplesAsList = map snd . allExamples . examples
 
--- | Parser for difficulty levels, which ignores non-alpha charactes (including
--- spaces) and upper/lower case distinction.
-readDifficulty :: String -> Maybe Difficulty
-readDifficulty s =
-   case filter p [VeryEasy .. VeryDifficult] of
-            [a] -> Just a
-            _   -> Nothing
+fromGen :: QCGen -> Gen a -> a
+fromGen rng (MkGen f) = a
  where
-   normal = filter isAlpha . map toLower
-   p = (== normal s) . normal . show
+   (sz, r) = randomR (0, 100) rng
+   a       = f r sz
 
--- | Assigns a difficulty level to a list of expressions.
-level :: Difficulty -> [a] -> Examples a
-level = zip . repeat
+-- | Returns a random exercise of a certain difficulty with some random
+-- number generator. The field 'randomExercise' is used; if this is not
+-- defined (i.e., Nothing), one of the examples is used instead.
+randomTerm :: QCGen -> Exercise a -> Maybe Difficulty -> Maybe a
+randomTerm rng ex mdif =
+   case filter ((== mdif) . fst) (allRandoms (examples ex)) of
+      (_, g):_ -> Just (fromGen rng g)
+      []
+         | null xs   -> Nothing
+         | otherwise -> Just (snd (xs !! i))
+       where
+         xs = filter p (allExamples (examples ex)) -- improve
+         p (Just d, _) = maybe True (==d) mdif
+         p _ = False
+         i = fst (randomR (0, length xs - 1) rng)
 
-mapExamples :: (a -> b) -> Examples a -> Examples b
-mapExamples f = map (second f)
+-- | Returns a list of randomly generated terms of a certain difficulty.
+randomTerms :: QCGen -> Exercise a -> Maybe Difficulty -> [a]
+randomTerms rng ex mdif = rec rng
+ where
+   rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (next a)))
 
--- | Returns the examples of an exercise class lifted to a context.
-examplesContext :: Exercise a -> Examples (Context a)
-examplesContext ex = mapExamples (inContext ex) (examples ex)
+-- | An exercise generator for testing purposes (including corner cases); first generator only.
+testGenerator :: Exercise a -> Maybe (Gen a)
+testGenerator = listToMaybe . allRandomTests . examples
 
 -----------------------------------------------------------------------------
 -- Context
@@ -296,77 +308,55 @@ -----------------------------------------------------------------------------
 -- Type casting
 
-data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b)
-                       (forall b . Typeable b => b -> Maybe a)
+instance HasTypeable Exercise where
+   getTypeable = hasTypeable
 
 -- | Encapsulates a type representation (use for 'hasTypeable' field).
 useTypeable :: Typeable a => Maybe (IsTypeable a)
-useTypeable = Just (IT cast cast)
-
--- | Cast from polymorphic type (to exercise-specific type).
--- This only works if 'hasTypeable' contains the right type representation.
-castFrom :: Typeable b => Exercise a -> a -> Maybe b
-castFrom ex a = do
-   IT f _ <- hasTypeable ex
-   f a
-
--- | Cast to polymorphic type (from exercise-specific type).
--- This only works if 'hasTypeable' contains the right type representation.
-castTo :: Typeable b => Exercise a -> b -> Maybe a
-castTo ex a = do
-   IT _ g <- hasTypeable ex
-   g a
+useTypeable = Just typeable
 
 -----------------------------------------------------------------------------
 -- Exercise-specific properties
 
 -- | Set an exercise-specific property (with a dynamic type)
-setProperty :: Typeable val => String -> val -> Exercise a -> Exercise a
-setProperty key a ex =
-   ex { properties = M.insert key (toDyn a) (properties ex) }
+setProperty :: (IsId n, Typeable val) => n -> val -> Exercise a -> Exercise a
+setProperty key a = insertProperty key (Dyn (cast a))
 
+-- | Set an exercise-specific property (with a dynamic type) that is
+-- parameterized over the exercise term.
+setPropertyF :: (IsId n, Typeable f) => n -> f a -> Exercise a -> Exercise a
+setPropertyF key a = insertProperty key (DynF (castF a))
+
+insertProperty :: IsId n => n -> Dynamic a -> Exercise a -> Exercise a
+insertProperty key d ex =
+   ex { properties = M.insert (newId key) d (properties ex) }
+
 -- | Get an exercise-specific property (of a dynamic type)
-getProperty :: Typeable val => String -> Exercise a -> Maybe val
-getProperty key ex = M.lookup key (properties ex) >>= fromDynamic
+getProperty :: (IsId n, Typeable val) => n -> Exercise a -> Maybe val
+getProperty key ex = lookupProperty key ex >>= \d ->
+   case d of
+      Dyn m -> m
+      _     -> Nothing
 
----------------------------------------------------------------
--- Random generators
+-- | Get an exercise-specific property (of a dynamic type) that is
+-- parameterized over the exercise term.
+getPropertyF :: (IsId n, Typeable f) => n -> Exercise a -> Maybe (f a)
+getPropertyF key ex = lookupProperty key ex >>= \d ->
+   case d of
+      DynF m -> m
+      _      -> Nothing
 
--- | Makes a random exercise generator from a QuickCheck generator; the exercise
--- generator ignores the difficulty level. See the 'randomExercise' field.
-simpleGenerator :: Gen a -> Maybe (StdGen -> Maybe Difficulty -> a)
-simpleGenerator = useGenerator . const
+lookupProperty :: IsId n => n -> Exercise a -> Maybe (Dynamic a)
+lookupProperty key = M.lookup (newId key) . properties
 
--- | Makes a random exercise generator based on a QuickCheck generator for a
--- particular difficulty level. See the 'randomExercise' field.
-useGenerator :: (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a)
-useGenerator makeGen = Just (\rng -> rec rng . makeGen)
- where
-   rec rng (MkGen f) = a
-    where
-      (size, r) = randomR (0, 100) rng
-      a         = f r size
+-- | Values with a dynamic type that is parameterized over the exercise term.
+data Dynamic a = Dyn  (forall b . Typeable b => Maybe b)
+               | DynF (forall f . Typeable f => Maybe (f a))
 
--- | Returns a random exercise of a certain difficulty with some random
--- number generator. The field 'randomExercise' is used; if this is not
--- defined (i.e., Nothing), one of the examples is used instead.
-randomTerm :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a
-randomTerm rng ex mdif =
-   case randomExercise ex of
-      Just f  -> return (f rng mdif)
-      Nothing
-         | null xs   -> Nothing
-         | otherwise -> Just (snd (xs !! i))
-       where
-         xs = filter p (examples ex)
-         p (d, _) = maybe True (==d) mdif
-         i = fst (randomR (0, length xs - 1) rng)
+castF :: (Typeable f, Typeable g) => f a -> Maybe (g a)
+castF = fmap fromIdentity . gcast1 . Identity
 
--- | Returns a list of randomly generated terms of a certain difficulty.
-randomTerms :: StdGen -> Exercise a -> Maybe Difficulty -> [a]
-randomTerms rng ex mdif = rec rng
- where
-   rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (next a)))
+newtype Identity a = Identity { fromIdentity :: a}
 
 ---------------------------------------------------------------
 -- Derivations
src/Ideas/Common/ExerciseTests.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: ExerciseTests.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.ExerciseTests where
 
@@ -24,21 +23,21 @@ import Ideas.Common.Exercise
 import Ideas.Common.Id
 import Ideas.Common.Rule
-import Ideas.Common.Utils.TestSuite
 import Ideas.Common.View
-import System.Random
+import Ideas.Utils.TestSuite
 import Test.QuickCheck
+import Test.QuickCheck.Random
 
 ---------------------------------------------------------------
 -- Checks for an exercise
 
 checkExercise :: Exercise a -> IO ()
 checkExercise ex = do
-   stdgen <- getStdGen
-   runTestSuite True (exerciseTestSuite stdgen ex)
+   qcgen <- newQCGen
+   runTestSuite True (exerciseTestSuite qcgen ex)
 
-exerciseTestSuite :: StdGen -> Exercise a -> TestSuite
-exerciseTestSuite stdgen ex = suite ("Exercise " ++ show (exerciseId ex)) $
+exerciseTestSuite :: QCGen -> Exercise a -> TestSuite
+exerciseTestSuite qcgen ex = suite ("Exercise " ++ show (exerciseId ex)) $
    [ assertTrue "exercise terms defined" (not (null xs))
    , assertTrue "equivalence implemented" $
         let eq a b = equivalence ex (inContext ex a) (inContext ex b)
@@ -46,7 +45,7 @@    , assertTrue "similarity implemented" $
         let sim a b = similarity ex (inContext ex a) (inContext ex b)
         in length (nubBy sim xs) > 1
-   , checkExamples stdgen ex
+   , checkExamples qcgen ex
    ] ++
    case testGenerator ex of
       Nothing  -> []
@@ -55,7 +54,7 @@               checkParserPrettyEx ex . inContext ex . fromS
          , suite "Soundness non-buggy rules" $
                  let eq a b = equivalence ex (fromS a) (fromS b)
-                     myGen  = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen)
+                     myGen  = showAs (prettyPrinterContext ex) (inContext ex <$> gen)
                      myView = makeView (Just . fromS) (S (prettyPrinterContext ex))
                      args   = stdArgs {maxSize = 10, maxSuccess = 10}
                  in [ usePropertyWith (showId r) args $
@@ -72,9 +71,9 @@        where
          showAsGen = showAs (prettyPrinter ex) gen
  where
-   xs | isJust (randomExercise ex) =
-           take 10 (randomTerms stdgen ex Nothing)
-      | otherwise = map snd (examples ex)
+   rs = randomTerms qcgen ex Nothing
+   xs | null rs   = examplesAsList ex
+      | otherwise = take 10 rs
 
 data ShowAs a = S {showS :: a -> String, fromS :: a}
 
@@ -82,7 +81,7 @@    show a = showS a (fromS a)
 
 showAs :: (a -> String) -> Gen a -> Gen (ShowAs a)
-showAs f = liftM (S f)
+showAs f = fmap (S f)
 
 -- check combination of parser and pretty-printer
 checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool
@@ -103,15 +102,15 @@    forAll (elements xs) $ \b ->
    a `eq` b
 
-checkExamples :: StdGen -> Exercise a -> TestSuite
-checkExamples stdgen ex
+checkExamples :: QCGen -> Exercise a -> TestSuite
+checkExamples qcgen ex
    | null xs   = mempty
    | otherwise = suite "Examples" $
-        concatMap (checksForTerm True stdgen ex) xs
+        concatMap (checksForTerm True qcgen ex) xs
  where
-   xs = map snd (examples ex)
+   xs = examplesAsList ex
 
-checksForTerm :: Bool -> StdGen -> Exercise a -> a -> [TestSuite]
+checksForTerm :: Bool -> QCGen -> Exercise a -> a -> [TestSuite]
 checksForTerm leftMost _ ex a =
    concat
    -- Left-most derivation
@@ -120,7 +119,7 @@            Nothing -> [assertTrue ("no derivation for " ++ prettyPrinter ex a) False]
       | leftMost
       ] {- ++
-   case randomDerivation stdgen tree of
+   case randomDerivation qcgen tree of
       Just d  -> checksForDerivation ex d
       Nothing -> []
  where
src/Ideas/Common/Id.hs view
@@ -1,8 +1,7 @@-{-# 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 2019, 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
@@ -27,10 +26,9 @@ -- of this type class typically allow labels to appear at multiple locations
 -- within their structure.
 --
--- The 'Id' datatype implements and re-exports the Monoid interface.
+-- The 'Id' datatype implements the Monoid interface.
 --
 -----------------------------------------------------------------------------
---  $Id: Id.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Id
    ( -- * Constructing identifiers
@@ -40,19 +38,17 @@    , describe, description, showId, compareId
      -- * Labeling with identifiers
    , Identify(..)
-     -- re-export
-   , module Data.Monoid
    ) where
 
 import Control.Monad
 import Data.Char
-import Data.Data
 import Data.List
-import Data.Monoid
 import Data.Ord
+import Data.Semigroup as Sem
 import Ideas.Common.Classes
-import Ideas.Common.Utils (splitsWithElem)
-import Ideas.Common.Utils.StringRef
+import Ideas.Text.HTML
+import Ideas.Utils.Prelude (splitsWithElem)
+import Ideas.Utils.StringRef
 import Test.QuickCheck
 
 ---------------------------------------------------------------------
@@ -65,7 +61,6 @@    , idDescription :: String
    , idRef         :: !StringRef
    }
- deriving (Data, Typeable)
 
 instance Show Id where
    show = intercalate "." . idList
@@ -80,9 +75,12 @@ instance Ord Id where
    compare = comparing idRef
 
+instance Sem.Semigroup Id where
+   (<>) = ( # )
+
 instance Monoid Id where
    mempty  = emptyId
-   mappend = ( # )
+   mappend = (<>)
 
 instance Arbitrary Id where
    arbitrary = frequency
@@ -91,6 +89,9 @@                return $ newId xs)
       , (1, liftM2 mappend arbitrary arbitrary)
       ]
+
+instance ToHTML Id where
+   toHTML = text
 
 -- | Type class 'IsId' for constructing identifiers. Examples are
 -- @newId \"algebra.equation\"@, @newId (\"a\", \"b\", \"c\")@, and @newId ()@
src/Ideas/Common/Library.hs view
@@ -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 2019, 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,14 +11,15 @@ -- Exports most from package Common
 --
 -----------------------------------------------------------------------------
---  $Id: Library.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Library
    ( module Export
    , failS, notS, repeatS, replicateS, sequenceS, untilS
+   , Some(..)
    ) where
 
 import Ideas.Common.Classes as Export
+import Ideas.Common.Constraint as Export hiding (Result(..))
 import Ideas.Common.Context as Export
 import Ideas.Common.Derivation as Export
 import Ideas.Common.Environment as Export
@@ -29,8 +30,8 @@ import Ideas.Common.Rule as Export
 import Ideas.Common.Strategy as Export hiding (fail, not, repeat, replicate, sequence, until)
 import Ideas.Common.Traversal.Navigator as Export (Location, location, toLocation, fromLocation, arity, top)
-import Ideas.Common.Utils as Export (readM)
 import Ideas.Common.View as Export
+import Ideas.Utils.Prelude as Export (readM, Some(..))
 
 import qualified Ideas.Common.Strategy as S
src/Ideas/Common/Predicate.hs view
@@ -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 2019, 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,6 @@ -- Representation for predicates
 --
 -----------------------------------------------------------------------------
---  $Id: Predicate.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Predicate
    ( -- * Predicate representation
@@ -23,7 +22,7 @@    , ands, ors, implies, equivalent
    ) where
 
-import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Classes
 import Ideas.Common.Id
 import Ideas.Common.View
src/Ideas/Common/Rewriting.hs view
@@ -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 2019, 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,9 +9,9 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Rewriting.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting (module Export) where
 
+import Ideas.Common.Rewriting.AutoTerm as Export (toTermG, fromTermG)
 import Ideas.Common.Rewriting.RewriteRule as Export
 import Ideas.Common.Rewriting.Term as Export
src/Ideas/Common/Rewriting/AC.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: AC.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting.AC
    ( -- * Types
+ src/Ideas/Common/Rewriting/AutoTerm.hs view
@@ -0,0 +1,124 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Rewriting.AutoTerm (toTermG, fromTermG, testTermFor) where
+
+import Control.Monad.State
+import Data.Data
+import Ideas.Common.Rewriting.Term
+import Ideas.Utils.Prelude (headM)
+
+toTermG :: Data a => a -> Term
+toTermG a =
+   case constrRep constr of
+      IntConstr n   -> TNum n                  -- for Int and Integer
+      FloatConstr r -> TFloat (fromRational r) -- for Double and Float
+      CharConstr c  -> TVar [c]
+      AlgConstr _   ->
+         case cast a of
+            Just s  -> TVar s -- for String
+            Nothing -> makeTerm constr (gfoldl op e a)
+ where
+   op (M xs) x = M (xs ++ [toTermG x])
+   e _    = M []
+   constr = toConstr a
+
+newtype M a = M [Term]
+
+-- test for list constructors
+makeTerm :: Constr -> M a -> Term
+makeTerm c (M xs) =
+   case xs of
+      [y, TList ys] | isCons  -> TList (y:ys)
+      []            | isNil   -> TList []
+      _ -> TCon (constrSymbol c) xs
+ where
+   txt = showConstr c
+   isNil   = txt == "[]"
+   isCons  = txt == "(:)"
+
+isTuple :: String -> Bool
+isTuple ('(':xs) = rec xs
+ where
+   rec ")"      = True
+   rec (',':ys) = rec ys
+   rec _        = False
+isTuple _       = False
+
+------------------------------------------------------------------------
+
+constrSymbol :: Constr -> Symbol
+constrSymbol c
+   | txt == "[]"  = nilSymbol
+   | txt == "(:)" = consSymbol
+   | isTuple txt  = tupleSymbol
+   | otherwise    = newSymbol (dataTypeName (constrType c) `mappend` show c)
+ where
+   txt = showConstr c
+
+nilSymbol, consSymbol, tupleSymbol :: Symbol
+nilSymbol   = newSymbol "list.nil"
+consSymbol  = newSymbol "list.cons"
+tupleSymbol = newSymbol "tuple"
+
+constructors :: Data a => Proxy a -> [Constr]
+constructors = dataTypeConstrs . dataTypeOf . fromProxy
+ where
+   fromProxy :: Proxy a -> a
+   fromProxy = error "fromProxy"
+
+findConstr :: (Monad m, Data a) => Proxy a -> Symbol -> m Constr
+findConstr p s =
+   headM [ c | c <- constructors p, s == constrSymbol c ]
+
+fromTermG :: (MonadPlus m, Data a) => Term -> m a
+fromTermG term =
+   case term of
+      TCon s xs -> fromTermTConG Proxy s xs
+      TVar [c]  -> castM c `mplus` castM [c]
+      TVar s    -> castM s
+      TList xs  -> fromTermG (foldr cons nil xs)
+      TNum n    -> castM n `mplus` castM (fromInteger n :: Int)
+      TFloat d  -> castM d `mplus` castM (doubleToFloat d)
+      TMeta _   -> fail "fromTermG: found TMeta"
+ where
+   cons = binary consSymbol
+   nil  = symbol nilSymbol
+
+castM :: (Monad m, Typeable a, Typeable b) => a -> m b
+castM = maybe (fail "fromTermG") return . cast
+
+doubleToFloat :: Double -> Float
+doubleToFloat = fromRational . toRational
+
+fromTermTConG :: (MonadPlus m, Data a) => Proxy a -> Symbol -> [Term] -> m a
+fromTermTConG p s xs = do
+   c <- findConstr p s
+   evalStateT (gunfold op return c) xs
+ where
+   op m = do
+      f <- m
+      t <- pop
+      a <- lift (fromTermG t)
+      return (f a)
+
+pop :: Monad m => StateT [a] m a
+pop = do
+   ts <- get
+   case ts of
+      []    -> fail "pop"
+      hd:tl -> put tl >> return hd
+
+--------------
+
+testTermFor :: (Data a, Eq a) => a -> Bool
+testTermFor x = fromTermG (toTermG x) == Just x
src/Ideas/Common/Rewriting/Confluence.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Confluence.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting.Confluence
    ( isConfluent, checkConfluence, checkConfluenceWith
@@ -17,6 +16,7 @@    , Config, defaultConfig, showTerm, complexity, termEquality
    ) where
 
+import Data.List
 import Data.Maybe
 import Ideas.Common.Id
 import Ideas.Common.Rewriting.RewriteRule
@@ -25,7 +25,7 @@ import Ideas.Common.Rewriting.Unification
 import Ideas.Common.Traversal.Navigator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.Uniplate hiding (rewriteM)
+import Ideas.Utils.Uniplate hiding (rewriteM)
 
 normalForm :: [RewriteRule a] -> Term -> Term
 normalForm rs = run []
@@ -79,7 +79,7 @@ 
 criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)]
 criticalPairs rs =
-   [ (a, (r1, b1), (r2, b2))
+   [ (renumber a, (r1, renumber b1), (r2, renumber b2))
    | r1       <- rs
    , r2       <- rs
    , na <- superImpose r1 r2
@@ -87,6 +87,10 @@    , let a = unfocus na
    , b1 <- rewriteTerm r1 a
    , b2 <- map unfocus (changeG (rewriteTerm r2) na)
+   , let is  = nub (concatMap metaVars [a, b1, b2])
+         sub = zip is [0..]
+         renumber (TMeta i) = TMeta (fromMaybe i (lookup i sub))
+         renumber t = descend renumber t
    ]
 
 noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]
@@ -134,25 +138,25 @@ 
 ----------------------------------------------------
 -- Example
-{-
-r1, r2, r3, r4, r5 :: RewriteRule SLogic
-r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r
-r2 = rewriteRule "R2" $ \p q   -> p :||: q :~> q :||: p
-r3 = rewriteRule "R3" $ \p     -> p :||: p :~> p
-r4 = rewriteRule "R4" $ \p     -> p :||: T :~> T
-r5 = rewriteRule "R5" $ \p     -> p :||: F :~> p
 
-this = [r1, r2, r3, r4, r5, r6]
-go = reportPairs $ noDiamondPairs this
+_go :: IO ()
+_go = checkConfluence [r1, r2, r3]
+ where
+   r1, r2, r3 :: RewriteRule Term
+   r1 = makeRewriteRule "a1" $ \a -> plus (TNum 0) a :~> a
+   r2 = makeRewriteRule "a2" $ \a b c -> plus a (plus b c) :~> plus (plus a b) c
+   r3 = makeRewriteRule "a3" $ \a -> plus a (TNum 0) :~> a
 
-r6 :: RewriteRule SLogic
-r6 = rewriteRule "R6" $ \p -> p :||: T :~> F
+   plus :: Term -> Term -> Term
+   plus x y = TCon (newSymbol "plus") [x, y]
 
-r1, r2, r3 :: RewriteRule Expr
-r1 = rewriteRule "a1" $ \a -> 0+a :~> a
-r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c
-r3 = rewriteRule "a2" $ \a -> a+0 :~> a
+_go2 :: IO ()
+_go2 = checkConfluence [r1,r2,r3]
+ where
+   -- example 7.7 in Baader-Nipkow
+   r1, r2,r3  :: RewriteRule Term
+   r1 = makeRewriteRule "a1" $ \x y z -> f(f(x,y),z) :~> f(x,f(y,z))
+   r2 = makeRewriteRule "a2" $ \x -> f(x,x) :~> x
+   r3 = makeRewriteRule "a3" $ \x y -> f(f(x,y),x) :~> x
 
-go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2]
-        checkConfluence [r1,r2,r3]
--}+   f(x,y) = TCon (newSymbol "f") [x,y]
src/Ideas/Common/Rewriting/Difference.hs view
@@ -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 2019, 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,12 +12,8 @@ -- into account.
 --
 -----------------------------------------------------------------------------
---  $Id: Difference.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
-module Ideas.Common.Rewriting.Difference
-   ( difference, differenceEqual
-   , differenceWith, differenceEqualWith
-   ) where
+module Ideas.Common.Rewriting.Difference (difference, differenceWith) where
 
 import Control.Monad
 import Data.Function
@@ -25,64 +21,38 @@ import Ideas.Common.Rewriting.Term
 import Ideas.Common.View
 
-differenceWith :: View Term a -> a -> a -> Maybe (a, a)
-differenceWith = diff (\_ _ -> True)
-
-differenceEqualWith :: View Term a -> (a -> a -> Bool) -> a -> a -> Maybe (a, a)
-differenceEqualWith v eq p q = guard (eq p q) >> diff eq v p q
-
 difference :: IsTerm a => a -> a -> Maybe (a, a)
-difference = diff (\_ _ -> True) termView
-
--- | This function returns the difference, except that the
--- returned terms should be logically equivalent. Nothing can signal that
--- there is no difference, or that the terms to start with are not equivalent.
-differenceEqual :: IsTerm a => (a -> a -> Bool) -> a -> a -> Maybe (a, a)
-differenceEqual eq p q = do
-   guard (eq p q)
-   diff eq termView p q
-
-collectSym :: Symbol -> Term -> [Term]
-collectSym s a = maybe [a] (uncurry ((++) `on` collectSym s)) (isBinary s a)
+difference = differenceWith termView
 
--- local implementation function
-diff :: (a -> a -> Bool) -> View Term a -> a -> a -> Maybe (a, a)
-diff eq v a b = do
-   let eqT x y = fromMaybe False $ liftM2 eq (match v x) (match v y)
-   (t1, t2) <- diffTerm eqT (build v a) (build v b)
+differenceWith :: View Term a -> a -> a -> Maybe (a, a)
+differenceWith v a b = do
+   (t1, t2) <- diffTerm (build v a) (build v b)
    liftM2 (,) (match v t1) (match v t2)
 
-diffTerm :: (Term -> Term -> Bool) -> Term -> Term -> Maybe (Term, Term)
-diffTerm eq = rec
+-- returns a result if the terms are different
+diffTerm :: Term -> Term -> Maybe (Term, Term)
+diffTerm p q =
+   case (getFunctionA p, getFunctionA q) of
+      (Just (s1, ps), Just (s2, qs))
+         | s1 == s2  -> diffList ps qs
+         | otherwise -> here
+      _  | p == q    -> Nothing
+         | otherwise -> here
  where
-   rec p q =
-      case (getFunction p, getFunction q) of
-         (Just (s1, ps), Just (s2, qs))
-            | s1 /= s2         -> Just (p, q)
-            | isAssociative s1 -> (diffA s1 `on` collectSym s1) p q
-            | otherwise        -> diffList ps qs
-         _  | p == q           -> Nothing
-            | otherwise        -> Just (p, q)
+   here = Just (p, q)
 
    diffList xs ys
-      | length xs /= length ys = Nothing
+      | length xs /= length ys = here
       | otherwise =
-           case catMaybes (zipWith rec xs ys) of
-              [p] -> Just p
-              _   -> Nothing
+           case catMaybes (zipWith diffTerm xs ys) of
+              []    -> Nothing
+              [one] -> Just one
+              _     -> here
 
-   diffA s = curry (make . rev . f . rev . f)
-    where
-      f (p:ps, q:qs) | not (null ps || null qs) &&
-                       isNothing (rec p q) &&
-                       equal ps qs =
-         f (ps, qs)
-      f pair = pair
+getFunctionA :: (Monad m, WithFunctions a) => a -> m (Symbol, [a])
+getFunctionA a = f <$> getFunction a
+ where
+   f (s, xs) = (s, if isAssociative s then collectSym s a else xs)
 
-      equal     = eq `on` builder
-      rev       = reverse *** reverse
-      builder   = foldr1 (binary s)
-      make pair =
-         case pair of
-            ([p], [q]) -> rec p q
-            (ps, qs)   -> Just (builder ps, builder qs)+collectSym :: WithFunctions a => Symbol -> a -> [a]
+collectSym s a = maybe [a] (uncurry ((++) `on` collectSym s)) (isBinary s a)
src/Ideas/Common/Rewriting/RewriteRule.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
+{-# LANGUAGE ExistentialQuantification,
        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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: RewriteRule.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting.RewriteRule
    ( -- * Supporting type class
@@ -27,15 +26,14 @@    ) where
 
 import Data.Maybe
-import Data.Monoid
 import Ideas.Common.Classes
 import Ideas.Common.Environment
 import Ideas.Common.Id
 import Ideas.Common.Rewriting.Substitution
 import Ideas.Common.Rewriting.Term
 import Ideas.Common.Rewriting.Unification
-import Ideas.Common.Utils.Uniplate (descend)
 import Ideas.Common.View hiding (match)
+import Ideas.Utils.Uniplate (descend)
 import qualified Data.IntSet as IS
 import qualified Data.Map as M
 
@@ -74,8 +72,42 @@ instance Different a => Different [a] where
    different = ([], [fst different])
 
+instance Different Int where
+   different = (0, 1)
+
+instance Different Integer where
+   different = (0, 1)
+
+instance Different Double where
+   different = (0, 1)
+
+instance Different Float where
+   different = (0, 1)
+
+instance Different Rational where
+   different = (0, 1)
+
+instance Different Bool where
+   different = (True, False)
+
 instance Different Char where
    different = ('a', 'b')
+
+instance Different Term where
+   different = (TNum 0, TNum 1)
+
+instance (Different a, Different b) => Different (a, b) where
+   different =
+      let (a1, a2) = different
+          (b1, b2) = different
+      in ((a1, b1), (a2, b2))
+
+instance (Different a, Different b, Different c) => Different (a, b, c) where
+   different =
+      let (a1, a2) = different
+          (b1, b2) = different
+          (c1, c2) = different
+      in ((a1, b1, c1), (a2, b2, c2))
 
 class (IsTerm a, Show a) => RuleBuilder t a | t -> a where
    buildRuleSpec  :: Int -> t -> RuleSpec Term
src/Ideas/Common/Rewriting/Substitution.hs view
@@ -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 2019, 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,6 @@ -- Substitutions on terms. Substitutions are idempotent, and non-cyclic.
 --
 -----------------------------------------------------------------------------
---  $Id: Substitution.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting.Substitution
    ( Substitution, emptySubst, singletonSubst, dom, lookupVar
@@ -22,10 +21,10 @@ import Control.Monad
 import Data.List
 import Data.Maybe
-import Data.Monoid
+import Data.Semigroup as Sem
 import Ideas.Common.Rewriting.Term
-import Ideas.Common.Utils.TestSuite
-import Ideas.Common.Utils.Uniplate
+import Ideas.Utils.TestSuite
+import Ideas.Utils.Uniplate
 import Test.QuickCheck
 import qualified Data.IntMap as IM
 import qualified Data.IntSet as IS
@@ -37,9 +36,12 @@ newtype Substitution = S { unS :: IM.IntMap Term }
    deriving Eq
 
+instance Sem.Semigroup Substitution where
+   (<>) = (@@)
+
 instance Monoid Substitution where
    mempty  = emptySubst
-   mappend = (@@)
+   mappend = (<>)
 
 infixr 5 |->
 infixr 6 @@
@@ -93,7 +95,7 @@ infix 6 @+@
 
 (@+@) :: Substitution -> Substitution -> Maybe Substitution
-s1 @+@ s2 = liftM S $ foldM op (unS s1) $ IM.toList $ unS s2
+s1 @+@ s2 = fmap S $ foldM op (unS s1) $ IM.toList $ unS s2
  where
    op m (i, a) =
       case IM.lookup i m of
src/Ideas/Common/Rewriting/Term.hs view
@@ -1,9 +1,8 @@-{-# 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 2019, 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,12 +12,12 @@ -- A simple data type for term rewriting
 --
 -----------------------------------------------------------------------------
---  $Id: Term.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting.Term
    ( -- * Symbols
      Symbol, newSymbol
    , isAssociative, makeAssociative
+   , nothingSymbol, trueSymbol, falseSymbol
      -- * Terms
    , Term(..), IsTerm(..), termView
    , fromTermM, fromTermWith
@@ -35,15 +34,15 @@    ) where
 
 import Control.Monad
-import Data.Data
 import Data.Function
 import Data.Maybe
 import Ideas.Common.Id
-import Ideas.Common.Utils (ShowString(..))
-import Ideas.Common.Utils.QuickCheck
-import Ideas.Common.Utils.Uniplate
 import Ideas.Common.View
+import Ideas.Utils.Prelude (ShowString(..))
+import Ideas.Utils.QuickCheck hiding (function)
+import Ideas.Utils.Uniplate
 import qualified Data.IntSet as IS
+import qualified Data.Map as M
 import qualified Data.Set as S
 
 -----------------------------------------------------------
@@ -85,7 +84,7 @@           | TNum   Integer
           | TFloat Double
           | TMeta  Int
- deriving (Show, Read, Eq, Ord, Typeable)
+ deriving (Show, Read, Eq, Ord)
 
 instance Uniplate Term where
    uniplate (TCon x xs)   = plate (function x) ||* xs
@@ -96,8 +95,14 @@ -- * Type class for conversion to/from terms
 
 class IsTerm a where
-   toTerm   :: a -> Term
-   fromTerm :: MonadPlus m => Term -> m a
+   toTerm       :: a -> Term
+   toTermList   :: [a] -> Term
+   fromTerm     :: MonadPlus m => Term -> m a
+   fromTermList :: MonadPlus m => Term -> m [a]
+   -- default implementation
+   toTermList   = TList . map toTerm
+   fromTermList (TList xs) = mapM fromTerm xs
+   fromTermList _ = fail "fromTermList: not a list"
 
 termView :: IsTerm a => View Term a
 termView = makeView fromTerm toTerm
@@ -113,18 +118,23 @@ 
 instance (IsTerm a, IsTerm b) => IsTerm (a, b) where
    toTerm (a, b) = TList [toTerm a, toTerm b]
-   fromTerm (TList [a, b]) = liftM2 (,) (fromTerm a) (fromTerm b)
+   fromTerm (TList [a, b]) =  (,) <$> fromTerm a <*> fromTerm b
    fromTerm _              = fail "fromTerm"
 
+instance (IsTerm a, IsTerm b, IsTerm c) => IsTerm (a, b, c) where
+   toTerm (a, b, c) = TList [toTerm a, toTerm b, toTerm c]
+   fromTerm (TList [a, b, c]) = (,,) <$> fromTerm a <*> fromTerm b <*> fromTerm c
+   fromTerm _                 = fail "fromTerm"
+
 instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where
    toTerm = either toTerm toTerm
    fromTerm expr =
-      liftM Left  (fromTerm expr) `mplus`
-      liftM Right (fromTerm expr)
+      fmap Left  (fromTerm expr) `mplus`
+      fmap Right (fromTerm expr)
 
 instance IsTerm Int where
    toTerm = TNum . fromIntegral
-   fromTerm = liftM fromInteger . fromTerm
+   fromTerm = fmap fromInteger . fromTerm
 
 instance IsTerm Integer where
    toTerm = TNum
@@ -138,14 +148,42 @@ 
 instance IsTerm Char where
    toTerm c = TVar [c]
-   fromTerm (TVar [c]) = return c
-   fromTerm _          = fail "fromTerm"
+   toTermList = TVar
+   fromTerm (TVar [c])   = return c
+   fromTerm _            = fail "fromTerm: not a TVar"
+   fromTermList (TVar s) = return s
+   fromTermList _        = fail "fromTermList: not a TVar"
 
+instance IsTerm Bool where
+   toTerm True  = symbol trueSymbol
+   toTerm False = symbol falseSymbol
+   fromTerm (TCon s [])
+      | s == trueSymbol  = return True
+      | s == falseSymbol = return False
+   fromTerm _ = fail "fromTerm: not a Bool"
+
 instance IsTerm a => IsTerm [a] where
-   toTerm = TList . map toTerm
-   fromTerm (TList xs) = mapM fromTerm xs
-   fromTerm _ = fail "fromTerm"
+   toTerm = toTermList
+   fromTerm = fromTermList
 
+instance (IsTerm a, Ord a) => IsTerm (S.Set a) where
+   toTerm   = toTerm . S.toList
+   fromTerm = fmap S.fromList . fromTerm
+
+instance (IsTerm a, IsTerm b, Ord a) => IsTerm (M.Map a b) where
+   toTerm   = toTerm . M.toList
+   fromTerm = fmap M.fromList . fromTerm
+
+trueSymbol, falseSymbol, nothingSymbol :: Symbol
+trueSymbol    = newSymbol "true"
+falseSymbol   = newSymbol "false"
+nothingSymbol = newSymbol "Nothing"
+
+instance IsTerm a => IsTerm (Maybe a) where
+   toTerm = maybe (symbol nothingSymbol) toTerm
+   fromTerm (TCon s []) | s == nothingSymbol = return Nothing
+   fromTerm t = fmap Just (fromTerm t)
+
 fromTermM :: (Monad m, IsTerm a) => Term -> m a
 fromTermM = maybe (fail "fromTermM") return . fromTerm
 
@@ -178,7 +216,7 @@    getFunction _           = fail "Ideas.Common.Rewriting.getFunction"
 
 isSymbol :: WithFunctions a => Symbol -> a -> Bool
-isSymbol s = maybe False (==s) . getSymbol
+isSymbol s = (== Just s) . getSymbol
 
 isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a]
 isFunction s a =
src/Ideas/Common/Rewriting/Unification.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Unification.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rewriting.Unification
    ( unify, match, matchExtended, matchList
@@ -22,7 +21,7 @@ import Ideas.Common.Rewriting.AC (pairingsMatchA)
 import Ideas.Common.Rewriting.Substitution
 import Ideas.Common.Rewriting.Term
-import Ideas.Common.Utils.TestSuite
+import Ideas.Utils.TestSuite
 import qualified Data.Map as M
 
 -----------------------------------------------------------
@@ -142,7 +141,7 @@ safeZipWith f = rec
  where
    rec []     []     = Just []
-   rec (a:as) (b:bs) = liftM (f a b:) (rec as bs)
+   rec (a:as) (b:bs) = fmap (f a b:) (rec as bs)
    rec _      _      = Nothing
 
 products :: [[Substitution]] -> [Substitution]
src/Ideas/Common/Rule.hs view
@@ -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 2019, 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,10 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Rule.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rule (module Export) where
 
 import Ideas.Common.Rule.Abstract as Export
-import Ideas.Common.Rule.EnvironmentMonad as Export
 import Ideas.Common.Rule.Parameter as Export
 import Ideas.Common.Rule.Recognizer as Export
 import Ideas.Common.Rule.Transformation as Export
src/Ideas/Common/Rule/Abstract.hs view
@@ -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 2019, 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,6 @@ -- can be lifted with a view using the LiftView type class.
 --
 -----------------------------------------------------------------------------
---  $Id: Abstract.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rule.Abstract
    ( -- * Rule data type and accessors
@@ -26,20 +25,18 @@    , idRule, checkRule, emptyRule
      -- * Rule properties
    , ruleSiblings, siblingOf
-   , isRewriteRule, isRecognizer, doAfter
+   , isRewriteRule, doAfter
      -- * Recognizer
    , addRecognizer, addRecognizerBool
-   , addTransRecognizer, addRecognizerEnvMonad
+   , addTransRecognizer
    ) where
 
 import Control.Arrow
 import Control.Monad
-import Data.Monoid
 import Ideas.Common.Classes
 import Ideas.Common.Environment
 import Ideas.Common.Id
 import Ideas.Common.Rewriting
-import Ideas.Common.Rule.EnvironmentMonad
 import Ideas.Common.Rule.Recognizer
 import Ideas.Common.Rule.Transformation
 import Ideas.Common.View
@@ -157,9 +154,6 @@ isRewriteRule :: Rule a -> Bool
 isRewriteRule = not . null . getRewriteRules . transformation
 
-isRecognizer :: Rule a -> Bool
-isRecognizer = isZeroTrans . transformation
-
 siblingOf :: HasId b => b -> Rule a -> Rule a
 siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r }
 
@@ -175,9 +169,6 @@ 
 addRecognizerBool :: (a -> a -> Bool) -> Rule a -> Rule a
 addRecognizerBool eq = addRecognizer (makeRecognizer eq)
-
-addRecognizerEnvMonad :: (a -> a -> EnvMonad ()) -> Rule a -> Rule a
-addRecognizerEnvMonad = addRecognizer . makeRecognizerEnvMonad
 
 addTransRecognizer :: (a -> a -> Bool) -> Rule a -> Rule a
 addTransRecognizer eq r = flip addRecognizer r $
− src/Ideas/Common/Rule/EnvironmentMonad.hs 
@@ -1,121 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- State monad for environments
---
------------------------------------------------------------------------------
---  $Id: EnvironmentMonad.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Rule.EnvironmentMonad
-   ( -- * Environment Monad
-     EnvMonad((:=), (:~), (:?))
-   , getRef, updateRefs
-     -- * Running the monad
-   , runEnvMonad, execEnvMonad, evalEnvMonad
-     -- * Extracting used references
-   , envMonadRefs, envMonadFunctionRefs
-   ) where
-
-import Control.Monad
-import Data.Maybe
-import Data.Typeable
-import Ideas.Common.Environment
-import Ideas.Common.Utils
-import System.IO.Unsafe
-import qualified Control.Exception as C
-
------------------------------------------------------------
--- Environment Monad
-
-infix 2 :=, :~, :?
-
-data EnvMonad a where
-   -- Monad operations
-   Return :: a -> EnvMonad a
-   Bind   :: EnvMonad a -> (a -> EnvMonad b) -> EnvMonad b
-   Then   :: EnvMonad a -> EnvMonad b -> EnvMonad b
-   Fail   :: String -> EnvMonad b
-   -- MonadPlus operations
-   Zero   :: EnvMonad a
-   Plus   :: EnvMonad a -> EnvMonad a -> EnvMonad a
-   -- References (special)
-   (:=)   :: Typeable a => Ref a -> a -> EnvMonad ()
-   (:~)   :: Typeable a => Ref a -> (a -> a) -> EnvMonad ()
-   (:?)   :: Typeable a => Ref a -> a -> EnvMonad a
-   GetRef :: Typeable a => Ref a -> EnvMonad a
-
-instance Monad EnvMonad where
-   return = Return
-   (>>=)  = Bind
-   fail   = Fail
-
-instance MonadPlus EnvMonad where
-   mzero = Zero
-   mplus = Plus
-
-getRef :: Typeable a => Ref a -> EnvMonad a
-getRef = GetRef
-
-updateRefs :: MonadPlus m => [EnvMonad a] -> Environment -> m Environment
-updateRefs xs = msum . map return . execEnvMonad (sequence_ xs)
-
------------------------------------------------------------
--- Environment Monad
-
-runEnvMonad :: EnvMonad a -> Environment -> [(a, Environment)]
-runEnvMonad envMonad env =
-   case envMonad of
-      Return a   -> [(a, env)]
-      Bind m f   -> concat [ runEnvMonad (f a) e | (a, e) <- runEnvMonad m env ]
-      Then m n   -> concat [ runEnvMonad n e     | (_, e) <- runEnvMonad m env ]
-      Fail _     -> []
-      Zero       -> []
-      Plus m n   -> runEnvMonad m env ++ runEnvMonad n env
-      ref := a   -> [((), insertRef ref a env)]
-      ref :~ f   -> [((), changeRef ref f env)]
-      ref :? a   -> [(fromMaybe a (ref ? env), env)]
-      GetRef ref -> case ref ? env of
-                       Just a  -> [(a, env)]
-                       Nothing -> []
-
-execEnvMonad :: EnvMonad a -> Environment -> [Environment]
-execEnvMonad m = liftM snd . runEnvMonad m
-
-evalEnvMonad :: EnvMonad a -> Environment -> [a]
-evalEnvMonad m = liftM fst . runEnvMonad m
-
------------------------------------------------------------
--- Extracting used references
-
-envMonadRefs :: EnvMonad a -> [Some Ref]
-envMonadRefs = unsafePerformIO . safeIO . envMonadRefsIO
-
-envMonadFunctionRefs :: (a -> EnvMonad b) -> [Some Ref]
-envMonadFunctionRefs = unsafePerformIO . safeIO . envMonadFunctionRefsIO
-
-envMonadRefsIO :: EnvMonad a -> IO [Some Ref]
-envMonadRefsIO monad =
-   case monad of
-      Bind m f -> envMonadRefsIO m ++++ envMonadFunctionRefsIO f
-      Then a b -> envMonadRefsIO a ++++ envMonadRefsIO b
-      Plus a b -> envMonadRefsIO a ++++ envMonadRefsIO b
-      r := _   -> return [Some r]
-      r :~ _   -> return [Some r]
-      r :? _   -> return [Some r]
-      _        -> return []
- where
-   a ++++ b = liftM2 (++) (safeIO a) (safeIO b)
-
-envMonadFunctionRefsIO :: (a -> EnvMonad b) -> IO [Some Ref]
-envMonadFunctionRefsIO = safeIO . envMonadRefsIO . ($ error "catch me")
-
-safeIO :: IO [a] -> IO [a]
-safeIO m = m `C.catch` \(C.SomeException _) -> return []
src/Ideas/Common/Rule/Parameter.hs view
@@ -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 2019, 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,47 +15,121 @@ -- the LiftView type class.
 --
 -----------------------------------------------------------------------------
---  $Id: Parameter.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rule.Parameter
-   ( ParamTrans
-   , supplyParameters, supplyContextParameters
+   ( -- * Reading inputs
+     input, inputWith
+   , transInput1, transInput2, transInput3, transInputWith
+   , readRef2, readRef3
+     -- * Writing outputs
+   , output, outputWith
+   , outputOnly, outputOnly2, outputOnly3, outputOnlyWith
+   , writeRef2, writeRef3, writeRef2_, writeRef3_
+     -- * Named parameters
+   , ParamTrans
    , parameter1, parameter2, parameter3
+   , transRef
+   , supplyParameters
    ) where
 
 import Control.Arrow
+import Data.Maybe
 import Ideas.Common.Context
 import Ideas.Common.Environment
-import Ideas.Common.Id
-import Ideas.Common.Rule.EnvironmentMonad
 import Ideas.Common.Rule.Transformation
 import Ideas.Common.View
 
------------------------------------------------------------
---- Bindables
+----------------------------------------------------------------------------
+-- Reading inputs
 
-type ParamTrans a b = Trans (a, b) b
+input :: Ref i -> Trans (i, a) b -> Trans a b
+input = inputWith . readRef
 
-supplyParameters :: ParamTrans b a -> (a -> Maybe b) -> Transformation a
-supplyParameters f g = transMaybe g &&& identity >>> f
+inputWith :: Trans a i -> Trans (i, a) b -> Trans a b
+inputWith f g = (f &&& identity) >>> g
 
-supplyContextParameters :: ParamTrans b a -> (a -> EnvMonad b) -> Transformation (Context a)
-supplyContextParameters f g = transLiftContextIn $
-   transUseEnvironment (transEnvMonad g &&& identity) >>> first f
+transInput1 :: Ref i -> (i -> a -> Maybe b) -> Trans a b
+transInput1 = transInputWith . readRef
 
-parameter1 :: (IsId n1, Reference a) => n1 -> (a -> Transformation b) -> ParamTrans a b
-parameter1 n1 f = first (bindValue n1 >>> arr f) >>> app
+transInput2 :: Ref i1 -> Ref i2 -> (i1 -> i2 -> a -> Maybe b) -> Trans a b
+transInput2 r1 r2 = transInputWith (readRef2 r1 r2) . uncurry
 
-parameter2 :: (IsId n1, IsId n2, Reference a, Reference b)
-           => n1 -> n2 -> (a -> b -> Transformation c) -> ParamTrans (a, b) c
-parameter2 n1 n2 f = first (bindValue n1 *** bindValue n2 >>> arr (uncurry f)) >>> app
+transInput3 :: Ref i1 -> Ref i2 -> Ref i3 -> (i1 -> i2 -> i3 -> a -> Maybe b) -> Trans a b
+transInput3 r1 r2 r3 = transInputWith (readRef3 r1 r2 r3) . uncurry3
 
-parameter3 :: (IsId n1, IsId n2, IsId n3, Reference a, Reference b, Reference c)
-           => n1 -> n2 -> n3 -> (a -> b -> c -> Transformation d) -> ParamTrans (a, b, c) d
-parameter3 n1 n2 n3 f = first ((\(a, b, c) -> (a, (b, c))) ^>>
-   bindValue n1 *** (bindValue n2 *** bindValue n3) >>^
-   (\(a, (b, c)) -> f a b c))
-           >>> app
+transInputWith :: MakeTrans f => Trans a i -> (i -> a -> f b) -> Trans a b
+transInputWith t = inputWith t . makeTrans . uncurry
 
-bindValue :: (IsId n, Reference a) => n -> Trans a a
-bindValue = transRef . makeRef+readRef2 :: Ref a -> Ref b -> Trans x (a, b)
+readRef2 r1 r2 = readRef r1 &&& readRef r2
+
+readRef3 :: Ref a -> Ref b -> Ref c -> Trans x (a, b, c)
+readRef3 r1 r2 r3 = readRef r1 &&& readRef2 r2 r3 >>^ to3
+
+----------------------------------------------------------------------------
+-- Writing outputs
+
+output :: Ref o -> Trans a (b, o) -> Trans a b
+output = outputWith . writeRef
+
+outputWith :: Trans o x -> Trans a (b, o) -> Trans a b
+outputWith f g = g >>> second f >>^ fst
+
+outputOnly :: Ref o -> Trans a o -> Trans a a
+outputOnly = outputOnlyWith . writeRef
+
+outputOnly2 :: Ref o1 -> Ref o2 -> Trans a (o1, o2) -> Trans a a
+outputOnly2 r1 = outputOnlyWith . writeRef2 r1
+
+outputOnly3 :: Ref o1 -> Ref o2 -> Ref o3 -> Trans a (o1, o2, o3) -> Trans a a
+outputOnly3 r1 r2 = outputOnlyWith . writeRef3 r1 r2
+
+outputOnlyWith :: Trans o x -> Trans a o -> Trans a a
+outputOnlyWith f g = ((g >>> f) &&& identity) >>^ snd
+
+writeRef2 :: Ref a -> Ref b -> Trans (a, b) (a, b)
+writeRef2 r1 r2 = writeRef r1 *** writeRef r2
+
+writeRef2_ :: Ref a -> Ref b -> Trans (a, b) ()
+writeRef2_ r1 r2 = writeRef2 r1 r2 >>^ const ()
+
+writeRef3 :: Ref a -> Ref b -> Ref c -> Trans (a, b, c) (a, b, c)
+writeRef3 r1 r2 r3 = from3 ^>> writeRef r1 *** writeRef2 r2 r3 >>^ to3
+
+writeRef3_ :: Ref a -> Ref b -> Ref c -> Trans (a, b, c) ()
+writeRef3_ r1 r2 r3 = writeRef3 r1 r2 r3 >>^ const ()
+
+----------------------------------------------------------------------------
+-- Named parameters
+
+type ParamTrans i a = Trans (i, a) a
+
+parameter1 :: Ref a -> (a -> b -> Maybe b) -> ParamTrans a b
+parameter1 r1 f = first (transRef r1) >>> makeTrans (uncurry f)
+
+parameter2 :: Ref a -> Ref b -> (a -> b -> c -> Maybe c) -> ParamTrans (a, b) c
+parameter2 r1 r2 f = first (transRef r1 *** transRef r2) >>> makeTrans (uncurry (uncurry f))
+
+parameter3 :: Ref a -> Ref b -> Ref c -> (a -> b -> c -> d -> Maybe d) -> ParamTrans (a, b, c) d
+parameter3 r1 r2 r3 f = first (from3 ^>> t >>^ to3) >>> makeTrans (uncurry (\(a, b, c) -> f a b c))
+ where
+   t = transRef r1 *** (transRef r2 *** transRef r3)
+
+transRef :: Ref a -> Trans a a
+transRef r = (identity &&& readRefMaybe r) >>> uncurry fromMaybe ^>> writeRef r
+
+supplyParameters :: ParamTrans b a -> Trans a b -> Transformation (Context a)
+supplyParameters f g = transLiftContextIn $
+   transUseEnvironment (g &&& identity) >>> first f
+
+-----------------------------------------------------------------
+-- helpers
+
+from3 :: (a, b, c) -> (a, (b, c))
+from3 (a, b, c) = (a, (b, c))
+
+to3 :: (a, (b, c)) -> (a, b, c)
+to3 (a, (b, c)) = (a, b, c)
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
src/Ideas/Common/Rule/Recognizer.hs view
@@ -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 2019, 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,20 +9,17 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Recognizer.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rule.Recognizer
    ( -- * data type and type class
      Recognizable(..), Recognizer
      -- * Constructor functions
-   , makeRecognizer, makeRecognizerEnvMonad, makeRecognizerTrans
+   , makeRecognizer, makeRecognizerTrans
    ) where
 
-import Control.Monad
 import Data.Maybe
-import Data.Monoid
+import Data.Semigroup as Sem
 import Ideas.Common.Environment
-import Ideas.Common.Rule.EnvironmentMonad
 import Ideas.Common.Rule.Transformation
 import Ideas.Common.View
 
@@ -46,9 +43,12 @@       let f = fmap fst . match v
       in R $ makeTrans f *** makeTrans f >>> unR r
 
+instance Sem.Semigroup (Recognizer a) where
+   f <> g = R $ unR f `mappend` unR g
+
 instance Monoid (Recognizer a) where
-   mempty      = R mempty
-   mappend f g = R $ unR f `mappend` unR g
+   mempty  = R mempty
+   mappend = (<>)
 
 instance Recognizable Recognizer where
    recognizer = id
@@ -60,10 +60,8 @@ --- Constructor functions
 
 makeRecognizer :: (a -> a -> Bool) -> Recognizer a
-makeRecognizer eq = makeRecognizerEnvMonad $ \a b -> guard (eq a b)
-
-makeRecognizerEnvMonad :: (a -> a -> EnvMonad ()) -> Recognizer a
-makeRecognizerEnvMonad = makeRecognizerTrans . makeTrans . uncurry
+makeRecognizer eq = makeRecognizerTrans $ transMaybe $ \(x, y) ->
+   if eq x y then Just () else Nothing
 
 makeRecognizerTrans :: Trans (a, a) () -> Recognizer a
 makeRecognizerTrans = R
src/Ideas/Common/Rule/Transformation.hs view
@@ -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 2019, 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,54 +13,55 @@ -- a list of results (often a singleton list or the empty list).
 --
 -----------------------------------------------------------------------------
---  $Id: Transformation.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Rule.Transformation
    ( -- * Trans data type
      Transformation, Trans
      -- * Constructor functions
    , MakeTrans(..)
-   , transPure, transMaybe, transList, transEnvMonad
-   , transRewrite, transRef
+   , transPure, transMaybe, transList, transGuard, transRewrite
+     -- * Reading and writing (with references)
+   , readRef, readRefDefault, readRefMaybe
+   , writeRef, writeRef_, writeRefMaybe
      -- * Lifting transformations
    , transUseEnvironment
    , transLiftView, transLiftViewIn
    , transLiftContext, transLiftContextIn
-   , makeTransLiftContext, makeTransLiftContext_
      -- * Using transformations
    , transApply, transApplyWith
-   , getRewriteRules, isZeroTrans
+   , getRewriteRules
    ) where
 
+import Control.Applicative
 import Control.Arrow
 import Data.Maybe
-import Data.Monoid
-import Data.Typeable
+import Data.Semigroup as Sem
 import Ideas.Common.Classes
 import Ideas.Common.Context
 import Ideas.Common.Environment
 import Ideas.Common.Rewriting
-import Ideas.Common.Rule.EnvironmentMonad
-import Ideas.Common.Utils
 import Ideas.Common.View
+import Ideas.Utils.Prelude
 import qualified Control.Category as C
 
 -----------------------------------------------------------
 --- Trans data type and instances
 
+type Transformation a = Trans a a
+
 data Trans a b where
    Zero     :: Trans a b
    List     :: (a -> [b]) -> Trans a b
    Rewrite  :: RewriteRule a -> Trans a a
-   EnvMonad :: (a -> EnvMonad b) -> Trans a b
-   Ref      :: Typeable a => Ref a -> Trans a a
    UseEnv   :: Trans a b -> Trans (a, Environment) (b, Environment)
    (:>>:)   :: Trans a b -> Trans b c -> Trans a c
    (:**:)   :: Trans a c -> Trans b d -> Trans (a, b) (c, d)
    (:++:)   :: Trans a c -> Trans b d -> Trans (Either a b) (Either c d)
-   Apply    :: Trans (Trans a b, a) b
    Append   :: Trans a b -> Trans a b -> Trans a b
 
+   ReadRefM  :: Ref a -> Trans x (Maybe a)
+   WriteRefM :: Ref a -> Trans (Maybe a) ()
+
 instance C.Category Trans where
    id  = arr id
    (.) = flip (:>>:)
@@ -82,15 +83,24 @@    left f  = f :++: identity
    right f = identity :++: f
 
-instance ArrowApply Trans where
-   app = Apply
+instance Sem.Semigroup (Trans a b) where
+   (<>) = (<+>)
 
 instance Monoid (Trans a b) where
    mempty  = zeroArrow
-   mappend = (<+>)
+   mappend = (<>)
 
-type Transformation a = Trans a a
+instance Functor (Trans a) where
+   fmap f t = t >>^ f
 
+instance Applicative (Trans a) where
+   pure    = transPure . const
+   s <*> t = (s &&& t) >>^ uncurry ($)
+
+instance Alternative (Trans a) where
+   empty = zeroArrow
+   (<|>) = (<+>)
+
 -----------------------------------------------------------
 --- Constructor functions
 
@@ -105,9 +115,6 @@ instance MakeTrans [] where
    makeTrans = transList
 
-instance MakeTrans EnvMonad where
-   makeTrans = transEnvMonad
-
 transPure :: (a -> b) -> Trans a b
 transPure f = transList (return . f)
 
@@ -117,17 +124,35 @@ transList :: (a -> [b]) -> Trans a b
 transList = List
 
-transEnvMonad :: (a -> EnvMonad b) -> Trans a b
-transEnvMonad = EnvMonad
+transGuard :: (a -> Bool) -> Trans a a
+transGuard p = transMaybe $ \x -> if p x then Just x else Nothing
 
 transRewrite :: RewriteRule a -> Trans a a
 transRewrite = Rewrite
 
-transRef :: Typeable a => Ref a -> Trans a a
-transRef = Ref
+-----------------------------------------------------------
+-- Reading and writing (with references)
 
+readRef :: Ref a -> Trans x a
+readRef r = readRefMaybe r >>> transMaybe id
+
+readRefDefault :: a -> Ref a -> Trans x a
+readRefDefault a r = readRefMaybe r >>^ fromMaybe a
+
+readRefMaybe  :: Ref a -> Trans x (Maybe a)
+readRefMaybe = ReadRefM
+
+writeRef :: Ref a -> Trans a a
+writeRef r = (identity &&& writeRef_ r) >>^ fst
+
+writeRef_ :: Ref a -> Trans a ()
+writeRef_ r = Just ^>> writeRefMaybe r
+
+writeRefMaybe :: Ref a -> Trans (Maybe a) ()
+writeRefMaybe = WriteRefM
+
 -----------------------------------------------------------
---- Lifting transformations
+-- Lifting transformations
 
 transUseEnvironment :: Trans a b -> Trans (a, Environment) (b, Environment)
 transUseEnvironment = UseEnv
@@ -136,7 +161,7 @@ transLiftView v = transLiftViewIn (v &&& identity)
 
 transLiftViewIn :: View a (b, c) -> Transformation b -> Transformation a
-transLiftViewIn v f = makeTrans (match v) >>> first f >>> arr (build v)
+transLiftViewIn v f = makeTrans (match v) >>> first f >>^ build v
 
 transLiftContext :: Transformation a -> Transformation (Context a)
 transLiftContext = transLiftContextIn . transUseEnvironment
@@ -147,14 +172,6 @@    f (a, c)        = ((a, environment c), c)
    g ((a, env), c) = (a, setEnvironment env c)
 
--- | Overloaded variant of @transLiftContext@
-makeTransLiftContext :: MakeTrans f => (a -> f a) -> Transformation (Context a)
-makeTransLiftContext = transLiftContext . makeTrans
-
--- | Overloaded variant of @transLiftContext@; ignores result
-makeTransLiftContext_ :: MakeTrans f => (a -> f ()) -> Transformation (Context a)
-makeTransLiftContext_ f = transLiftContext (identity &&& makeTrans f >>> arr fst)
-
 -----------------------------------------------------------
 --- Using transformations
 
@@ -167,21 +184,18 @@       Zero       -> []
       List f     -> [ (b, env) | b <- f a ]
       Rewrite r  -> [ (b, env) | b <- applyAll r a ]
-      EnvMonad f -> runEnvMonad (f a) env
-      Ref ref    -> case ref ? env of
-                       Just b  -> [(b, env)]
-                       Nothing -> [(a, insertRef ref a env)]
       UseEnv f   -> do (b, envb) <- transApplyWith (snd a) f (fst a)
                        return ((b, envb), env)
       f :>>: g   -> do (b, env1) <- transApplyWith env  f a
                        (c, env2) <- transApplyWith env1 g b
                        return (c, env2)
       f :**: g   -> do (b, env1) <- transApplyWith env f (fst a)
-                       (c, env2) <- transApplyWith env g (snd a)
-                       return ((b, c), env2 `mappend` env1)
+                       (c, env2) <- transApplyWith env1 g (snd a)
+                       return ((b, c), env2)
       f :++: g   -> either (make Left f) (make Right g) a
-      Apply      -> uncurry (transApplyWith env) a
       Append f g -> transApplyWith env f a ++ transApplyWith env g a
+      ReadRefM r  -> [(r ? env, env)]
+      WriteRefM r -> [((), maybe (deleteRef r) (insertRef r) a env)]
  where
    make :: (b -> c) -> Trans a b -> a -> [(c, Environment)]
    make f g = map (mapFirst f) . transApplyWith env g
@@ -195,27 +209,17 @@ instance HasRefs (Trans a b) where
    allRefs trans =
       case trans of
-         Ref r      -> [Some r]
-         EnvMonad f -> envMonadFunctionRefs f
-         _          -> descendTrans allRefs trans
-
-isZeroTrans :: Trans a b -> Bool
-isZeroTrans = or . rec
- where
-   rec :: Trans a b -> [Bool]
-   rec trans =
-      case trans of
-         Zero       -> [True]
-         Append f g -> [isZeroTrans f && isZeroTrans g]
-         _          -> descendTrans rec trans
+         ReadRefM r  -> [Some r]
+         WriteRefM r -> [Some r]
+         _           -> descendTrans allRefs trans
 
 -- General recursion function (existentially quantified)
 descendTrans :: Monoid m => (forall x y . Trans x y -> m) -> Trans a b -> m
 descendTrans make trans =
    case trans of
-      UseEnv f   -> make f
-      f :>>: g   -> make f `mappend` make g
-      f :**: g   -> make f `mappend` make g
-      f :++: g   -> make f `mappend` make g
-      Append f g -> make f `mappend` make g
-      _          -> mempty+      UseEnv f     -> make f
+      f :>>: g     -> make f `mappend` make g
+      f :**: g     -> make f `mappend` make g
+      f :++: g     -> make f `mappend` make g
+      Append f g   -> make f `mappend` make g
+      _            -> mempty
src/Ideas/Common/Strategy.hs view
@@ -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 2019, 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,12 @@ -- 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 $
 
 module Ideas.Common.Strategy
    ( -- * Data types and type classes
@@ -24,27 +24,27 @@    , derivationList
      -- * Strategy combinators
      -- ** Basic combinators
-   , (<*>), (<|>), (<%>), succeed, fail, atomic, label
-   , sequence, alternatives, interleave, permute, fix
+   , (.*.), (.|.), (.%.), (.@.), (!~>)
+   , succeed, fail, atomic, label, inits
+   , sequence, choice, preference, orelse
+   , 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, dynamic
      -- ** 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 ()
src/Ideas/Common/Strategy/Abstract.hs view
@@ -1,55 +1,90 @@-{-# 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 2019, 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 $
 
 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 Data.Maybe
 import Ideas.Common.Classes
 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.CyclicTree hiding (label)
+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.View
+import Prelude hiding (sequence)
+import qualified Ideas.Common.Strategy.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 +95,28 @@ 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 . LeafRule
 
 instance IsStrategy RewriteRule where
    toStrategy = toStrategy . ruleRewrite
 
+instance IsStrategy Dynamic where
+   toStrategy = S . leaf . LeafDyn
+
+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 +146,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 +165,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,66 +176,71 @@ 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 = concatMap f (toList (toStrategyTree s))
+ where
+   f (LeafRule r) | isMajor r = [r]
+   f _ = []
 
 instance LiftView LabeledStrategy where
-   liftViewIn = mapRules . liftViewIn
+   liftViewIn v (LS n s) = LS n (liftViewIn v s)
 
 instance LiftView Strategy where
-   liftViewIn = mapRulesS . liftViewIn
+   liftViewIn v = S . fmap (liftViewIn v) . toStrategyTree
 
 -- | Apply a function to all the rules that make up a labeled strategy
-mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b
+mapRules :: (Rule a -> Rule a) -> LabeledStrategy a -> LabeledStrategy a
 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 :: (Rule a -> Rule a) -> Strategy a -> Strategy a
+mapRulesS = onStrategyTree . mapRulesInTree
 
 -- | 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 (Leaf a)
+getProcess = treeToProcess . 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
src/Ideas/Common/Strategy/Choice.hs view
@@ -1,69 +1,72 @@ -----------------------------------------------------------------------------
--- 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 2019, 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 $
 
 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 +74,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 +98,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 +110,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 +156,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)
src/Ideas/Common/Strategy/Combinators.hs view
@@ -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 2019, 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 $
 
 module Ideas.Common.Strategy.Combinators where
 
-import Data.Array
 import Data.Graph
 import Data.List ((\\))
+import Data.Maybe
 import Ideas.Common.Id
+import Ideas.Common.Rewriting (IsTerm)
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Abstract
-import Ideas.Common.Strategy.Core
-import Ideas.Common.Utils (fst3)
+import Ideas.Common.Strategy.CyclicTree hiding (label)
+import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.StrategyTree
+import Ideas.Utils.Prelude (fst3, thd3)
 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,98 @@ 
 -- 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
 
+-- | Combines a list of strategies with left-preference
+preference :: IsStrategy f => [f a] -> Strategy a
+preference = Choice.preference . map toStrategy
+
+-- | Combines a list of strategies with left-biased choice
+orelse :: IsStrategy f => [f a] -> Strategy a
+orelse = Choice.orelse . 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,74 +140,63 @@ -- | 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 $ LeafRule $ 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
+exhaustive = declN $ "exhaustive" .=. Nary Derived.exhaustive
 
-hide :: IsStrategy f => f a -> Strategy a
-hide = liftCore Hide
+-- | The structure of a dynamic strategy depends on the current term
+dynamic :: (IsId n, IsStrategy f, IsTerm a) => n -> (a -> f a) -> Strategy a
+dynamic n f = toStrategy $ makeDynamic n (toStrategyTree . f)
 
 -- Graph to strategy ----------------------
 
-type DependencyGraph node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
+type DependencyGraph node key = [(node, key, [key])]
 
 -- | Create a strategy from a dependency graph with strategies as nodes
 -- Does not check for cycles
-dependencyGraph:: IsStrategy f => DependencyGraph (f a) key -> Strategy a
-dependencyGraph (graph, vertex2data, _) = g2s []
+dependencyGraph:: (IsStrategy f, Ord key) => DependencyGraph (f a) key -> Strategy a
+dependencyGraph = make . graphFromEdges
+ where
+   make (graph, vertex2data, key2data) = rec []
     where
-        g2s seen
-            | null reachables   = succeed
-            | otherwise         = alternatives $ map makePath reachables
-            where
-               reachables      = filter isReachable $ vertices graph \\ seen
-               isReachable     = null . (\\ seen) . (graph!)
-               makePath vertex = (fst3 . vertex2data) vertex <*> g2s (vertex:seen)+      rec seen
+         | null reachables = succeed
+         | otherwise       = choice $ map makePath reachables
+       where
+         reachables  = filter isReachable $ vertices graph \\ seen
+         isReachable = null . (\\ seen) . mapMaybe key2data . thd3 . vertex2data
+         makePath v  = fst3 (vertex2data v) .*. rec (v:seen)
src/Ideas/Common/Strategy/Configuration.hs view
@@ -1,29 +1,40 @@+{-# 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 2019, 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 $
 
 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 Data.Semigroup as Sem
+import Ideas.Common.Classes
 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.CyclicTree hiding (label)
+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.Strategy.CyclicTree as Tree
 
 ---------------------------------------------------------------------
 -- Types and constructors
@@ -33,12 +44,15 @@ instance Show StrategyCfg where
    show (Cfg xs) = show xs
 
+instance Sem.Semigroup StrategyCfg where
+   (Cfg xs) <> (Cfg ys) = Cfg (xs ++ ys)
+
 instance Monoid StrategyCfg where
    mempty  = Cfg []
    mconcat xs = Cfg [ y | Cfg ys <- xs, y <- ys ]
-   mappend (Cfg xs) (Cfg ys) = Cfg (xs ++ ys)
+   mappend = (<>)
 
-data ConfigLocation = ByName Id
+newtype ConfigLocation = ByName Id
 
 instance Show ConfigLocation where
    show (ByName a) = show a
@@ -64,45 +78,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 f
  where
-   rec (g:gs)
-      | x `elem` g = filter (`notElem` g) xs
-      | otherwise  = rec gs
-   rec [] = xs+   f a = case firsts a of
+            [(LeafRule r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r)
+            _ -> empty
+   collapseWith l =
+      single . LeafRule . makeRule l . runProcess
+
+hideDecl :: Decl Unary
+hideDecl = "hidden" .=. Unary (fmap minor)
− src/Ideas/Common/Strategy/Core.hs 
@@ -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)
+ src/Ideas/Common/Strategy/CyclicTree.hs view
@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Strategy.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.Monad
+import Data.List (intercalate)
+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 = (<$> 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 -> fmap (node a) . sequenceA
+      , fLeaf  = fmap leaf . f
+      , fLabel = fmap . label
+      , fRec   = fmap . 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, leaf <$> arbitrary)
+      : [ (1, elements (map Var [1..vi])) | vi > 0 ]
+   rec vi n = frequency
+      [ (3, node <$> arbitrary <*> ms)
+      , (2, rec vi 0)
+      , (1, label <$> genId <*> m)
+      , (1, 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
src/Ideas/Common/Strategy/Derived.hs view
@@ -1,62 +1,125 @@+{-# LANGUAGE 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 2019, 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 $
 
 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
+   , (<@>), (!*>), 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 => (a -> Bool) -> (Process a -> Process a) -> Process a -> Process a
+split skipCond cont = rec (0 :: Int)
+ where
+   rec n = withMenu op empty
+    where
+      op a = a ~> rest
+       where
+         next | a == atomicOpen  = n+1
+              | a == atomicClose = n-1
+              | otherwise        = n
+         rest | skipCond a       = rec next
+              | next > 0         = rec next
+              | otherwise        = cont
 
+-- atomic prefix
+(!*>) :: AtomicSymbol a => Process a -> Process a -> Process a
+a !*> p = atomicOpen ~> a .*. withMenu op (single atomicClose) p
+ where
+   op b q
+      | b == atomicOpen = q
+      | otherwise       = b ~> atomicClose ~> 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
+interleave :: (AtomicSymbol a, LabelSymbol a) => [Process a] -> Process a
+interleave xs = if null xs then done else foldr1 (<%>) xs
+
+-- interleaving
+(<%>) :: (AtomicSymbol a, LabelSymbol a) => Process a -> Process a -> Process a
+p <%> q =
+   bothAreDone p q .|. ((p %>> q) .|. (q %>> p))
  where
-   f (Single a)   = (a ~>)
-   f (Composed p) = (p <*>)
+   bothAreDone = withMenu stop2 . withMenu stop2 done
+   stop2 _ _   = empty
+   r %>> s     = split isEnterSymbol (<%> s) r
 
-atomic :: IsProcess f => f (Sym a) -> f (Sym a)
-atomic = single . Composed . fromAtoms . toProcess
+-- | 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 ]
 
-concurrent :: IsProcess f => (a -> Bool) -> f a -> f a -> f a
-concurrent switch x y = normal (toProcess x) (toProcess y)
+-- Alternate combinator
+(<@>) :: AtomicSymbol a => Process a -> Process a -> Process a
+p <@> q = bothOk p q .|. (p @>> q)
  where
-   normal p q = stepBoth q p <|> (stepRight q p <|> stepRight p q)
+   bothOk  = withMenu (\_ _ -> empty) done
+   r @>> s = split (const False) (s <@>) r
 
-   stepBoth  = useFirst stop2 . useFirst stop2 done
-   stop2 _ _ = empty
+inits :: AtomicSymbol a => Process a -> Process a
+inits p = done .|. split (const False) inits p
 
-   stepRight p = useFirst op empty
-    where
-      op a = (a ~>) . (if switch a then normal else stepRight) p
+many :: (Sequence a, Fix a, Choice a) => a -> a
+many s = fix $ \x -> done .|. (s .*. x)
 
--- Alternate combinator
-(<@>) :: IsProcess f => f a -> f a -> f a
-p0 <@> q0 = rec (toProcess q0) (toProcess p0)
- where
-   rec q  = useFirst (\a r -> a ~> rec r q) (bothOk q)
-   bothOk = useFirst (\_ _ -> empty) done
+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
 
 ---------------------------------------------------------------------------
+ src/Ideas/Common/Strategy/Legacy.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+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
src/Ideas/Common/Strategy/Location.hs view
@@ -1,17 +1,16 @@ -----------------------------------------------------------------------------
--- 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 2019, 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 $
 
 module Ideas.Common.Strategy.Location
    ( checkLocation, subTaskLocation, nextTaskLocation
@@ -19,11 +18,9 @@    ) where
 
 import Data.Maybe
-import Ideas.Common.Classes
 import Ideas.Common.Id
 import Ideas.Common.Strategy.Abstract
-import Ideas.Common.Strategy.Core
-import Ideas.Common.Utils.Uniplate
+import Ideas.Common.Strategy.CyclicTree
 
 -----------------------------------------------------------
 --- Strategy locations
@@ -57,17 +54,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))
− src/Ideas/Common/Strategy/Parsing.hs 
@@ -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 ';'
+ src/Ideas/Common/Strategy/Prefix.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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.
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Strategy.Prefix
+   ( -- * Prefix
+     Prefix, noPrefix, makePrefix, firstsOrdered
+   , replayProcess
+   , isEmptyPrefix, majorPrefix, searchModePrefix, prefixPaths
+     -- * Path
+   , Path, emptyPath, readPath, readPaths
+   ) where
+
+import Data.Char
+import Data.List (intercalate)
+import Data.Maybe
+import Data.Semigroup as Sem
+import Ideas.Common.Classes
+import Ideas.Common.Environment
+import Ideas.Common.Rewriting.Term
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Strategy.StrategyTree
+import Ideas.Utils.Prelude (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 Sem.Semigroup (Prefix a) where
+   (Prefix xs p) <> (Prefix ys q) = Prefix (xs ++ ys) (p .|. q)
+
+instance Monoid (Prefix a) where
+   mempty  = noPrefix
+   mappend = (<>)
+
+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 (Leaf 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 (Leaf a) -> ([Rule a], a -> Prefix a)
+replayProcess (Path is) = fromMaybe ([], const noPrefix) . replay [] is
+ where
+   replay acc path p =
+      case path of
+         []         -> return (reverse acc, createPrefix p)
+         Input _:_  -> Nothing
+         Index n:ns -> do
+            (leaf, q) <- getByIndex n (menu p)
+            case (leaf, ns) of
+               (LeafRule r, _) -> replay (r:acc) ns q
+               (LeafDyn d, Input t:ns2) -> do
+                  a <- dynamicFromTerm d t
+                  replay acc ns2 (treeToProcess a .*. q)
+               _ -> Nothing
+
+   createPrefix p = Prefix [Path is] . flip (rec []) p
+
+   rec ns a = cut . onMenuWithIndex f doneMenu . menu
+    where
+      f n (LeafDyn d) p = fromMaybe empty $ do
+         t <- dynamicToTerm d a
+         s <- dynamicFromTerm d t
+         return (rec (Input t:Index n:ns) a (treeToProcess s .*. p))
+      f n (LeafRule r) p = choice
+         [ r ?~> (b, env, mk b)
+         | (b, env) <- transApply (transformation r) a
+         ]
+       where
+         ms   = Index 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 and terms (the latter act as input for the dynamic strategies).
+newtype Path = Path [PathItem]
+   deriving Eq
+
+data PathItem = Index Int | Input Term
+   deriving Eq
+
+instance Show PathItem where
+   show (Index n) = show n
+   show (Input t) = show t
+
+instance Read PathItem where
+   readsPrec n s =
+      case dropWhile isSpace s of
+         s2@(c:_) | isDigit c -> map (mapFirst Index) (readsPrec n s2)
+         s2 -> map (mapFirst Input) (readsPrec n s2)
+
+instance Show Path where
+   show (Path is) = show is
+   showList = (++) . intercalate ";" . map show
+
+-- | The empty path.
+emptyPath :: Path
+emptyPath = Path []
+
+readPath :: Monad m => String -> m Path
+readPath = fmap Path . readM
+
+readPaths :: Monad m => String -> m [Path]
+readPaths = mapM readPath . splitsWithElem ';'
src/Ideas/Common/Strategy/Process.hs view
@@ -1,156 +1,92 @@ {-# 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 2019, 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 $
 
 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
src/Ideas/Common/Strategy/Sequence.hs view
@@ -1,46 +1,56 @@ {-# 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 2019, 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 $
 
 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 +59,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 ]
+ src/Ideas/Common/Strategy/StrategyTree.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RankNTypes, ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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.
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Strategy.StrategyTree
+   ( -- * StrategyTree type synonym
+     StrategyTree, Leaf(..), treeToProcess, mapRulesInTree
+     -- * Declarations (named combinators)
+   , Decl, Combinator, associative, isAssociative, combinator
+   ,  (.=.), applyDecl
+     -- * Dynamic strategies
+   , Dynamic, makeDynamic, dynamicToTerm, dynamicTree, dynamicFromTerm
+     -- * Arities
+   , Arity(..), Nullary(..), Unary(..), Binary(..), Nary(..)
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.Maybe
+import Ideas.Common.Classes
+import Ideas.Common.Id
+import Ideas.Common.Rewriting.Term (Term, IsTerm(..))
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.CyclicTree
+import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Strategy.Symbol
+import Ideas.Common.View
+
+infix 1 .=.
+
+------------------------------------------------------------------------------
+
+type StrategyTree a = CyclicTree (Decl Nary) (Leaf a)
+
+data Leaf a = LeafRule (Rule a)
+            | LeafDyn  (Dynamic a)
+
+instance Show (Leaf a) where
+   show = showId
+
+instance Eq (Leaf a) where
+   x == y = getId x == getId y
+
+instance HasId (Leaf a) where
+   getId      (LeafRule r) = getId r
+   getId      (LeafDyn d)  = getId d
+   changeId f (LeafRule r) = LeafRule (changeId f r)
+   changeId f (LeafDyn d)  = LeafDyn (changeId f d)
+
+instance AtomicSymbol (Leaf a) where
+   atomicOpen  = LeafRule atomicOpen
+   atomicClose = LeafRule atomicClose
+
+instance LabelSymbol (Leaf a) where
+   isEnterSymbol (LeafRule r) = isEnterSymbol r
+   isEnterSymbol (LeafDyn _)  = False
+
+instance Minor (Leaf a) where
+   isMinor    (LeafRule r)   = isMinor r
+   isMinor    (LeafDyn _)    = False
+   setMinor b (LeafRule r)   = LeafRule (setMinor b r)
+   setMinor _ lf@(LeafDyn _) = lf
+
+instance Apply Leaf where
+   applyAll (LeafRule r) a    = applyAll r a
+   applyAll (LeafDyn d) a = applyAll d a
+
+instance LiftView Leaf where
+   liftViewIn v (LeafRule r) = LeafRule (liftViewIn v r)
+   liftViewIn v (LeafDyn d)  = LeafDyn  (liftViewIn v d)
+
+treeToProcess :: StrategyTree a -> Process (Leaf a)
+treeToProcess = foldUnwind emptyAlg
+   { fNode  = fromNary . combinator
+   , fLeaf  = single
+   , fLabel = \l p -> LeafRule (enterRule l) ~> p .*. (LeafRule (exitRule l) ~> done)
+   }
+
+mapRulesInTree :: (Rule a -> Rule a) -> StrategyTree a -> StrategyTree a
+mapRulesInTree f = inTree
+ where
+   inTree = fmap inLeaf
+
+   inLeaf (LeafRule r) = LeafRule (f r)
+   inLeaf (LeafDyn d)  = LeafDyn (inDyn d)
+
+   inDyn d = d { dynamicFromTerm = fmap inTree . dynamicFromTerm d }
+
+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]
+
+------------------------------------------------------------------------------
+
+data Dynamic a = Dyn
+   { dynamicId       :: Id
+   , dynamicToTerm   :: a -> Maybe Term
+   , dynamicFromTerm :: Term -> Maybe (StrategyTree a)
+   }
+
+instance HasId (Dynamic a) where
+   getId = dynamicId
+   changeId f d = d { dynamicId = changeId f (dynamicId d) }
+
+instance Apply Dynamic where
+   applyAll d a = maybe [] ((`runProcess` a) . treeToProcess) (dynamicTree d a)
+
+instance LiftView Dynamic where
+   liftViewIn v d = d
+      { dynamicToTerm   = fmap fst . match v >=> dynamicToTerm d
+      , dynamicFromTerm = fmap (fmap (liftViewIn v)) . dynamicFromTerm d
+      }
+
+makeDynamic :: (IsId n, IsTerm a) => n -> (a -> StrategyTree a) -> Dynamic a
+makeDynamic n f = Dyn (newId n) (Just . toTerm) (fmap f . fromTerm)
+
+dynamicTree :: Dynamic a -> a -> Maybe (StrategyTree a)
+dynamicTree d = dynamicToTerm d >=> dynamicFromTerm d
+
+------------------------------------------------------------------------------
+
+type Combinator f = forall a . f (Process (Leaf 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
+
+newtype Nullary a = Nullary { fromNullary :: a }
+newtype Unary   a = Unary   { fromUnary   :: a -> a }
+newtype Binary  a = Binary  { fromBinary  :: a -> a -> a }
+newtype 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))
+ src/Ideas/Common/Strategy/Symbol.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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.
+--
+-----------------------------------------------------------------------------
+
+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
src/Ideas/Common/Strategy/Traversal.hs view
@@ -1,36 +1,45 @@ -----------------------------------------------------------------------------
--- 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 2019, 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 $
 
 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 Data.Monoid hiding ((<>))
+import Data.Semigroup ((<>))
+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 Prelude hiding (repeat, not, traverse)
+import qualified Data.Semigroup as Sem
+import qualified Prelude
 
 ----------------------------------------------------------------------
 -- One-layer combinators
@@ -40,11 +49,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 +63,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 +72,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,37 +80,40 @@ 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 }
 
+instance Sem.Semigroup (Option a) where
+   O f <> O g = O (f . g)
+
 instance Monoid (Option a) where
-   mempty            = O id
-   O f `mappend` O g = O (f . g)
+   mempty  = O id
+   mappend = (<>)
 
 fromOptions :: [Option a] -> Info a
 fromOptions xs = unO (mconcat xs) (Info VisitOne Choice [] True False)
@@ -115,20 +127,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 +163,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
src/Ideas/Common/Traversal/Iterator.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Iterator.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Traversal.Iterator
    ( -- * Iterator type class
src/Ideas/Common/Traversal/Navigator.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Navigator.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Traversal.Navigator
    ( -- * Location information
@@ -36,11 +35,11 @@ import Data.Function
 import Data.Generics.Str
 import Data.Maybe
-import Ideas.Common.Algebra.Group
+import Data.Semigroup as Sem
 import Ideas.Common.Traversal.Iterator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.Uniplate
-import Test.QuickCheck hiding (Str)
+import Ideas.Utils.Uniplate
+import Test.QuickCheck
 
 ---------------------------------------------------------------
 -- Navigator type class
@@ -51,9 +50,12 @@ instance Show Location where
    show = show . fromLocation
 
+instance Sem.Semigroup Location where
+   L xs <> L ys = L (xs ++ ys)
+
 instance Monoid Location where
-   mempty = L []
-   L xs `mappend` L ys = L (xs ++ ys)
+   mempty  = L []
+   mappend = (<>)
 
 toLocation :: [Int] -> Location
 toLocation = L
@@ -71,7 +73,7 @@    childnr  :: a -> Int
    location :: a -> Location
    -- default definitions
-   downLast = liftM (fixp right) . down
+   downLast = fmap (fixp right) . down
    childnr  = pred . length . fixpl left
    location = toLocation . map childnr . drop 1 . reverse . fixpl up
 
@@ -175,7 +177,7 @@    update a = (unwrap a, wrap)
 
 instance Navigator a => Iterator (PreOrder a) where
-   previous = liftWrapper ((liftM rightMostLeaf . left) >|< up)
+   previous = liftWrapper ((fmap rightMostLeaf . left) >|< up)
    next     = let rec = right >|< (up >=> rec)
               in liftWrapper (down >|< rec)
    first    = mapWrapper top
@@ -251,10 +253,10 @@ instance Navigator a => Iterator (Leafs a) where
    previous = liftWrapper $
       let rec = left >|< (up >=> rec)
-      in liftM rightMostLeaf . rec
+      in fmap rightMostLeaf . rec
    next = liftWrapper $
       let rec = right >|< (up >=> rec)
-      in liftM leftMostLeaf . rec
+      in fmap leftMostLeaf . rec
    first = mapWrapper (leftMostLeaf . top)
    final = mapWrapper (rightMostLeaf . top)
 
@@ -302,8 +304,8 @@    }
 
 instance Iterator (StrIterator a) where
-   next     (SI n a) = liftM (SI (n+1)) $ searchNext ok a
-   previous (SI n a) = liftM (SI (n-1)) $ searchPrevious ok a
+   next     (SI n a) = SI (n+1) <$> searchNext ok a
+   previous (SI n a) = SI (n-1) <$> searchPrevious ok a
    first    (SI _ a) = SI 0 $ safe (searchForward ok) (first a)
    final    (SI _ a) = finalSI $ safe (searchBackward ok) (final a)
    position          = posSI
@@ -352,8 +354,8 @@    down     = downWith focusM
    downLast = downWith lastStrIterator
 
-   left  (U fs a) = liftM (U fs) (previous a)
-   right (U fs a) = liftM (U fs) (next a)
+   left  (U fs a) = U fs <$> previous a
+   right (U fs a) = U fs <$> next a
 
    childnr (U _ a) = position a
 
@@ -366,7 +368,7 @@    unfocus = current . top
 
 instance (Arbitrary a, Uniplate a) => Arbitrary (UniplateNavigator a) where
-   arbitrary = liftM focus arbitrary >>= genNav
+   arbitrary = fmap focus arbitrary >>= genNav
     where
       genNav a =
          case map genNav (downs a) of
@@ -375,7 +377,7 @@ 
 downWith :: Uniplate a => (Str a -> Maybe (StrIterator a))
                        -> UniplateNavigator a -> Maybe (UniplateNavigator a)
-downWith make (U fs a) = liftM (U (f:fs)) (make cs)
+downWith make (U fs a) = U (f:fs) <$> make cs
  where
    (cs, g) = uniplate (current a)
    f = (`replace` a) . g . unfocus
src/Ideas/Common/Traversal/Tests.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Tests.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Traversal.Tests
    ( testIterator, testNavigator, tests
@@ -18,12 +17,13 @@ 
 import Control.Monad
 import Data.Maybe
+import Data.Semigroup as Sem
 import Ideas.Common.Traversal.Iterator
 import Ideas.Common.Traversal.Navigator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.TestSuite
-import Ideas.Common.Utils.Uniplate
-import Test.QuickCheck
+import Ideas.Utils.TestSuite
+import Ideas.Utils.Uniplate
+import Test.QuickCheck hiding ((===))
 
 testIterator :: (Show a, Eq a, Iterator a) => String -> Gen a -> TestSuite
 testIterator s gen = suite (s ++ " Iterator")
@@ -73,8 +73,8 @@         ]
 
    , suite "down/downLast"
-        [ prop gen "down; rightMost"       $  liftM rightMost . down === downLast
-        , prop gen "downLast; leftMost"    $  liftM leftMost . downLast === down
+        [ prop gen "down; rightMost"       $  fmap rightMost . down === downLast
+        , prop gen "downLast; leftMost"    $  fmap leftMost . downLast === down
         , prop gen "down is leftMost"      $  isNothing . (down >=> left)
         , prop gen "downLast is rightMost" $  isNothing . (downLast >=> right)
         ]
@@ -105,16 +105,16 @@ tests =
    suite "Iterators"
       [ testIterator "List" listGen
-      , testIterator "Mirror"     $ liftM makeMirror     listGen
-      , testIterator "Leafs"      $ liftM makeLeafs      uniGen
-      , testIterator "PreOrder"   $ liftM makePreOrder   uniGen
-      , testIterator "PostOrder"  $ liftM makePostOrder  uniGen
-      , testIterator "Horizontal" $ liftM makeHorizontal uniGen
-      , testIterator "LevelOrder" $ liftM makeLevelOrder uniGen
+      , testIterator "Mirror"     $ makeMirror     <$> listGen
+      , testIterator "Leafs"      $ makeLeafs      <$> uniGen
+      , testIterator "PreOrder"   $ makePreOrder   <$> uniGen
+      , testIterator "PostOrder"  $ makePostOrder  <$> uniGen
+      , testIterator "Horizontal" $ makeHorizontal <$> uniGen
+      , testIterator "LevelOrder" $ makeLevelOrder <$> uniGen
       ] <>
    suite "Navigators"
       [ testNavigator "Uniplate" uniGen
-      , testNavigator "Mirror" $ liftM makeMirror uniGen
+      , testNavigator "Mirror" $ makeMirror <$> uniGen
       ]
 
 _go :: IO ()
src/Ideas/Common/Traversal/Utils.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Utils.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.Traversal.Utils
    ( -- * Update type class
@@ -47,7 +46,7 @@ changeM = changeG
 
 changeG :: (Update f, Monad g) => (a -> g a) -> f a -> g (f a)
-changeG f a = liftM (`replace` a) (f (current a))
+changeG f a = (`replace` a) <$> f (current a)
 
 ---------------------------------------------------------------
 -- Focus type class
@@ -62,10 +61,10 @@    focusM = Just . focus
 
 liftFocus :: Focus a => (Unfocus a -> Maybe (Unfocus a)) -> a -> Maybe a
-liftFocus f = liftM focus . f . unfocus
+liftFocus f = fmap focus . f . unfocus
 
 unliftFocus :: Focus a => (a -> Maybe a) -> Unfocus a -> Maybe (Unfocus a)
-unliftFocus f = liftM unfocus . f . focus
+unliftFocus f = fmap unfocus . f . focus
 
 ---------------------------------------------------------------
 -- Wrapper type class
@@ -75,10 +74,10 @@    unwrap :: f a -> a
 
 liftWrapper :: (Monad m, Wrapper f) => (a -> m a) -> f a -> m (f a)
-liftWrapper f = liftM wrap . f . unwrap
+liftWrapper f = fmap wrap . f . unwrap
 
 unliftWrapper :: (Monad m, Wrapper f) => (f a -> m (f a)) -> a -> m a
-unliftWrapper f = liftM unwrap . f . wrap
+unliftWrapper f = fmap unwrap . f . wrap
 
 mapWrapper :: Wrapper f => (a -> a) -> f a -> f a
 mapWrapper f = wrap . f . unwrap
− src/Ideas/Common/Utils.hs 
@@ -1,131 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A collection of general utility functions
---
------------------------------------------------------------------------------
---  $Id: Utils.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Utils
-   ( Some(..), ShowString(..), readInt, readM
-   , subsets, isSubsetOf
-   , cartesian, distinct, allsame
-   , fixpoint
-   , splitAtElem, splitsWithElem
-   , useFixedStdGen, timedSeconds
-   , fst3, snd3, thd3
-   , headM, findIndexM
-   , elementAt, changeAt, replaceAt
-   , list
-   ) where
-
-import Data.Char
-import Data.List
-import System.Random
-import System.Timeout
-
-data Some f = forall a . Some (f a)
-
-data ShowString = ShowString { fromShowString :: String }
-   deriving (Eq, Ord)
-
-instance Show ShowString where
-   show = fromShowString
-
-readInt :: String -> Maybe Int
-readInt xs
-   | null xs                = Nothing
-   | any (not . isDigit) xs = Nothing
-   | otherwise              = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- '
-
-readM :: (Monad m, Read a) => String -> m a
-readM s = case reads s of
-             [(a, xs)] | all isSpace xs -> return a
-             _ -> fail ("no read: " ++ s)
-
-subsets :: [a] -> [[a]]
-subsets = foldr op [[]]
- where op a xs = xs ++ map (a:) xs
-
-isSubsetOf :: Eq a => [a] -> [a] -> Bool
-isSubsetOf xs ys = all (`elem` ys) xs
-
-cartesian :: [a] -> [b] -> [(a, b)]
-cartesian as bs = [ (a, b) | a <- as, b <- bs ]
-
-distinct :: Eq a => [a] -> Bool
-distinct []     = True
-distinct (x:xs) = notElem x xs && distinct xs
-
-allsame :: Eq a => [a] -> Bool
-allsame []     = True
-allsame (x:xs) = all (==x) xs
-
-fixpoint :: Eq a => (a -> a) -> a -> a
-fixpoint f = stop . iterate f
- where
-   stop []           = error "Ideas.Common.Utils: empty list"
-   stop (x:xs)
-      | x == head xs = x
-      | otherwise    = stop xs
-
-splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a])
-splitAtElem c s =
-   case break (==c) s of
-      (xs, _:ys) -> Just (xs, ys)
-      _          -> Nothing
-
-splitsWithElem :: Eq a => a -> [a] -> [[a]]
-splitsWithElem c s =
-   case splitAtElem c s of
-      Just (xs, ys) -> xs : splitsWithElem c ys
-      Nothing       -> [s]
-
--- | Use a fixed standard "random" number generator. This generator is
--- accessible by calling System.Random.getStdGen
-useFixedStdGen :: IO ()
-useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -}
-
-timedSeconds :: Int -> IO a -> IO a
-timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>=
-   maybe (fail ("Timeout after " ++ show n ++ " seconds")) return
-
-fst3 :: (a, b, c) -> a
-fst3 (x, _, _) = x
-
-snd3 :: (a, b, c) -> b
-snd3 (_, x, _) = x
-
-thd3 :: (a, b, c) -> c
-thd3 (_, _, x) = x
-
--- generalized list functions (results in monad)
-headM :: Monad m => [a] -> m a
-headM (a:_) = return a
-headM _     = fail "headM"
-
-findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int
-findIndexM p = maybe (fail "findIndexM") return . findIndex p
-
-elementAt :: Monad m => Int -> [a] -> m a
-elementAt i = headM . drop i
-
-changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a]
-changeAt i f as =
-   case splitAt i as of
-      (xs, y:ys) -> return (xs ++ f y : ys)
-      _          -> fail "changeAt"
-
-replaceAt :: Monad m => Int -> a -> [a] -> m [a]
-replaceAt i = changeAt i . const
-
-list :: b -> ([a] -> b) -> [a] -> b
-list b f xs = if null xs then b else f xs
− src/Ideas/Common/Utils/QuickCheck.hs 
@@ -1,104 +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)
---
--- Extensions to the QuickCheck library
---
------------------------------------------------------------------------------
---  $Id: QuickCheck.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Utils.QuickCheck
-   ( module Test.QuickCheck
-     -- * Data type
-   , ArbGen, generator, generators
-     -- * Constructors
-   , arbGen, constGen, constGens, unaryGen, unaryGens
-   , unaryArbGen, binaryGen, binaryGens, toArbGen
-     -- * Frequency combinators
-   , common, uncommon, rare, changeFrequency
-   ) where
-
-import Control.Arrow
-import Control.Monad
-import Data.Monoid
-import Data.Ratio
-import Test.QuickCheck
-
----------------------------------------------------------
--- @ArbGen@ datatype
-
-newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))]
-
-instance Monoid (ArbGen a) where
-   mempty = AG mempty
-   AG xs `mappend` AG ys = AG (xs `mappend` ys)
-
-generator :: ArbGen a -> Gen a
-generator (AG pairs) = sized rec
- where
-   factor = foldr (lcm . denominator . fst) 1 pairs
-   rec n  = frequency (map make (select pairs))
-    where
-      select
-         | n == 0    = filter ((==0) . fst . snd)
-         | otherwise = id
-      make (r, (a, gf)) =
-         let m  = round (fromInteger factor*r)
-             xs = replicateM a $ rec $ n `div` 2
-         in (m, liftM2 ($) gf xs)
-
-generators :: [ArbGen a] -> Gen a
-generators = generator . mconcat
-
----------------------------------------------------------
--- Constructors
-
-arbGen :: Arbitrary b => (b -> a) -> ArbGen a
-arbGen f = newGen 0 (liftM (const . f) arbitrary)
-
-constGen :: a -> ArbGen a
-constGen = pureGen 0 . const
-
-constGens :: [a] -> ArbGen a
-constGens = mconcat . map constGen
-
-unaryGen :: (a -> a) -> ArbGen a
-unaryGen f = pureGen 1 (f . head)
-
-unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a
-unaryArbGen f = newGen 1 $ liftM (\a -> f a . head) arbitrary
-
-unaryGens :: [a -> a] -> ArbGen a
-unaryGens = mconcat . map unaryGen
-
-binaryGen :: (a -> a -> a) -> ArbGen a
-binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1))
-
-binaryGens :: [a -> a -> a] -> ArbGen a
-binaryGens = mconcat . map binaryGen
-
-pureGen :: Int -> ([a] -> a) -> ArbGen a
-pureGen n = newGen n . return
-
-toArbGen :: Gen a -> ArbGen a
-toArbGen = newGen 0 . liftM const
-
-newGen :: Int -> Gen ([a] -> a) -> ArbGen a
-newGen n f = AG [(1, (n, f))]
-
----------------------------------------------------------
--- Frequency combinators
-
-common, uncommon, rare :: ArbGen a -> ArbGen a
-common   = changeFrequency 2
-uncommon = changeFrequency (1/2)
-rare     = changeFrequency (1/5)
-
-changeFrequency :: Rational -> ArbGen a -> ArbGen a
-changeFrequency r (AG xs) = AG (map (first (*r)) xs)
− src/Ideas/Common/Utils/StringRef.hs 
@@ -1,137 +0,0 @@-{-# 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.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- References to Strings, proving a fast comparison implementation (Eq and
--- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy
--- Virutal Machine (LVM) identifiers.
---
------------------------------------------------------------------------------
---  $Id: StringRef.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Utils.StringRef
-   ( StringRef, stringRef, toString, tableStatus
-   ) where
-
-import Data.Bits
-import Data.Data
-import Data.IORef
-import Data.List
-import System.IO.Unsafe
-import qualified Data.IntMap as IM
-
-----------------------------------------------------------------
--- StringRef datatype and instance declarations
-
-data StringRef = S !Int
-   deriving (Eq, Ord, Data, Typeable)
-
-----------------------------------------------------------------
--- Hash table
-
-type HashTable = IM.IntMap [String]
-
-tableRef :: IORef HashTable
-tableRef = unsafePerformIO (newIORef IM.empty)
-
-----------------------------------------------------------------
--- Conversion to and from strings
-
-stringRef :: String -> StringRef
-stringRef s = unsafePerformIO $ do
-   let hash = hashString s
-   m <- readIORef tableRef
-   case IM.insertLookupWithKey (const combine) hash [s] m of
-      (Nothing, new) -> do
-         writeIORef tableRef new
-         return (S (encodeIndexZero hash))
-      (Just old, new) ->
-         case elemIndex s old of
-            Just index ->
-               return (S (encode hash index))
-            Nothing -> do
-               let index = length old
-               writeIORef tableRef new
-               return (S (encode hash index))
-
-toString :: StringRef -> String
-toString (S i) = unsafePerformIO $ do
-   m <- readIORef tableRef
-   case IM.lookup (extractHash i) m of
-      Just xs -> return (atIndex (extractIndex i) xs)
-      Nothing -> intErr "id not found"
-
-----------------------------------------------------------------
--- Bit encoding
-
-encode :: Int -> Int -> Int
-encode hash index = hash + index `shiftL` 12
-
-encodeIndexZero :: Int -> Int
-encodeIndexZero hash = hash
-
-extractHash :: Int -> Int
-extractHash i = i `mod` 4096
-
-extractIndex :: Int -> Int
-extractIndex i = i `shiftR` 12
-
-----------------------------------------------------------------
--- Hash function
-
--- simple hash function that performs quite good in practice
-hashString :: String -> Int
-hashString s = (f s `mod` prime) `mod` maxHash
- where
-   f        = foldl' next 0   -- ' strict fold
-   next n c = n*65599 + fromEnum c
-   prime    = 32537 --65599   -- require: prime < maxHash
-
-maxHash :: Int
-maxHash = 0xFFF -- 12 bits
-
-----------------------------------------------------------------
--- Utility functions
-
-atIndex :: Int -> [a] -> a
-atIndex 0 (x:_)  = x
-atIndex i (_:xs) = atIndex (i-1) xs
-atIndex _ _      = intErr "corrupt symbol table"
-
-combine :: Eq a => [a] -> [a] -> [a]
-combine [a] = rec
- where
-   rec [] = [a]
-   rec this@(x:xs)
-      | a == x    = this
-      | otherwise = x:rec xs
-combine _ = intErr "combine"
-
-intErr :: String -> a
-intErr s = error ("Internal error in Ideas.Common.StringRef: " ++ s)
-
-----------------------------------------------------------------
--- Testing and debugging
-
-tableStatus :: IO String
-tableStatus = readIORef tableRef >>= \m ->
-   let xs = map f (IM.assocs m)
-       f (i, ys) = '#' : show i ++ ": " ++ intercalate ", " (map g (frequency ys)) ++
-                   "  [total = " ++ show (length ys) ++ "]"
-       g (a, n)  | n == 1    = show a
-                 | otherwise = show a ++ " (" ++ show n ++ ")"
-   in return $ unlines xs
-
-frequency :: Eq a => [a] -> [(a, Int)]
-frequency [] = []
-frequency (x:xs) =
-   let (ys, zs) = partition (==x) xs
-   in (x, 1+length ys) : frequency zs
− src/Ideas/Common/Utils/TestSuite.hs 
@@ -1,421 +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)
---
--- A lightweight wrapper for organizing tests (including QuickCheck tests). It
--- introduces the notion of a test suite, and it stores the test results for
--- later inspection (e.g., for the generation of a test report). A TestSuite
--- is a monoid.
---
------------------------------------------------------------------------------
---  $Id: TestSuite.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Utils.TestSuite
-   ( -- * TestSuite
-     TestSuite, module Data.Monoid
-   , suite, useProperty, usePropertyWith
-   , assertTrue, assertNull, assertEquals, assertIO
-   , assertMessage, assertMessageIO
-   , onlyWarnings, rateOnError
-     -- * Running a test suite
-   , runTestSuite, runTestSuiteResult
-     -- * Test Suite Result
-   , Result, subResults, findSubResult
-   , justOneSuite, allMessages, topMessages
-   , nrOfTests, nrOfErrors, nrOfWarnings
-   , timeInterval, makeSummary, printSummary
-     -- * Message
-   , Message, message, warning, messageLines
-     -- * Status
-   , Status, HasStatus(..)
-   , isError, isWarning, isOk
-     -- * Rating
-   , Rating, HasRating(..)
-   ) where
-
-import Control.Exception
-import Control.Monad
-import Data.Foldable (toList)
-import Data.IORef
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.Time
-import Prelude hiding (catch)
-import System.IO
-import Test.QuickCheck hiding (Result)
-import qualified Data.Sequence as S
-
-----------------------------------------------------------------
--- Test Suite
-
-newtype TestSuite = TS (S.Seq Test)
-
-data Test = Case  String (IO Message)
-          | Suite String TestSuite
-
-instance Monoid TestSuite where
-   mempty = TS mempty
-   TS xs `mappend` TS ys = TS (xs <> ys)
-
-tests :: TestSuite -> [Test]
-tests (TS xs) = toList xs
-
-makeTestSuite :: Test -> TestSuite
-makeTestSuite = TS . S.singleton
-
-----------------------------------------------------------------
--- Test suite constructors
-
--- | Construct a (named) test suite containing test cases and other suites
-suite :: String -> [TestSuite] -> TestSuite
-suite s = makeTestSuite . Suite s . mconcat
-
--- | Turn a QuickCheck property into the test suite. The first argument is
--- a label for the property
-useProperty :: Testable prop => String -> prop -> TestSuite
-useProperty = flip usePropertyWith stdArgs
-
--- | Turn a QuickCheck property into the test suite, also providing a test
--- configuration (Args)
-usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
-usePropertyWith s args =
-   makeTestSuite . Case s . liftM make . quickCheckWithResult args {chatty=False}
- where
-   make qc =
-      case qc of
-         Success {} ->
-            mempty
-         Failure {reason = msg} ->
-            message msg
-         NoExpectedFailure {} ->
-            message "no expected failure"
-         GaveUp {numTests = i} ->
-            warning ("passed only " ++ show i ++ " tests")
-
-assertTrue :: String -> Bool -> TestSuite
-assertTrue s = assertIO s . return
-
-assertNull :: Show a => String -> [a] -> TestSuite
-assertNull s xs = assertMessages s (null xs) (map show xs)
-
-assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
-assertEquals s x y = assertMessage s (x==y) $
-   "not equal " ++ show x ++ " and " ++ show y
-
-assertMessage :: String -> Bool -> String -> TestSuite
-assertMessage s b = assertMessages s b . return
-
-assertMessages :: String -> Bool -> [String] -> TestSuite
-assertMessages s b xs = makeTestSuite . Case s $ return $
-   if b then mempty else mconcat (map message xs)
-
-assertIO :: String -> IO Bool -> TestSuite
-assertIO s = makeTestSuite . Case s . liftM f
- where
-   f b = if b then mempty else message "assertion failed"
-
-assertMessageIO :: String -> IO Message -> TestSuite
-assertMessageIO s = makeTestSuite . Case s
-
--- | All errors are turned into warnings
-onlyWarnings :: TestSuite -> TestSuite
-onlyWarnings = changeMessages $ \m ->
-   m { messageStatus = messageStatus m  `min` Warning
-     , messageRating = mempty
-     }
-
-rateOnError :: Int -> TestSuite -> TestSuite
-rateOnError n = changeMessages $ \m ->
-   if isError m then m { messageRating = Rating n } else m
-
-changeMessages :: (Message -> Message) -> TestSuite -> TestSuite
-changeMessages f = changeTS
- where
-   changeTS   (TS xs)     = TS (fmap changeTest xs)
-   changeTest (Case s io) = Case s (liftM f io)
-   changeTest (Suite s t) = Suite s (changeTS t)
-
-----------------------------------------------------------------
--- Running a test suite
-
-runTestSuite :: Bool -> TestSuite -> IO ()
-runTestSuite chattyIO = void . runTestSuiteResult chattyIO
-
-runTestSuiteResult :: Bool -> TestSuite -> IO Result
-runTestSuiteResult chattyIO ts = do
-   hSetBuffering stdout NoBuffering
-   ref <- newIORef 0
-   result <- runner ref chattyIO ts
-   newline ref
-   return result
- where
-
-runner :: IORef Int -> Bool -> TestSuite -> IO Result
-runner ref chattyIO = runTS
- where
-   runTS :: TestSuite -> IO Result
-   runTS ts = do
-      (res, dt) <- getDiffTime (foldM addTest mempty (tests ts))
-      returnStrict res { diffTime = dt }
-
-   runTest :: Test -> IO Result
-   runTest t =
-      case t of
-         Suite s xs -> runSuite s xs
-         Case s io  -> runTestCase s io
-
-   runSuite ::String -> TestSuite -> IO Result
-   runSuite s ts = do
-      when chattyIO $ do
-         newline ref
-         putStrLn s
-         reset ref
-      result <- runTS ts
-      returnStrict (suiteResult s result)
-
-   runTestCase :: String -> IO Message -> IO Result
-   runTestCase s io = do
-      msg <- io `catch` handler
-      case messageStatus msg of
-         _ | not chattyIO -> return ()
-         Ok -> dot ref
-         _  -> do
-            newlineIndent ref
-            print msg
-            reset ref
-      returnStrict (caseResult (s, msg))
-    where
-      handler :: SomeException -> IO Message
-      handler = return . message . show
-
-   addTest :: Result -> Test -> IO Result
-   addTest res t = liftM (res <>) (runTest t)
-
--- formatting helpers
-type WriteIO a = IORef Int -> IO a
-
-newline :: WriteIO ()
-newline ref = do
-   i <- readIORef ref
-   when (i>0) (putChar '\n')
-   reset ref
-
-newlineIndent :: WriteIO ()
-newlineIndent ref = do
-   newline ref
-   putStr "   "
-   writeIORef ref 3
-
-dot :: WriteIO ()
-dot ref = do
-   i <- readIORef ref
-   unless (i>0 && i<60) (newlineIndent ref)
-   putChar '.'
-   modifyIORef ref (+1)
-
-reset :: WriteIO ()
-reset = (`writeIORef` 0)
-
-----------------------------------------------------------------
--- Test Suite Result
-
-data Result = Result
-   { suites       :: S.Seq (String, Result)
-   , cases        :: S.Seq (String, Message)
-   , diffTime     :: !NominalDiffTime
-   , nrOfTests    :: !Int
-   , nrOfWarnings :: !Int
-   , nrOfErrors   :: !Int
-   , resultRating :: !Rating
-   }
-
--- one-line summary
-instance Show Result where
-   show result =
-      "(tests: "     ++ show (nrOfTests result)    ++
-      ", errors: "   ++ show (nrOfErrors result)   ++
-      ", warnings: " ++ show (nrOfWarnings result) ++
-      ", "           ++ show (diffTime result)     ++ ")"
-
-instance Monoid Result where
-   mempty = Result mempty mempty 0 0 0 0 mempty
-   x `mappend` y = Result
-      { suites       = suites x <> suites y
-      , cases        = cases x  <> cases y
-      , diffTime     = diffTime x     + diffTime y
-      , nrOfTests    = nrOfTests x    + nrOfTests y
-      , nrOfWarnings = nrOfWarnings x + nrOfWarnings y
-      , nrOfErrors   = nrOfErrors x   + nrOfErrors y
-      , resultRating = resultRating x <> resultRating y
-      }
-
-instance HasStatus Result where
-   getStatus r | nrOfErrors r   > 0 = Error
-               | nrOfWarnings r > 0 = Warning
-               | otherwise          = Ok
-
-instance HasRating Result where
-   rating   = rating . resultRating
-   rate n a = a {resultRating = Rating n}
-
-suiteResult :: String -> Result -> Result
-suiteResult s res = mempty
-   { suites       = S.singleton (s, res)
-   , nrOfTests    = nrOfTests res
-   , nrOfWarnings = nrOfWarnings res
-   , nrOfErrors   = nrOfErrors res
-   , resultRating = resultRating res
-   }
-
-caseResult :: (String, Message) -> Result
-caseResult x@(_, msg) =
-   case getStatus msg of
-      Ok      -> new
-      Warning -> new { nrOfWarnings = 1 }
-      Error   -> new { nrOfErrors   = 1 }
- where
-   new = mempty
-      { cases        = S.singleton x
-      , nrOfTests    = 1
-      , resultRating = messageRating msg
-      }
-
-subResults :: Result -> [(String, Result)]
-subResults = toList . suites
-
-topMessages :: Result -> [(String, Message)]
-topMessages = toList . cases
-
-allMessages :: Result -> [(String, Message)]
-allMessages res =
-   topMessages res ++ concatMap (allMessages . snd) (subResults res)
-
-findSubResult :: String -> Result -> Maybe Result
-findSubResult name = listToMaybe . recs
- where
-   recs = concatMap rec . subResults
-   rec (n, t)
-      | n == name = [t]
-      | otherwise = recs t
-
-justOneSuite :: Result -> Maybe (String, Result)
-justOneSuite res =
-   case subResults res of
-      [x] | S.null (cases res) -> Just x
-      _ -> Nothing
-
-timeInterval :: Result -> Double
-timeInterval = fromRational . toRational . diffTime
-
-printSummary :: Result -> IO ()
-printSummary = putStrLn . makeSummary
-
-makeSummary :: Result -> String
-makeSummary result = unlines $
-   [ line
-   , "Tests    : " ++ show (nrOfTests result)
-   , "Errors   : " ++ show (nrOfErrors result)
-   , "Warnings : " ++ show (nrOfWarnings result)
-   , ""
-   , "Time     : " ++ show (diffTime result)
-   , ""
-   , "Suites: "
-   ] ++ map f (subResults result)
-     ++ [line]
- where
-   line = replicate 75 '-'
-   f (name, r) = "   " ++ name ++ "   " ++ show r
-
------------------------------------------------------
--- Message
-
-data Message = M
-   { messageStatus :: !Status
-   , messageRating :: !Rating
-   , messageLines  :: [String]
-   }
- deriving Eq
-
-instance Show Message where
-   show a = st ++ sep ++ msg
-    where
-      msg = intercalate ", " (messageLines a)
-      sep = if null st || null msg then "" else ": "
-      st | isError a             = "error"
-         | isWarning a           = "warning"
-         | null (messageLines a) = "ok"
-         | otherwise             = ""
-
-instance Monoid Message where
-   mempty = M mempty mempty mempty
-   M s r xs `mappend` M t q ys = M (s <> t) (r <> q) (xs <> ys)
-
-instance HasStatus Message where
-   getStatus = messageStatus
-
-instance HasRating Message where
-   rating   = rating . messageRating
-   rate n a = a {messageRating = Rating n}
-
-message :: String -> Message
-message = M Error (Rating 0) . return
-
-warning :: String -> Message
-warning = M Warning mempty . return
-
------------------------------------------------------
--- Status
-
-data Status = Ok | Warning | Error
-   deriving (Eq, Ord)
-
-instance Monoid Status where
-   mempty  = Ok
-   mappend = max
-
-class HasStatus a where
-   getStatus :: a -> Status
-
-isOk, isWarning, isError :: HasStatus a => a -> Bool
-isOk      = (== Ok)      . getStatus
-isWarning = (== Warning) . getStatus
-isError   = (== Error)   . getStatus
-
------------------------------------------------------
--- Rating
-
-data Rating = Rating !Int | MaxRating
-   deriving (Eq, Ord)
-
-instance Monoid Rating where
-   mempty  = MaxRating
-   mappend = min
-
-class HasRating a where
-   rating :: a -> Maybe Int
-   rate   :: Int -> a -> a
-
-instance HasRating Rating where
-   rating (Rating n) = Just n
-   rating MaxRating  = Nothing
-   rate = const . Rating
-
------------------------------------------------------
--- Utility function
-
-getDiffTime :: IO a -> IO (a, NominalDiffTime)
-getDiffTime action = do
-   t0 <- getCurrentTime
-   a  <- action
-   t1 <- getCurrentTime
-   return (a, diffUTCTime t1 t0)
-
-returnStrict :: Monad m => a -> m a
-returnStrict a = a `seq` return a
− src/Ideas/Common/Utils/Uniplate.hs 
@@ -1,26 +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)
---
--- Exports a subset of Data.Generics.Uniplate.Direct (the @Uniplate@ type
--- class and its utility plus constructor functions)
---
------------------------------------------------------------------------------
---  $Id: Uniplate.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Common.Utils.Uniplate
-   ( -- * Uniplate type class and utility functions
-     Uniplate
-   , children, contexts, descend, descendM, holes, para
-   , rewrite, rewriteM, transform, transformM, uniplate, universe
-     -- * Instance constructors
-   , (|-), (|*), (||*), plate
-   ) where
-
-import Data.Generics.Uniplate.Direct
src/Ideas/Common/View.hs view
@@ -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 2019, 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,6 @@ -- in Interactive Exercise Assistants"
 --
 -----------------------------------------------------------------------------
---  $Id: View.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Common.View
    ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
@@ -40,7 +39,6 @@    ) where
 
 import Control.Arrow
-import Control.Monad
 import Data.Maybe
 import Ideas.Common.Classes
 import Ideas.Common.Id
@@ -102,7 +100,7 @@ 
 canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a
 canonicalWithM f view a =
-   match view a >>= liftM (build view) . f
+   match view a >>= fmap (build view) . f
 
 isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool
 isCanonical = isCanonicalWith (==)
src/Ideas/Encoding/DecoderJSON.hs view
@@ -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 2019, 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,13 +12,13 @@ -- Services using JSON notation
 --
 -----------------------------------------------------------------------------
---  $Id: DecoderJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.DecoderJSON
    ( JSONDecoder, jsonDecoder
    ) where
 
-import Control.Monad
+import Control.Monad.State (mplus, foldM, get, gets, put)
+import Data.Char
 import Data.Maybe
 import Ideas.Common.Library hiding (exerciseId, symbol)
 import Ideas.Common.Traversal.Navigator
@@ -26,30 +26,31 @@ import Ideas.Service.State
 import Ideas.Service.Types hiding (String)
 import Ideas.Text.JSON
+import Ideas.Utils.Decoding (symbol)
 import qualified Ideas.Service.Types as Tp
 
-type JSONDecoder a = Decoder a JSON
+type JSONDecoder a t = DecoderX a JSON t
 
 jsonDecoder :: TypedDecoder a JSON
-jsonDecoder tp = decoderFor $ \json ->
+jsonDecoder tp = get >>= \json ->
    case json of
       Array xs -> decodeType tp // xs
       _ -> fail "expecting an array"
 
-decodeType :: Type a t -> Decoder a [JSON] t
+decodeType :: Type a t -> DecoderX a [JSON] t
 decodeType tp =
    case tp of
       Tag _ t -> decodeType t
-      Iso p t -> liftM (from p) (decodeType t)
+      Iso p t -> from p <$> decodeType t
       Pair t1 t2 -> do
          a <- decodeType t1
          b <- decodeType t2
          return (a, b)
       t1 :|: t2 ->
-         liftM Left  (decodeType t1) `mplus`
-         liftM Right (decodeType t2)
+         (Left  <$> decodeType t1) `mplus`
+         (Right <$> decodeType t2)
       Unit         -> return ()
-      Const StdGen -> getStdGen
+      Const QCGen  -> getQCGen
       Const Script -> getScript
       Const t      -> symbol >>= \a -> decodeConst t // a
       _ -> fail $ "No support for argument type: " ++ show tp
@@ -62,8 +63,9 @@       Exercise    -> getExercise
       Environment -> decodeEnvironment
       Location    -> decodeLocation
-      Int         -> decoderFor fromJSON
-      Tp.String   -> decoderFor fromJSON
+      Term        -> gets jsonToTerm
+      Int         -> get >>= fromJSON
+      Tp.String   -> get >>= fromJSON
       Id          -> decodeId
       Rule        -> decodeRule
       _           -> fail $ "No support for argument type: " ++ show tp
@@ -71,38 +73,46 @@ decodeRule :: JSONDecoder a (Rule (Context a))
 decodeRule = do
    ex <- getExercise
-   decoderFor $ \json ->
+   get >>= \json ->
       case json of
          String s -> getRule ex (newId s)
          _        -> fail "expecting a string for rule"
 
 decodeId :: JSONDecoder a Id
-decodeId = decoderFor $ \json ->
+decodeId = get >>= \json ->
    case json of
       String s -> return (newId s)
       _        -> fail "expecting a string for id"
 
 decodeLocation :: JSONDecoder a Location
-decodeLocation = decoderFor $ \json ->
+decodeLocation = get >>= \json ->
    case json of
-      String s -> liftM toLocation (readM s)
+      String s -> toLocation <$> readM s
       _        -> fail "expecting a string for a location"
 
 decodeState :: JSONDecoder a (State a)
 decodeState = do
    ex <- getExercise
-   decoderFor $ \json ->
+   get >>= \json ->
       case json of
-         Array [a] -> setInput a >> decodeState
-         Array [String _code, pref, term, jsonContext] -> do
+         Array [a] -> put a >> decodeState
+         Array (String _code : pref : term : jsonContext : rest) -> do
             pts  <- decodePaths       // pref
-            a    <- decodeTerm        // term
+            a    <- decodeExpression  // term
             env  <- decodeEnvironment // jsonContext
             let loc = envToLoc env
                 ctx = navigateTowards loc $ deleteRef locRef $
                          setEnvironment env $ inContext ex a
-                prfx = replayPaths pts (strategy ex) ctx
-            return $ makeState ex prfx ctx
+                prfx = pts (strategy ex) 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
@@ -111,32 +121,41 @@ locRef :: Ref String
 locRef = makeRef "location"
 
-decodePaths :: JSONDecoder a [Path]
+decodePaths :: JSONDecoder a (LabeledStrategy (Context a) -> Context a -> Prefix (Context a))
 decodePaths =
-   decoderFor $ \json ->
+   get >>= \json ->
       case json of
-         String p -> readPaths p
+         String p
+            | p ~= "noprefix" -> return (\_ _ -> noPrefix)
+            | otherwise       -> replayPaths <$> readPaths p
          _ -> fail "invalid prefixes"
+ where
+   x ~= y = filter isAlphaNum (map toLower x) == y
 
 decodeEnvironment :: JSONDecoder a Environment
-decodeEnvironment = decoderFor $ \json ->
+decodeEnvironment = get >>= \json ->
    case json of
       String "" -> return mempty
       Object xs -> foldM (flip add) mempty xs
       _         -> fail $ "invalid context: " ++ show json
  where
    add (k, String s) = return . insertRef (makeRef k) s
+   add (k, Number n) = return . insertRef (makeRef k) (show n)
    add _             = fail "invalid item in context"
 
 decodeContext :: JSONDecoder a (Context a)
 decodeContext = do
    ex <- getExercise
-   liftM (inContext ex) decodeTerm
+   inContext ex <$> decodeExpression
 
-decodeTerm :: JSONDecoder a a
-decodeTerm = do
-   ex <- getExercise
-   decoderFor $ \json ->
+decodeExpression :: JSONDecoder a a
+decodeExpression = withJSONTerm $ \b -> getExercise >>= \ex -> get >>= f b ex
+ where
+   f True ex json =
+      case hasJSONView ex of
+         Just v  -> matchM v json
+         Nothing -> fail "JSON encoding not supported by exercise"
+   f False ex json =
       case json of
          String s -> either fail return (parser ex s)
-         _        -> fail "Expecting a string when reading a term"+         _ -> fail "Expecting a string when reading a term"
src/Ideas/Encoding/DecoderXML.hs view
@@ -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 2019, 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,46 +12,57 @@ -- Services using XML notation
 --
 -----------------------------------------------------------------------------
---  $Id: DecoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.DecoderXML
    ( XMLDecoder, xmlDecoder
    ) where
 
-import Control.Monad
+import Control.Applicative hiding (Const)
+import Control.Monad.State hiding (State)
 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
-import Ideas.Service.Request
+import Ideas.Encoding.Request hiding (XML)
 import Ideas.Service.State
 import Ideas.Service.Types
+import Ideas.Text.MathML
 import Ideas.Text.OpenMath.Object
 import Ideas.Text.XML
 
-type XMLDecoder a = Decoder a XML
+type XMLDecoder a t = DecoderX a XML t
 
 xmlDecoder :: TypedDecoder a XML
 xmlDecoder tp =
    case tp of
+      Tag s (Const String) ->
+         decodeChild s decodeData
+       `mplus`
+         decodeAttribute s
       Tag s t
          | s == "answer" ->
               decodeChild "answer" (xmlDecoder t)
          | s == "Difficulty" -> do
               g <- equalM tDifficulty tp
-              a <- decoderFor (findAttribute "difficulty")
+              a <- decodeAttribute "difficulty"
               maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)
          | otherwise ->
               decodeChild s (xmlDecoder t)
-      Iso p t  -> liftM (from p) (xmlDecoder t)
+      Iso p t  -> from p <$> xmlDecoder t
+      List t -> do
+         x  <- xmlDecoder t
+         xs <- xmlDecoder (List t)
+         return (x:xs)
+       `mplus`
+         return []
       Pair t1 t2 -> do
          x <- xmlDecoder t1
          y <- xmlDecoder t2
          return (x, y)
       t1 :|: t2 ->
-         liftM Left  (xmlDecoder t1) `mplus`
-         liftM Right (xmlDecoder t2)
+         (Left  <$> xmlDecoder t1) `mplus`
+         (Right <$> xmlDecoder t2)
       Unit -> return ()
       Const ctp ->
          case ctp of
@@ -59,14 +70,18 @@             Context     -> decodeContext
             Rule        -> decodeRule
             Environment -> decodeArgEnvironment
+            Term        -> get >>= (fromXML >=> fromOMOBJ)
             Location    -> decodeLocation
             StratCfg    -> decodeConfiguration
-            StdGen      -> getStdGen
+            QCGen       -> getQCGen
             Script      -> getScript
             Exercise    -> getExercise
             Id          -> -- improve!
                            decodeChild "location" $
-                              makeDecoder (newId . getData)
+                              gets (newId . getData)
+            MathML      -> decodeMathML
+            String      -> decodeData
+            XML         -> get
             _ -> fail $ "No support for argument type in XML: " ++ show tp
       _ -> fail $ "No support for argument type in XML: " ++ show tp
 
@@ -74,12 +89,12 @@ decodeRule :: XMLDecoder a (Rule (Context a))
 decodeRule = decodeChild "ruleid" $ do
    ex <- getExercise
-   decoderFor (getRule ex . newId . getData)
+   get >>= getRule ex . newId . getData
 
 -- <location>
 decodeLocation :: XMLDecoder a Location
 decodeLocation = decodeChild "location" $
-   makeDecoder (toLocation . read . getData)
+   gets (toLocation . read . getData)
 
 -- <state>
 decodeState :: XMLDecoder a (State a)
@@ -93,7 +108,7 @@ -- <prefix>
 decodePaths :: XMLDecoder a [Path]
 decodePaths = do
-   prefixText <- makeDecoder (maybe "" getData . findChild "prefix")
+   prefixText <- gets (maybe "" getData . findChild "prefix")
    if all isSpace prefixText
       then return [emptyPath]
       else if prefixText ~= "no prefix"
@@ -106,36 +121,39 @@ decodeContext :: XMLDecoder a (Context a)
 decodeContext = do
    ex   <- getExercise
-   expr <- decodeTerm
+   expr <- decodeExpression
    env  <- decodeEnvironment
    let ctx    = setEnvironment env (inContext ex expr)
        locRef = makeRef "location"
    case locRef ? env of
       Just s  -> maybe (fail "invalid location") return $ do
-         loc <- liftM toLocation (readM s)
+         loc <- toLocation <$> readM s
          navigateTo loc (deleteRef locRef ctx)
       Nothing ->
          return ctx
 
-decodeTerm :: XMLDecoder a a
-decodeTerm = withOpenMath f
+decodeExpression :: XMLDecoder a a
+decodeExpression = withOpenMath f
  where
    f True  = decodeOMOBJ
    f False = decodeChild "expr" $ do
       ex <- getExercise
-      decoderFor $ either fail return . parser ex . getData
+      get >>= either fail return . parser ex . getData
 
 decodeOMOBJ :: XMLDecoder a a
-decodeOMOBJ = decodeChild "OMOBJ" $ decoderFor $ \xml -> do
+decodeOMOBJ = decodeChild "OMOBJ" $ get >>= \xml -> do
    ex    <- getExercise
    omobj <- fromXML xml
    case fromOpenMath ex omobj of
       Just a  -> return a
       Nothing -> fail "Invalid OpenMath object for this exercise"
 
+decodeMathML :: XMLDecoder a MathML
+decodeMathML = decodeFirstChild "math" $ get >>= fromXML
+
 decodeEnvironment :: XMLDecoder a Environment
 decodeEnvironment =
-   decodeChild "context" (decoderFor $ foldM add mempty . children)
+   decodeChild "context" (get >>= foldM add mempty . children)
    <|> return mempty
  where
    add env item = do
@@ -158,9 +176,8 @@ -- <configuration>
 decodeConfiguration :: XMLDecoder a StrategyCfg
 decodeConfiguration = decodeChild "configuration" $
-   decoderFor $ \xml ->
-      liftM mconcat $
-         mapM decodeAction (children xml)
+   get >>= \xml ->
+      mconcat <$> mapM decodeAction (children xml)
  where
    decodeAction item = do
       guard (null (children item))
@@ -169,11 +186,11 @@       return (action `byName` newId cfgloc)
 
 decodeArgEnvironment :: XMLDecoder a Environment
-decodeArgEnvironment = decoderFor $
-   liftM makeEnvironment . mapM (decodeBinding //) . findChildren "argument"
+decodeArgEnvironment = get >>=
+   fmap makeEnvironment . mapM (decodeBinding //) . findChildren "argument"
 
 decodeBinding :: XMLDecoder a Binding
-decodeBinding = decoderFor $ \xml -> do
+decodeBinding = get >>= \xml -> do
    a   <- findAttribute "description" xml
    req <- getRequest
    case findChild "OMOBJ" xml of
@@ -186,12 +203,4 @@       _ -> return (makeBinding (makeRef a) (getData xml))
  where
    termBinding :: String -> Term -> Binding
-   termBinding = makeBinding . makeRef
-
-decodeChild :: String -> XMLDecoder a b -> XMLDecoder a b
-decodeChild s m = split f >>= (m //)
- where
-   p     = either (const False) ((==s) . name)
-   f xml = case break p (content xml) of
-              (xs, Right y:ys) -> Right (y, xml { content = xs ++ ys })
-              _ -> Left $ "Could not find child " ++ s+   termBinding = makeBinding . makeRef
src/Ideas/Encoding/Encoder.hs view
@@ -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 2019, 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,252 +10,179 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Evaluator.hs 6535 2014-05-14 11:05:06Z bastiaan $
 
 module Ideas.Encoding.Encoder
    ( -- * Converter type class
-     Converter(..)
-   , getExercise, getStdGen, getScript, getRequest
-   , withExercise, withOpenMath, (//)
-     -- * Options
-   , Options, simpleOptions, makeOptions
+     getExercise, getOptions, getRequest
+   , withExercise, getBaseUrl, getQCGen, getScript
+   , (//), withJSONTerm, withOpenMath
+     -- * JSON support
+   , hasJSONView, addJSONView, jsonEncoding
+   , termToJSON, jsonToTerm
+     -- * Latex support
+   , hasLatexEncoding, latexPrinter, latexPrinterContext
+   , latexEncoding, latexEncodingWith
      -- * Encoder datatype
-   , Encoder, TypedEncoder
-   , makeEncoder, encoderFor, exerciseEncoder
+   , EncoderX, TypedEncoder
    , (<?>), encodeTyped
      -- * Decoder datatype
-   , Decoder, TypedDecoder
-   , makeDecoder, decoderFor
-   , split, symbol, setInput
-     -- re-export
-   , module Data.Monoid, module Control.Applicative
-   , module Control.Arrow
+   , DecoderX, TypedDecoder
    ) where
 
-import Control.Applicative hiding (Const)
-import Control.Arrow
-import Control.Monad
-import Data.Monoid
-import Ideas.Common.Library hiding (exerciseId, symbol)
-import Ideas.Common.Utils (Some(..))
-import Ideas.Service.DomainReasoner
-import Ideas.Service.FeedbackScript.Parser (parseScriptSafe, Script)
-import Ideas.Service.Request
+import Control.Monad.Reader
+import Data.Maybe
+import Ideas.Common.Library
+import Ideas.Encoding.Options
+import Ideas.Encoding.Request
+import Ideas.Service.FeedbackScript.Parser (Script)
 import Ideas.Service.Types
-import Ideas.Text.XML
-import System.Random (newStdGen, mkStdGen, StdGen)
-import qualified Control.Category as C
+import Ideas.Text.JSON hiding (String)
+import Ideas.Text.Latex
+import Ideas.Utils.Decoding
+import Test.QuickCheck.Random
+import qualified Ideas.Common.Rewriting.Term as Term
+import qualified Ideas.Text.JSON as JSON
 
 -------------------------------------------------------------------
 -- Converter type class
 
-class Converter f where
-   fromOptions :: (Options a -> t) -> f a s t
-   run  :: Monad m => f a s t -> Options a -> s -> m t
+getExercise :: DecoderX a s (Exercise a)
+getExercise = reader fst
 
-getExercise :: Converter f => f a s (Exercise a)
-getExercise = fromOptions exercise
+getOptions :: DecoderX a s Options
+getOptions = reader snd
 
-getStdGen :: Converter f => f a s StdGen
-getStdGen = fromOptions stdGen
+getRequest :: DecoderX a s Request
+getRequest = request <$> getOptions
 
-getScript :: Converter f => f a s Script
-getScript = fromOptions script
+withExercise :: (Exercise a -> DecoderX a s t) -> DecoderX a s t
+withExercise = (getExercise >>=)
 
-getRequest :: Converter f => f a s Request
-getRequest = fromOptions request
+getBaseUrl :: DecoderX a s String
+getBaseUrl = fromMaybe "http://ideas.cs.uu.nl/" . baseUrl <$> getOptions
 
-withExercise :: (Converter f, Monad (f a s)) => (Exercise a -> f a s t) -> f a s t
-withExercise = (getExercise >>=)
+getQCGen :: DecoderX a s QCGen
+getQCGen = fromMaybe (mkQCGen 0) . qcGen <$> getOptions
 
-withOpenMath :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t
-withOpenMath = (liftM useOpenMath getRequest >>=)
+getScript :: DecoderX a s Script
+getScript = script <$> getOptions
 
-(//) :: (Converter f, Monad (f a s2)) => f a s t -> s -> f a s2 t
+withOpenMath :: (Bool -> DecoderX a s t) -> DecoderX a s t
+withOpenMath = (fmap useOpenMath getRequest >>=)
+
+withJSONTerm :: (Bool -> DecoderX a s t) -> DecoderX a s t
+withJSONTerm = (fmap useJSONTerm getRequest >>=)
+
+(//) :: Decoder env s a -> s -> Decoder env s2 a
 p // a = do
-   xs <- fromOptions id
-   run p xs a
+   env  <- ask
+   runDecoder p env a
 
 -------------------------------------------------------------------
--- Options
+-- JSON terms
 
-data Options a = Options
-   { exercise :: Exercise a -- the current exercise
-   , request  :: Request    -- meta-information about the request
-   , stdGen   :: StdGen     -- random number generator
-   , script   :: Script     -- feedback script
-   }
+jsonProperty :: Id
+jsonProperty = describe "Support for JSON encoding" $ newId "json"
 
-simpleOptions :: Exercise a -> Options a
-simpleOptions ex =
-   let req = emptyRequest {encoding = [EncHTML]}
-   in Options ex req (mkStdGen 0) mempty
+hasJSONView :: Exercise a -> Maybe (View JSON a)
+hasJSONView = getPropertyF jsonProperty
 
-makeOptions :: DomainReasoner -> Request -> IO (Some Options)
-makeOptions dr req = do
-   Some ex  <-
-      case exerciseId req of
-         Just code -> findExercise dr code
-         Nothing   -> return (Some emptyExercise)
+addJSONView :: View JSON a -> Exercise a -> Exercise a
+addJSONView = setPropertyF jsonProperty
 
-   scr <- case feedbackScript req of
-             Just s -> parseScriptSafe s
-             Nothing
-                | getId ex == mempty -> return mempty
-                | otherwise          -> defaultScript dr (getId ex)
-   stdgen <- newStdGen
-   return $ Some Options
-      { exercise = ex
-      , request  = req
-      , stdGen   = stdgen
-      , script   = scr
-      }
+jsonEncoding :: InJSON a => Exercise a -> Exercise a
+jsonEncoding = addJSONView (makeView fromJSON toJSON)
 
--------------------------------------------------------------------
--- Encoder datatype
+termToJSON :: Term -> JSON
+termToJSON term =
+   case term of
+      TVar s    -> JSON.String s
+      TCon s []
+         | s == trueSymbol  -> Boolean True
+         | s == falseSymbol -> Boolean False
+         | s == nullSymbol  -> Null
+      TCon s ts
+         | s == objectSymbol -> Object (f ts)
+         | otherwise -> Object [("_apply", Array (JSON.String (show s):map termToJSON ts))]
+      TList xs  -> Array (map termToJSON xs)
+      TNum n    -> Number (I n)
+      TFloat d  -> Number (D d)
+      TMeta n   -> Object [("_meta", Number (I (toInteger n)))]
+ where
+   f [] = []
+   f (TVar s:x:xs) = (s, termToJSON x) : f xs
+   f _ = error "termToJSON"
 
-newtype Encoder a s t = Enc { runEnc :: Options a -> s -> Error t }
+jsonToTerm :: JSON -> Term
+jsonToTerm json =
+   case json of
+      Number (I n)  -> TNum n
+      Number (D d)  -> TFloat d
+      JSON.String s -> TVar s
+      Boolean b     -> Term.symbol  (if b then trueSymbol else falseSymbol)
+      Array xs      -> TList (map jsonToTerm xs)
+      Object [("_meta", Number (I n))] -> TMeta (fromInteger n)
+      Object [("_apply", Array (JSON.String s:xs))] -> TCon (newSymbol s) (map jsonToTerm xs)
+      Object xs     -> TCon objectSymbol (concatMap f xs)
+      Null          -> Term.symbol nullSymbol
+ where
+   f (s, x) = [TVar s, jsonToTerm x]
 
-type TypedEncoder a = Encoder a (TypedValue (Type a))
+nullSymbol, objectSymbol :: Symbol
+nullSymbol   = newSymbol "null"
+objectSymbol = newSymbol "object"
 
-instance C.Category (Encoder a) where
-   id    = arr id
-   f . g = Enc $ \xs -> runEnc g xs >=> runEnc f xs
+-------------------------------------------------------------------
+-- Latex support
 
-instance Arrow (Encoder a) where
-   arr   f = Enc $ \_ -> return . f
-   first f = Enc $ \xs (a, b) -> runEnc f xs a >>= \c -> return (c, b)
+latexProperty :: Id
+latexProperty = describe "Support for LaTeX encoding" $ newId "latex"
 
-instance Monad (Encoder a s) where
-   return a = Enc $ \_ _ -> return a
-   fail s   = Enc $ \_ _ -> fail s
-   p >>= f  = Enc $ \xs s -> do
-      (a) <- runEnc p xs s
-      runEnc (f a) xs s
+newtype F a = F { unF :: a -> Latex }
 
-instance MonadPlus (Encoder a s) where
-   mzero = fail "Decoder: mzero"
-   mplus p q = Enc $ \xs s ->
-      runEnc p xs s `mplus` runEnc q xs s
+getF :: Exercise a -> Maybe (F a)
+getF = getPropertyF latexProperty
 
-instance Functor (Encoder a s) where
-   fmap = liftM
+hasLatexEncoding :: Exercise a -> Bool
+hasLatexEncoding = isJust . getF
 
-instance Applicative (Encoder a s) where
-   pure  = return
-   (<*>) = liftM2 ($)
+-- | Uses exercise pretty-printer in case latex encoding is missing.
+latexPrinter :: Exercise a -> a -> Latex
+latexPrinter ex = maybe (toLatex . prettyPrinter ex) unF (getF ex)
 
-instance Converter Encoder where
-   fromOptions f = Enc $ \xs _ -> return (f xs)
-   run f xs = runErrorM . runEnc f xs
+-- | Uses exercise pretty-printer in case latex encoding is missing.
+latexPrinterContext :: Exercise a -> Context a -> Latex
+latexPrinterContext ex ctx =
+   let def = toLatex (prettyPrinterContext ex ctx)
+   in fromMaybe def (unF <$> getF ex <*> fromContext ctx)
 
-instance Monoid t => Monoid (Encoder a s t) where
-   mempty  = pure mempty
-   mappend = liftA2 (<>)
+latexEncoding :: ToLatex a => Exercise a -> Exercise a
+latexEncoding = latexEncodingWith toLatex
 
-instance BuildXML t => BuildXML (Encoder a s t) where
-   n .=. s   = pure (n .=. s)
-   unescaped = pure . unescaped
-   builder   = pure . builder
-   tag       = liftA . tag
+latexEncodingWith :: (a -> Latex) -> Exercise a -> Exercise a
+latexEncodingWith = setPropertyF latexProperty . F
 
-makeEncoder :: (s -> t) -> Encoder a s t
-makeEncoder = arr
+-------------------------------------------------------------------
+-- Encoder datatype
 
-encoderFor :: (s -> Encoder a s t) -> Encoder a s t
-encoderFor f = C.id >>= f
+type EncoderX a = Encoder (Exercise a, Options)
 
-exerciseEncoder :: (Exercise a -> s -> t) -> Encoder a s t
-exerciseEncoder f = withExercise $ makeEncoder . f
+type TypedEncoder a b = TypedValue (Type a) -> EncoderX a b
 
 infixr 5 <?>
 
-(<?>) :: (Encoder a t b, Type a1 t) -> Encoder a (TypedValue (Type a1)) b
-                                    -> Encoder a (TypedValue (Type a1)) b
-(p, t) <?> q = do
-   val ::: tp <- makeEncoder id
+(<?>) :: (t -> EncoderX a b, Type a t) -> TypedEncoder a b -> TypedEncoder a b
+((p, t) <?> q) tv@(val ::: tp) =
    case equal tp t of
-      Just f -> p // f val
-      Nothing -> q
+      Just f  -> p (f val)
+      Nothing -> q tv
 
-encodeTyped :: Encoder st t b -> Type a t -> Encoder st (TypedValue (Type a)) b
+encodeTyped :: (t -> EncoderX a b) -> Type a t -> TypedEncoder a b
 encodeTyped p t = (p, t) <?> fail "Types do not match"
 
 -------------------------------------------------------------------
 -- Decoder datatype
 
-newtype Decoder a s t = Dec { runDec :: Options a -> s -> Error (t, s) }
-
-type TypedDecoder a s = forall t . Type a t -> Decoder a s t
-
-instance Monad (Decoder a s) where
-   return a = Dec $ \_ s -> return (a, s)
-   fail s   = Dec $ \_ _ -> fail s
-   p >>= f  = Dec $ \xs s1 -> do
-      (a, s2) <- runDec p xs s1
-      runDec (f a) xs s2
-
-instance MonadPlus (Decoder a s) where
-   mzero = fail "Decoder: mzero"
-   mplus p q = Dec $ \xs s ->
-      runDec p xs s `mplus` runDec q xs s
-
-instance Functor (Decoder a s) where
-   fmap = liftM
-
-instance Applicative (Decoder a s) where
-   pure  = return
-   (<*>) = liftM2 ($)
-
-instance Alternative (Decoder a s) where
-   empty = fail "Decoder: empty"
-   (<|>) = mplus
-
-get :: Decoder a s s
-get = Dec $ \_ s -> return (s, s)
-
-put :: s -> Decoder a s ()
-put s = Dec $ \_ _ -> return ((), s)
-
-instance Converter Decoder where
-   fromOptions f = Dec $ \xs s -> return (f xs, s)
-   run f xs = liftM fst . runErrorM . runDec f xs
-
-split :: (s -> Either String (t, s)) -> Decoder a s t
-split f = get >>= either fail (\(a, s2) -> put s2 >> return a) . f
-
-symbol :: Decoder a [s] s
-symbol = split f
- where
-   f []     = Left "Empty input"
-   f (x:xs) = Right (x, xs)
-
-setInput :: s -> Decoder a s ()
-setInput inp = split (\_ -> Right ((), inp))
-
-makeDecoder:: (s -> t) -> Decoder a s t
-makeDecoder f = fmap f get
-
-decoderFor :: (s -> Decoder a s t) -> Decoder a s t
-decoderFor f = get >>= f
-
--------------------------------------------------------------------
--- Error monad (helper)
-
-newtype Error a = Error { runError :: Either String a }
-
-instance Monad Error where
-   fail    = Error . Left
-   return  = Error . Right
-   m >>= f = Error $ either Left (runError . f) (runError m)
-
-instance MonadPlus Error where
-   mzero     = fail "mzero"
-   mplus p q = Error $
-      case (runError p, runError q) of
-         (Right a, _) -> Right a
-         (_, Right a) -> Right a
-         (Left s, _)  -> Left s
+type DecoderX a = Decoder (Exercise a, Options)
 
-runErrorM :: Monad m => Error a -> m a
-runErrorM = either fail return . runError+type TypedDecoder a s = forall t . Type a t -> Decoder (Exercise a, Options) s t
src/Ideas/Encoding/EncoderHTML.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, OverloadedStrings #-}
 -----------------------------------------------------------------------------
--- 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 2019, 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,115 +12,155 @@ -- Encoding in HTML
 --
 -----------------------------------------------------------------------------
---  $Id: EncoderHTML.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
-module Ideas.Encoding.EncoderHTML (htmlEncoder, htmlEncoderAt) where
+module Ideas.Encoding.EncoderHTML (HTMLEncoder, htmlEncoder) where
 
 import Data.Char
 import Data.List
 import Data.Maybe
-import Data.Ord
-import Ideas.Common.Library hiding (alternatives)
-import Ideas.Common.Utils
-import Ideas.Common.Utils.TestSuite
+import Data.Monoid
+import Ideas.Common.Examples (isEmpty, size, allRandoms)
+import Ideas.Common.Library hiding (alternatives, isEmpty, left, right, collapse, Medium)
+import Ideas.Common.Strategy.Symbol
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.LinkManager
+import Ideas.Encoding.Logging
+import Ideas.Encoding.Request
 import Ideas.Encoding.RulePresenter
 import Ideas.Encoding.RulesInfo
 import Ideas.Encoding.StrategyInfo
 import Ideas.Service.BasicServices
 import Ideas.Service.Diagnose
 import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
 import Ideas.Service.State
 import Ideas.Service.Types
-import Ideas.Text.HTML
+import Ideas.Text.HTML hiding (table, keyValueTable)
+import Ideas.Text.HTML.Templates
+import Ideas.Text.HTML.W3CSS hiding (tag, ul, top, table, content)
 import Ideas.Text.OpenMath.FMP
 import Ideas.Text.OpenMath.Object
-import Ideas.Text.XML
+import Ideas.Text.XML hiding (content)
+import Ideas.Utils.Prelude (munless, mwhen)
+import Ideas.Utils.TestSuite
 import System.IO.Unsafe
+import qualified Ideas.Text.HTML.W3CSS as W3
 
-type HTMLEncoder a t = Encoder a t HTMLBuilder
+type HTMLEncoder a = EncoderX a HTMLBuilder
 
 htmlEncoder :: DomainReasoner -> TypedEncoder a HTMLPage
-htmlEncoder = htmlEncoderAt 0
+htmlEncoder dr tv = do
+   lm <- getLinkManager
+   ex <- getExercise
+   makePage lm dr ex <$> encodeType dr tv
 
-htmlEncoderAt :: Int -> DomainReasoner -> TypedEncoder a HTMLPage
-htmlEncoderAt n dr = do
-   req <- getRequest
-   let lm = f (maybe staticLinks dynamicLinks (cgiBinary req))
-       f  = if n==0 then id else linksUp n
-   makePage lm dr <$> encodeType lm dr
+getLinkManager :: EncoderX a LinkManager
+getLinkManager = do
+   req  <- getRequest
+   base <- getBaseUrl
+   return $ makeLinkManager base (fromMaybe "" (cgiBinary req))
 
-makePage :: LinkManager -> DomainReasoner -> HTMLBuilder -> HTMLPage
-makePage lm dr a =
-   addCSS (urlForCSS lm "ideas.css") $
-   htmlPage "Ideas: documentation pages" $ mconcat
-      [ divClass "page-header" $ mconcat
-           [ divClass  "ideas-logo" space
-           , divClass  "ounl-logo"  space
-           , spanClass "menuitem"   $ linkToIndex lm $ string "Index"
-           , spanClass "menuitem"   $ linkToExercises lm $ string "Exercises"
-           , spanClass "menuitem"   $ linkToServices lm  $ string "Services"
+makePage :: LinkManager -> DomainReasoner -> Exercise a -> HTMLBuilder -> HTMLPage
+makePage lm dr ex body =
+   (if hasLatexEncoding ex then addScript mathJaxUrl else id) $
+   -- addCSS "http://ideas.cs.uu.nl/css/2007-chili-pepper.css" $
+   addCSS (urlForCSS lm "2007-chili-pepper.css") $
+   webpage myWebPage
+ where
+   mathJaxUrl =
+      "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-MML-AM_CHTML"
+
+   myWebPage = WebPage
+      { title       = "Ideas: documentation pages"
+      , menuButtons =
+           [ Button "http://ideas.cs.uu.nl/ " (theme L1) (fontAwesome "lightbulb-o" <> tag "span" (fontSize Large " I") <> tag "span" (fontSize Medium "DEAS"))
+           , Button (urlForIndex lm)     (hover White) "Index"
+           , Button (urlForExercises lm) (hover White) $ "Exercises " <> nrBadge (length (exercises dr))
+           , Button (urlForServices lm)  (hover White) $ "Services " <> nrBadge (length (services dr))
            ]
-      , divClass "page-content" a
-      , divClass "page-footer" $
-           string (fullVersion dr)
-      ]
+      , menuStyle   = theme_ . fontSize Large
+      , iconBarsStyle = hover White . fontSize Large . theme L1
+      , sideWidth = 150
+      , sideHeader  = tag "h4" $ barItem $ bold $ textTheme "Exercise"
+      , sideButtons =
+           let mk f = Button (f lm ex) (hover Black)
+           in if getId ex == mempty then [] else
+              [ mk urlForExercise    "Information"
+              , mk urlForStrategy    "Strategy"
+              , mk urlForRules       "Rules"
+              , mk urlForConstraints "Constraints"
+              , mk urlForExamples    "Examples"
+              , mk urlForDerivations "Derivations"
+              , mk urlForTestReport  "Test report"
+              ]
+      , sideStyle = theme L3 . fontSize Medium
+      , iconCloseStyle = fontSize XL . hover Black
+      , content = body
+      , footer = italic $ string $ fullVersion dr
+      , footerStyle = theme L1
+      }
 
-encodeType :: LinkManager -> DomainReasoner -> HTMLEncoder a (TypedValue (Type a))
-encodeType lm dr =
+nrBadge :: BuildXML a => Int -> a
+nrBadge = badge . theme L1 . fontSize Small . text
+
+table :: BuildXML a => Bool -> [[a]] -> a
+table hasHeader = tableAll . mconcat . zipWith f (hasHeader : repeat False)
+ where
+   f header = tag "tr" . mconcat . map makeCell
+    where
+      makeCell | header    = tag "th"
+               | otherwise = tag "td"
+
+keyValueTable :: BuildXML a => [(String, a)] -> a
+keyValueTable = table False . map (\(s, a) -> [string s, a])
+
+encodeType :: DomainReasoner -> TypedValue (Type a) -> HTMLEncoder a
+encodeType dr =
    (encodeIndex, tDomainReasoner) <?>
-   (exerciseHeader lm <> htmlDiagnosis lm dr, tDiagnosis) <?>
-   (exerciseHeader lm <> encodeExampleList lm, tList (tPair tDifficulty tContext)) <?>
-   (exerciseHeader lm <> htmlFirsts lm, tList (tPair tStepInfo tState)) <?>
-   (exerciseHeader lm <> htmlAllApplications lm, tList (tTuple3 tRule tLocation tState)) <?>
-   (exerciseHeader lm <> encodeDerivation lm, tDerivation (tPair tRule tEnvironment) tContext) <?>
-   (exerciseHeader lm <> encodeDerivationList lm, tList (tDerivation (tPair tRule tEnvironment) tContext)) <?>
-   encoderFor (\(val ::: tp) ->
+   (exerciseHeader . htmlDiagnosis dr, tDiagnosis) <?>
+   (exerciseHeader . encodeExampleList, tList (tPair tDifficulty tContext)) <?>
+   (exerciseHeader . htmlFirsts, tList (tPair tStepInfo tState)) <?>
+   (exerciseHeader . htmlAllApplications, tList (tTuple3 tRule tLocation tState)) <?>
+   (exerciseHeader . encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?>
+   (exerciseHeader . encodeDerivationList, tList (tDerivation (tPair tRule tEnvironment) tContext)) <?>
+   \(val ::: tp) ->
         case tp of
-           Iso iso t  -> encodeType lm dr // (to iso val ::: t)
-           Tag _ t    -> encodeType lm dr // (val ::: t)
-           Pair t1 t2 -> encodeType lm dr // (fst val ::: t1) <>
-                         encodeType lm dr // (snd val ::: t2)
+           Iso iso t  -> encodeType dr (to iso val ::: t)
+           Tag _ t    -> encodeType dr (val ::: t)
+           Pair t1 t2 -> encodeType dr (fst val ::: t1) <>
+                         encodeType dr (snd val ::: t2)
            t1 :|: t2  -> case val of
-                            Left x  -> encodeType lm dr // (x ::: t1)
-                            Right x -> encodeType lm dr // (x ::: t2)
-           List (Const Service) -> encodeServiceList lm // val
-           List (Const SomeExercise) -> encodeExerciseList lm // val
-           List (Const Rule) -> exerciseHeader lm <> encodeRuleList lm // val
-           List t -> ul [ encodeType lm dr // (x ::: t) | x <- val ]
-           Const t -> encodeConst lm dr // (val ::: t)
-           _ -> string $ "unknown: " ++ show tp)
+                            Left x  -> encodeType dr (x ::: t1)
+                            Right x -> encodeType dr (x ::: t2)
+           List (Const Service) -> encodeServiceList val
+           List (Const SomeExercise) -> encodeExerciseList val
+           List (Const Rule) -> exerciseHeader (encodeRuleList val)
+           List t -> ul [ encodeType dr (x ::: t) | x <- val ]
+           Const t -> encodeConst dr (val ::: t)
+           _ -> string $ "unknown: " ++ show tp
 
-encodeConst :: LinkManager -> DomainReasoner -> HTMLEncoder a (TypedValue (Const a))
-encodeConst lm dr = encoderFor $ \tv@(val ::: tp) ->
+encodeConst :: DomainReasoner -> TypedValue (Const a) -> HTMLEncoder a
+encodeConst dr tv@(val ::: tp) =
    case tp of
-      Service     -> encodeService // val
-      Exercise    -> exerciseHeader lm <> encodeExercise lm // val
-      Strategy    -> exerciseHeader lm <> encodeStrategy // val
-      Rule        -> encodeRule // val
-      State       -> exerciseHeader lm <> (encodeState lm dr // val)
+      Service     -> encodeService val
+      Exercise    -> exerciseHeader (encodeExercise val)
+      Strategy    -> exerciseHeader (encodeStrategy val)
+      Rule        -> encodeRule val
+      State       -> exerciseHeader (encodeState dr val)
       Location    -> text val
       Environment -> text val
-      Context     -> encodeContext // val
+      Term        -> text val
+      Context     -> encodeContext val
       String      -> string val
-      Result      -> exerciseHeader lm <> encodeResult lm val
+      Result      -> exerciseHeader (encodeResult val)
       _           -> text tv
 
-encodeContext :: HTMLEncoder a (Context a)
-encodeContext = exerciseEncoder $ \ex ->
-   string . prettyPrinterContext ex
+encodeContext :: Context a -> HTMLEncoder a
+encodeContext ctx = (\ex -> string (prettyPrinterContext ex ctx)) <$> getExercise
 
-encodeIndex :: HTMLEncoder a DomainReasoner
-encodeIndex = makeEncoder $ \dr -> mconcat
-   [ h1 $ "Domain reasoner " ++ showId dr
-   , htmlDescription dr
-   , keyValueTable
-        [ ("version", string $ fullVersion dr)
-        , ("exercises", text $ length $ exercises dr)
-        , ("services", text $ length $ services dr)
-        ]
+encodeIndex :: DomainReasoner -> HTMLEncoder a
+encodeIndex dr = return $ mconcat
+   [ htmlDescription "Domain reasoner" dr
+   , panel $ right $ string "Logging: " <> bool logEnabled
    , munless (null $ aliases dr) $
         h2 "Exercise aliases" <>
         table True (
@@ -137,32 +177,36 @@            ])
    ]
 
-encodeServiceList :: LinkManager -> HTMLEncoder a [Service]
-encodeServiceList lm = makeEncoder $ \srvs ->
-   h1 "Services" <>
-   mconcat
-      [ h2 (show i ++ ". " ++ s) <> table False (map make xs)
-      | (i, s, xs) <- groupById srvs
-      ]
+encodeServiceList :: [Service] -> HTMLEncoder a
+encodeServiceList srvs = do
+   lm <- getLinkManager
+   return $
+      h1 "Services" <>
+      mconcat
+         [ h2 (show i ++ ". " ++ s) <> table False (map (make lm) xs)
+         | (i, s, xs) <- groupById srvs
+         ]
  where
-   make s = [ linkToService lm s (string (showId s)) <>
-              mwhen (serviceDeprecated s) (italic (string " (deprecated)"))
-            , string (description s)
-            ]
+   make lm s = [ linkToService lm s (string (showId s)) <>
+                 mwhen (serviceDeprecated s) (italic (string " (deprecated)"))
+               , string (description s)
+               ]
 
-encodeExerciseList :: LinkManager -> HTMLEncoder a [Some Exercise]
-encodeExerciseList lm = makeEncoder $ \exs ->
-   h1 "Exercises" <>
-   mconcat
-      [ h2 (show i ++ ". " ++ dom) <> table False (map make xs)
-      | (i, dom, xs) <- groupsWith f exs
-      ]
+encodeExerciseList :: [Some Exercise] -> HTMLEncoder a
+encodeExerciseList exs = do
+   lm <- getLinkManager
+   return $
+      h1 "Exercises" <>
+      mconcat
+         [ h2 (show i ++ ". " ++ dom) <> table False (map (make lm) xs)
+         | (i, dom, xs) <- groupsWith f exs
+         ]
  where
    f :: Some Exercise -> String
    f (Some ex) = fromMaybe "" (listToMaybe (qualifiers (getId ex)))
 
-   make :: Some Exercise -> [HTMLBuilder]
-   make (Some ex) =
+   make :: LinkManager -> Some Exercise -> [HTMLBuilder]
+   make lm (Some ex) =
       [ linkToExercise lm ex $ string $ showId ex
       , string $ map toLower $ show $ status ex
       , string $ description ex
@@ -176,17 +220,16 @@ 
 orderedGroupsWith :: Ord b => (b -> String) -> (a -> b) -> [a] -> [(Int, String, [a])]
 orderedGroupsWith showf get =
-   zipWith f [1..] . groupBy eq . sortBy (comparing get)
+   zipWith f [1..] . groupBy eq . sortOn get
  where
    eq x y = get x == get y
    f i xs = (i, showf (get (head xs)), xs)
 
-encodeService :: HTMLEncoder a Service
-encodeService = makeEncoder $ \srv -> mconcat
-   [ h1 $ "Service " ++ showId srv
+encodeService :: Service -> HTMLEncoder a
+encodeService srv = return $ mconcat
+   [ htmlDescription "Service" srv
    , mwhen (serviceDeprecated srv) $
         para $ spanClass "warning" $ string "Warning: this service is deprecated"
-   , htmlDescription srv
    , case serviceFunction srv of
         _ ::: tp ->
            let (xs, ys) = inputOutputTypes tp
@@ -218,81 +261,69 @@       Unit       -> []
       _          -> [Some tp]
 
-encodeExercise :: LinkManager -> HTMLEncoder a (Exercise a)
-encodeExercise lm = makeEncoder $ \ex -> mconcat
-   [ generalInfo ex
-   , h2 "Example exercises"
-   , ul $ [ para $ linkToExamples lm ex $ string "list of examples"
-          | not (null (examples ex))
-          ] ++
-          [ para $ mconcat $
-               string "generate exercise: " :
-               intersperse (string ", ")
-                  [ linkToRandomExample lm ex d $ text d
-                  | d <- [VeryEasy .. VeryDifficult]
-                  ]
-          | isJust (randomExercise ex)
-          ] ++
-          [ para $ submitStateInfo lm ex
-          | not (isStatic lm)
-          ]
-   ]
+encodeExercise :: Exercise a -> HTMLEncoder a
+encodeExercise ex = do
+   lm <- getLinkManager
+   return $ mconcat
+      [ generalInfo lm
+      , h2 "Example exercises"
+      , ul $ [ para $ linkToExamples lm ex $ string "list of examples"
+             | isEmpty (examples ex)
+             ] ++
+             [ para $ mconcat $
+                  string "generate exercise: " :
+                  intersperse (string ", ")
+                     [ linkToRandomExample lm ex d $ text d
+                     | d <- [VeryEasy .. VeryDifficult]
+                     ]
+             | not $ null $ allRandoms $ examples ex
+             ] ++
+             [ para $ submitStateInfo lm ex ]
+      ]
  where
-   generalInfo ex = keyValueTable
-      [ ("Code",   ttText (showId ex))
+   generalInfo lm = container $ panel $ left $ keyValueTable
+      [ ("Code",   string $ showId ex)
       , ("Status", text $ status ex)
       , ("Strategy", linkToStrategy lm ex $ string (showId $ strategy ex))
       , ("Rules", text nrOfSoundRules)
+      , ("Constraints", text (length (constraints ex)))
       , ("Buggy rules", text nrOfBuggyRules)
       , ("OpenMath support", bool $ isJust $ hasTermView ex)
       , ("Restartable strategy", bool $ canBeRestarted ex)
-      , ("Exercise generator", bool $ isJust $ randomExercise ex)
-      , ("Examples", text $ length $ examples ex)
+      , ("Exercise generator", bool $ not $ null $ allRandoms $ examples ex)
+      , ("Examples", text $ size $ examples ex)
       ]
     where
       (nrOfBuggyRules, nrOfSoundRules) =
          mapBoth length (partition isBuggy (ruleset ex))
 
-exerciseHeader :: LinkManager -> HTMLEncoder a b
-exerciseHeader lm = withExercise $ \ex -> mconcat
-   [ exerciseMenu lm
-   , h1 $ "Exercise " ++ showId ex
-   , pure $ htmlDescription ex
-   ]
-
-exerciseMenu :: LinkManager -> HTMLEncoder a b
-exerciseMenu lm = divClass "menubox" $
-   bold (string "Exercise") <>
-   ul [ with linkToExercise    "information"
-      , with linkToStrategy "   strategy"
-      , with linkToRules       "rules"
-      , with linkToExamples    "examples"
-      , with linkToDerivations "derivations"
-      , with linkToTestReport  "test report"
+exerciseHeader :: HTMLEncoder a -> HTMLEncoder a
+exerciseHeader body = withExercise $ \ex ->
+   tag "div" $ mconcat
+      [ return (htmlDescription "Exercise" ex)
+      , body
       ]
- where
-   with f s = withExercise $ \ex ->
-      pure $ f lm ex (string s)
 
-encodeStrategy :: HTMLEncoder a (Strategy (Context a))
-encodeStrategy = exerciseEncoder $ \ex s -> mconcat
-   [ h2 "Strategy"
-   , highlightXML True (strategyToXML s)
-   , h2 "Locations"
-   , let f :: HasId a => ([Int], a) -> [HTMLBuilder]
-         f (loc, a) = [text loc, indent (length loc) <> string (showId a)]
-         indent n = string (replicate (3*n) '.')
-     in table True
-           ( [string "Location", string "Label"]
-           : map f (strategyLocations (strategy ex))
-           )
-   ]
+encodeStrategy :: Strategy (Context a) -> HTMLEncoder a
+encodeStrategy s = withExercise $ \ex ->
+   return $ mconcat
+      [ h2 "Strategy"
+      , highlightXML True (strategyToXML s)
+      , h2 "Locations"
+      , let f :: HasId a => ([Int], a) -> [HTMLBuilder]
+            f (loc, a) = [text loc, indent (length loc) <> string (showId a)]
+            indent n = string (replicate (3*n) '.')
+        in table True
+              ( [string "Location", string "Label"]
+              : map f (strategyLocations (strategy ex))
+              )
+      ]
 
 bool :: Bool -> HTMLBuilder
 bool b = string (if b then "yes" else "no")
 
-encodeResult :: BuildXML b => LinkManager -> Result -> b
-encodeResult lm tests = mconcat
+encodeResult :: Result -> HTMLEncoder a
+encodeResult tests = getLinkManager >>= \lm -> mconcat
    [ h2 "Test report"
    , divClass "test-summary" $ mconcat
         [ divClass "test-status" (statusImg lm tests 32)
@@ -309,26 +340,26 @@              ]
         ]
    , mwhen (isError tests) $
-        mconcat (h2 "Errors" : map makeItem errors)
+        mconcat (h2 "Errors" : map (makeItem lm) errors)
    , mwhen (isWarning tests) $
-        mconcat (h2 "Warnings" : map makeItem warnings)
+        mconcat (h2 "Warnings" : map (makeItem lm) warnings)
    , h2 "Tests"
-   , make tests
+   , make lm tests
    ]
  where
    msgs     = allMessages tests
    errors   = filter (isError . snd) msgs
    warnings = filter (isWarning . snd) msgs
 
-   make t = mconcat $
-      map makeGroup (subResults t) ++
-      map makeItem (topMessages t)
+   make lm t = mconcat $
+      map (makeGroup lm) (subResults t) ++
+      map (makeItem lm) (topMessages t)
 
-   makeGroup (s, t) = divClass "test-group" $
+   makeGroup lm (s, t) = divClass "test-group" $
       divClass "test-title" (string (s ++ " " ++ show t))
-      <> make t
+      <> make lm t
 
-   makeItem (s, m) = divClass "test-item" $
+   makeItem lm (s, m) = divClass "test-item" $
       statusImg lm m 16 <> spaces 3 <> string s <> msg
     where
       msg | isOk m      = mempty
@@ -361,15 +392,16 @@           | a == 1    = "star_2.png"
           | otherwise = "star_3.png"
 
-encodeRuleList :: LinkManager -> HTMLEncoder a [Rule (Context a)]
-encodeRuleList lm = exerciseEncoder $ \ex rs ->
+encodeRuleList :: [Rule (Context a)] -> HTMLEncoder a
+encodeRuleList rs = withExercise $ \ex -> do
+   lm <- getLinkManager
    let (rs1, rs2) = partition isBuggy rs
 
        header = [ string "Rule name", string "Args"
                 , string "Used", string "Siblings", string "Rewrite rule"
                 ]
        used = rulesInStrategy (strategy ex)
-       f r  = [ linkToRule lm ex r $ ttText (showId r)
+       f r  = [ linkToRule lm ex r $ string $ showId r
               , text $ length $ getRefs r
               , bool $ r `elem` used
               , string $ intercalate ", " $ map show $ ruleSiblings r
@@ -377,123 +409,133 @@                    ruleToHTML (Some ex) r
               ]
 
-   in mconcat
+   return $ mconcat
          [ h2 $ "Rules for " ++ showId ex
          , table True (header:map f rs2)
          , h2 $ "Buggy rules for " ++ showId ex
          , table True (header:map f rs1)
          ]
 
-encodeRule :: HTMLEncoder a (Rule (Context a))
-encodeRule = exerciseEncoder $ \ex r -> mconcat
-   [ h1 $ "Rule " ++ showId r
-   , htmlDescription r
-   , let commas  = string . intercalate ", "
-         idList  = commas . map showId
-         refList = commas . map show . getRefIds
-     in para $ keyValueTable
-           [ ("Parameters", refList r)
-           , ("Buggy", bool (isBuggy r))
-           , ("Rewrite rule", bool (isRewriteRule r))
-           , ("Siblings", idList $ ruleSiblings r)
-           ]
-   , mwhen (isRewriteRule r) $
-        h2 "Rewrite rule" <> ruleToHTML (Some ex) r
-   -- FMPS
-   , let xs = getRewriteRules (transformation r)
-     in munless (null xs) $ mconcat $
-           h2 "Formal Mathematical Properties" :
-           [ para $
-              let fmp = rewriteRuleToFMP (not $ isBuggy r) rr
-              in highlightXML False $ makeXML "FMP" $
-                    builder $ omobj2xml $ toObject fmp
-           | Some rr <- xs
-           ]
-   ]
+encodeRule :: Rule (Context a) -> HTMLEncoder a
+encodeRule r = withExercise $ \ex ->
+   return $ mconcat
+      [ htmlDescription "Rule" r
+      , let commas  = string . intercalate ", "
+            idList  = commas . map showId
+            refList = commas . map show . getRefIds
+        in para $ keyValueTable
+              [ ("Parameters", refList r)
+              , ("Buggy", bool (isBuggy r))
+              , ("Rewrite rule", bool (isRewriteRule r))
+              , ("Siblings", idList $ ruleSiblings r)
+              ]
+      , mwhen (isRewriteRule r) $
+           h2 "Rewrite rule" <> ruleToHTML (Some ex) r
+      -- FMPS
+      , let xs = getRewriteRules (transformation r)
+        in munless (null xs) $ mconcat $
+              h2 "Formal Mathematical Properties" :
+              [ para $
+                 let fmp = rewriteRuleToFMP (not $ isBuggy r) rr
+                 in highlightXML False $ makeXML "FMP" $
+                       builder $ omobj2xml $ toObject fmp
+              | Some rr <- xs
+              ]
+      ]
 
-encodeExampleList :: LinkManager -> HTMLEncoder a [(Difficulty, Context a)]
-encodeExampleList lm = exerciseEncoder $ \ex pairs -> mconcat $
-   h2 "Examples" :
-   [ h3 (s ++ " (" ++ show (length xs) ++ ")")
-       <> (if isStatic lm then ul else mconcat) (map (make ex) xs)
-   | (_, s, xs) <- orderedGroupsWith show fst pairs
-   ]
+encodeExampleList :: [(Difficulty, Context a)] -> HTMLEncoder a
+encodeExampleList pairs = withExercise $ \ex -> do
+   lm <- getLinkManager
+   return $ mconcat $
+      h2 "Examples" :
+      [  container . third $
+          h3 (s ++ " (" ++ show (length xs) ++ ")")
+          <> W3.ulWith hoverable (map ((fontAwesome "hand-o-right" <>) . padding Small . make lm ex) xs)
+      | (_, s, xs) <- orderedGroupsWith show fst pairs
+      ]
  where
-   make ex (_, x) = para $
-      munless (isStatic lm) (
-         let st = emptyStateContext ex x
-         in spanClass "statelink" $ linkToState lm st $ external lm)
-      <> spanClass "term" (string (prettyPrinterContext ex x))
-
-external :: BuildXML a => LinkManager -> a
-external lm = element "img"
-   ["src" .=. urlForImage lm "external.png", "width" .=. "15"]
+   make lm ex (_, x) =
+      let st = emptyStateContext ex x
+      in button (escapeInURL (urlForState lm st)) (htmlContext False ex x)
 
-encodeDerivation :: LinkManager -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a))
-encodeDerivation lm =
-   h2 "Derivation" <> htmlDerivation lm
+encodeDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> HTMLEncoder a
+encodeDerivation d =
+   h2 "Derivation" <> htmlDerivation d
 
-encodeDerivationList :: LinkManager -> HTMLEncoder a [Derivation (Rule (Context a), Environment) (Context a)]
-encodeDerivationList lm = encoderFor $ \ds ->
+encodeDerivationList :: [Derivation (Rule (Context a), Environment) (Context a)] -> HTMLEncoder a
+encodeDerivationList ds =
    h2 "Derivations"
    <> mconcat
-      [ h3 (show i ++ ".") <> htmlDerivation lm // d
+      [ h3 (show i ++ ".") <> htmlDerivation d
       | (i, d) <- zip [1::Int ..] ds
       ]
 
-htmlDerivation :: LinkManager -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a))
-htmlDerivation lm = exerciseEncoder $ \ex d ->
+htmlDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> HTMLEncoder a
+htmlDerivation d = withExercise $ \ex -> do
+   lm <- getLinkManager
    let before =
           stateLink lm (emptyStateContext ex (firstTerm d))
           <> case fmap (isReady ex) (fromContext (lastTerm d)) of
                 Just True -> mempty
                 _ -> spanClass "error" (string "Final term is not finished")
        forStep ((r, env1), env2) =
-          let showEnv e = munless (noBindings e) $ string $ ", " ++ show e in
-          spanClass "derivation-step" $ mconcat
-             [ unescaped "&#8658; "
+          let showEnv e = munless (noBindings e) $ string $ "," ++ show e in
+          container $ marginPos CenterLeft $ mconcat
+             [ string [chr 8658, ' ']
              , linkToRule lm ex r $ string $ showId r
              , showEnv env1 -- local environment
              , showEnv env2 -- global environment (diff)
              ]
-       forTerm a =
-          divClass "term" $ string $ prettyPrinterContext ex a
-   in htmlDerivationWith before forStep forTerm (diffEnvironment d)
+       forTerm = htmlContext True ex
+   return $ htmlDerivationWith before forStep forTerm (diffEnvironment d)
 
-htmlState :: LinkManager -> HTMLEncoder a (State a)
-htmlState lm = makeEncoder $ \state ->
-   para $ divClass "state" $
+htmlState :: State a -> HTMLEncoder a
+htmlState state = do
+   lm <- getLinkManager
+   return $ para $ container $ background LightGray $ para $
       stateLink lm state
-      <> divClass "term" (string $ prettyPrinterContext (exercise state) (stateContext state))
+      <> htmlContext True (exercise state) (stateContext state)
       <> string "ready: " <> bool (finished state)
 
+htmlContext :: Bool -> Exercise a -> Context a -> HTMLBuilder
+htmlContext useDiv ex = f "term" . textLines . printer
+ where
+   textLines = mconcat . intersperse br . map string . lines
+   f = if useDiv then divClass else spanClass
+
+   inline s = "\\(" ++ s ++ "\\)" :: String
+   printer
+      | hasLatexEncoding ex = inline . show . latexPrinterContext ex
+      | otherwise = prettyPrinterContext ex
+
 stateLink :: LinkManager -> State a -> HTMLBuilder
-stateLink lm st
-   | isStatic lm = mempty
-   | otherwise =
-        spanClass "derivation-statelink" $ linkToState lm st $ external lm
+stateLink lm st =
+   container $ right $ linkToState lm st $
+   tag "span" $ textTheme $ fontAwesome "external-link"
 
-encodeState :: LinkManager -> DomainReasoner -> HTMLEncoder a (State a)
-encodeState lm dr =
-   htmlState lm <>
-   makeEncoder (\state ->
+encodeState :: DomainReasoner -> State a -> HTMLEncoder a
+encodeState dr state = do
+   lm <- getLinkManager
+   htmlState state <>
       let xs = useAllFirsts dr state
           n  = either (const 0) length xs
-      in mconcat
+      in return (mconcat
          [ h2 "Feedback"
          , submitDiagnose lm state
-         , ul [ case xs of
-                   Right (hd:_) -> linkToState lm (snd hd) $ string "onefirst"
+         , tag "p" $ padding Small  $ mconcat [ case xs of
+                   Right (hd:_) -> linkToState lm (snd hd) $ serviceButton $ string "onefirst"
                    _ -> string "(no onefirst)"
-              , linkToFirsts lm state $ string $ "allfirsts (" ++ show n ++ ")"
-              , linkToApplications lm state $ string "allapplications"
-              , linkToDerivation lm state $ string "derivation"
-              , linkToMicrosteps lm state $ string "microsteps"
-              ]
+              , linkToFirsts lm state $ serviceButton $ string $ "allfirsts (" ++ show n ++ ")"
+              , linkToApplications lm state $ serviceButton $ string "allapplications"
+              , linkToDerivation lm state $ serviceButton $ string "derivation"
+              , linkToMicrosteps lm state $ serviceButton $ string "microsteps"
+           ]
          , munless (noBindings state) $
               h2 "Environment" <> text (environment state)
          , encodePrefix state (statePrefix state)
          ])
+     where
+       serviceButton = theme L1  . W3.w3class "w3-button"
 
 -- use allfirsts service of domain reasoner, instead of calling the service
 -- directly. Note that the service can be redefined (e.g. for the Ask-Elle tutor)
@@ -502,7 +544,7 @@ 
 useAllFirstsIO :: DomainReasoner -> State a -> IO (Either String [(StepInfo a, State a)])
 useAllFirstsIO dr st = do
-   srv <- findService dr (newId "allfirsts")
+   srv <- findService dr (newId ("allfirsts" :: String))
    case serviceFunction srv of
       f ::: tp -> do
          conv <- equalM tp (tState .-> tError (tList (tPair tStepInfo tState)))
@@ -530,20 +572,22 @@       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 =
-   divClass "derivation" $ mconcat $
+   container $ background LightGray $ para $ mconcat $
       before : forTerm (firstTerm d) :
          [ forStep s <> forTerm a | (_, s, a) <- triples d ]
 
-htmlFirsts :: LinkManager -> HTMLEncoder a [(StepInfo a, State a)]
-htmlFirsts lm = encoderFor $ \xs ->
+htmlFirsts :: [(StepInfo a, State a)] -> HTMLEncoder a
+htmlFirsts xs =
    h2 "Firsts" <>
    ul [ keyValueTable
            [ ("Rule", string $ showId r)
@@ -551,58 +595,64 @@            , ("Term", text $ show $ currentTerm (top $ stateContext s) )
            , ("Focus", text $ show $ currentTerm (stateContext s) )
            , ("Environment", text env)
-           ] <> htmlState lm // s
+           ] <> htmlState s
       | ((r, loc, env), s) <- xs
       ]
 
-htmlAllApplications :: LinkManager -> HTMLEncoder a [(Rule (Context a), Location, State a)]
-htmlAllApplications lm = encoderFor $ \xs ->
+htmlAllApplications :: [(Rule (Context a), Location, State a)] -> HTMLEncoder a
+htmlAllApplications xs =
    h2 "All applications" <>
    ul [ keyValueTable
            [ ("Rule", string $ showId r)
            , ("Location", text loc)
-           ] <> (if isBuggy r then mempty else htmlState lm // s)
+           ] <> (if isBuggy r then mempty else htmlState s)
       | (r, loc, s) <- xs
       ]
 
-htmlDiagnosis :: LinkManager -> DomainReasoner -> HTMLEncoder a (Diagnosis a)
-htmlDiagnosis lm dr = encoderFor $ \diagnosis ->
+htmlDiagnosis :: DomainReasoner -> Diagnosis a -> HTMLEncoder a
+htmlDiagnosis dr diagnosis =
    case diagnosis of
+      SyntaxError s ->
+         spanClass "error" $ string s
       Buggy _ r ->
          spanClass "error" $ string $ "Not equivalent: buggy rule " ++ show r
       NotEquivalent s ->
          spanClass "error" $ string $ if null s then "Not equivalent" else s
       Similar _ s ->
-         h2 "Similar term" <> encodeState lm dr // s
+         h2 "Similar term" <> encodeState dr s
       WrongRule _ s mr ->
          h2 ("WrongRule " ++ maybe "" showId mr)
-         <> encodeState lm dr // s
+         <> encodeState dr s
       Expected _ s r ->
          h2 ("Expected (" ++ show r ++ ")")
-         <> encodeState lm dr // s
+         <> encodeState dr s
       Detour _ s _ r ->
          h2 ("Detour (" ++ show r ++ ")")
-         <> encodeState lm dr // s
+         <> encodeState dr s
       Correct _ s ->
-         h2 "Correct" <> encodeState lm dr // s
+         h2 "Correct" <> encodeState dr s
       Unknown _ s ->
-         h2 "Unknown" <> encodeState lm dr // s
+         h2 "Unknown" <> encodeState dr s
 
-htmlDescription :: HasId a => a -> HTMLBuilder
-htmlDescription a = munless (null (description a)) $
-   para $
-      bold (string "Description") <> br
-      <> spanClass "description" (string (description a))
+htmlDescription :: HasId a => String -> a -> HTMLBuilder
+htmlDescription tp a = munless (null (description a)) $
+   para $ panel $ barPos CenterLeft $ borderTheme $ background LightGray $ para $ mconcat
+      [ bold $ string $ tp ++ " " ++ showId a
+      , br
+      , italic $ string $ description a
+      ]
 
 submitForm :: HTMLBuilder -> HTMLBuilder
-submitForm this = element "form"
-   [ "name"     .=. "myform"
-   , "onsubmit" .=. "return submitTerm()"
-   , "method"   .=. "post"
-   , this
-   , element "input" ["type" .=. "text", "name" .=. "myterm"]
-   , element "input" ["type"  .=. "submit", "value" .=. "Submit"]
-   ]
+submitForm this = form . padding Tiny $ mconcat
+  [ para $ mconcat [termLabel, termInput mempty]
+  , this
+  , para $ submitBtn mempty
+  ]
+ where
+   form      = tag "form"  . ("name" .=. "myform" <>) . ("method" .=. "post" <>) . ("onsubmit" .=. "return submitTerm()" <>) . w3class "w3-container"
+   termLabel = tag "label" $ tag "b" "Input:"
+   termInput = tag "input" . ("name" .=. "myterm" <>) . ("type" .=. "text" <>) . border . W3.input
+   submitBtn = tag "input" . ("value" .=. "Submit" <>) . ("type" .=. "submit" <>) . theme L1 . W3.w3class "w3-button"
 
 -- stateinfo service
 submitStateInfo :: LinkManager -> Exercise a -> HTMLBuilder
@@ -613,7 +663,7 @@    request = "<request service='stateinfo' exerciseid='" ++ showId ex
           ++ "' encoding='html'><state><expr>\" + getTerm() + \"</expr></state></request>"
 
--- diagnose service
+-- diagnose service *here*
 submitDiagnose :: LinkManager -> State a -> HTMLBuilder
 submitDiagnose lm st = submitForm mempty <> submitRequest lm request
  where
@@ -639,7 +689,7 @@ submitURL :: String -> HTMLBuilder
 submitURL url = tag "script" $
    ("type" .=. "text/javascript")
-   <> unescaped (
+   <> string ( -- script is not to be escaped
       "function getTerm() {\
       \   var s = document.myform.myterm.value;\
       \   var result = '';\
src/Ideas/Encoding/EncoderJSON.hs view
@@ -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 2019, Ideas project team. This file is distributed `r 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,47 +12,49 @@ -- Services using JSON notation
 --
 -----------------------------------------------------------------------------
---  $Id: EncoderJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.EncoderJSON (jsonEncoder) where
 
-import Ideas.Common.Library hiding (exerciseId, (<|>), (<*>))
-import Ideas.Common.Utils (Some(..), distinct)
+import Control.Applicative hiding (Const)
+import Data.Maybe
+import Ideas.Common.Library hiding (exerciseId)
 import Ideas.Encoding.Encoder
+import Ideas.Encoding.Request
 import Ideas.Service.State
 import Ideas.Service.Types hiding (String)
 import Ideas.Text.JSON
+import Ideas.Utils.Prelude (distinct)
 import qualified Ideas.Service.Diagnose as Diagnose
 import qualified Ideas.Service.Submit as Submit
 import qualified Ideas.Service.Types as Tp
 
-type JSONEncoder a t = Encoder a t JSON
+type JSONEncoder a = EncoderX a JSON
 
 jsonEncoder :: TypedEncoder a JSON
-jsonEncoder = encoderFor $ \tv@(val ::: tp) ->
+jsonEncoder tv@(val ::: tp) =
    case tp of
       _ | length (tupleList tv) > 1 ->
-         jsonTuple <$> sequence [ jsonEncoder // x | x <- tupleList tv ]
-      Iso p t   -> jsonEncoder // (to p val ::: t)
+         jsonTuple <$> sequence [ jsonEncoder x | x <- tupleList tv ]
+      Iso p t   -> jsonEncoder (to p val ::: t)
       t1 :|: t2 -> case val of
-         Left  x -> jsonEncoder // (x ::: t1)
-         Right y -> jsonEncoder // (y ::: t2)
+         Left  x -> jsonEncoder (x ::: t1)
+         Right y -> jsonEncoder (y ::: t2)
       Pair t1 t2 ->
          let f x y = jsonTuple [x, y]
-         in liftA2 f (jsonEncoder // (fst val ::: t1))
-                     (jsonEncoder // (snd val ::: t2))
+         in liftA2 f (jsonEncoder (fst val ::: t1))
+                     (jsonEncoder (snd val ::: t2))
       List (Const Rule) ->
-         pure $ Array $ map ruleShortInfo val
+         return $ Array $ map ruleShortInfo val
       Tp.Tag s t
-         | s == "Result"     -> encodeTyped encodeResult Submit.tResult
-         | s == "Diagnosis"  -> encodeTyped encodeDiagnosis Diagnose.tDiagnosis
-         | s == "Derivation" -> (encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?>
-                                encodeTyped encodeDerivationText (tDerivation tString tContext)
-         | s == "elem"       -> jsonEncoder // (val ::: t)
-         | otherwise -> (\b -> Object [(s, b)]) <$> jsonEncoder // (val ::: t)
-      Tp.Unit   -> pure Null
-      Tp.List t -> Array <$> sequence [ jsonEncoder // (x ::: t) | x <- val ]
-      Const ctp -> jsonEncodeConst // (val ::: ctp)
+         | s == "Result"     -> encodeTyped encodeResult Submit.tResult tv
+         | s == "Diagnosis"  -> encodeTyped encodeDiagnosis Diagnose.tDiagnosis tv
+         | s == "Derivation" -> ((encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?>
+                                encodeTyped encodeDerivationText (tDerivation tString tContext)) tv
+         | s == "elem"       -> jsonEncoder (val ::: t)
+         | otherwise -> (\b -> Object [(s, b)]) <$> jsonEncoder (val ::: t)
+      Tp.Unit   -> return Null
+      Tp.List t -> Array <$> sequence [ jsonEncoder (x ::: t) | x <- val ]
+      Const ctp -> jsonEncodeConst (val ::: ctp)
       _ -> fail $ "Cannot encode type: " ++ show tp
  where
    tupleList :: TypedValue (TypeRep f) -> [TypedValue (TypeRep f)]
@@ -60,78 +62,84 @@    tupleList (p ::: Tp.Pair t1 t2) =
       tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2)
    tupleList (x ::: Tag s t)
-      | s `elem` ["Message"] = tupleList (x ::: t)
+      | s == "Message" = tupleList (x ::: t)
    tupleList (ev ::: (t1 :|: t2)) =
       either (\x -> tupleList (x ::: t1))
              (\x -> tupleList (x ::: t2)) ev
-   tupleList tv = [tv]
+   tupleList a = [a]
 
-jsonEncodeConst :: JSONEncoder a (TypedValue (Const a))
-jsonEncodeConst = encoderFor $ \(val ::: tp) ->
+jsonEncodeConst :: TypedValue (Const a) -> JSONEncoder a
+jsonEncodeConst (val ::: tp) =
    case tp of
       SomeExercise -> case val of
-                         Some ex -> pure (exerciseInfo ex)
-      State        -> encodeState // val
-      Rule         -> pure (toJSON (showId val))
-      Context      -> encodeContext // val
-      Location     -> pure (toJSON (show val))
-      Environment  -> encodeEnvironment // val
-      Text         -> pure (toJSON (show val))
-      Int          -> pure (toJSON val)
-      Bool         -> pure (toJSON val)
-      Tp.String    -> pure (toJSON val)
+                         Some ex -> return (exerciseInfo ex)
+      State        -> encodeState val
+      Rule         -> return (toJSON (showId val))
+      Context      -> encodeContext val
+      Location     -> return (toJSON (show val))
+      Constraint   -> return (toJSON (show val))
+      Environment  -> encodeEnvironment val
+      Term         -> return (termToJSON val)
+      Text         -> return (toJSON (show val))
+      Int          -> return (toJSON val)
+      Bool         -> return (toJSON val)
+      Tp.String    -> return (toJSON val)
       _ -> fail $ "Type " ++ show tp ++ " not supported in JSON"
 
 --------------------------
 
 -- legacy representation
-encodeEnvironment :: JSONEncoder a Environment
-encodeEnvironment = makeEncoder $ \env ->
+encodeEnvironment :: Environment -> JSONEncoder a
+encodeEnvironment env = return $
    let f a = Object [(showId a, String (showValue a))]
    in Array [ f a | a <- bindings env ]
 
-encodeContext :: JSONEncoder a (Context a)
-encodeContext = exerciseEncoder $ \ex ctx ->
-   String $ prettyPrinterContext ex ctx
+encodeContext :: Context a -> JSONEncoder a
+encodeContext ctx = f . useJSONTerm <$> getRequest <*> getExercise
+ where
+   f True  ex = fromMaybe Null $ liftA2 build (hasJSONView ex) $ fromContext ctx
+   f False ex = String $ prettyPrinterContext ex ctx
 
-encodeState :: JSONEncoder a (State a)
-encodeState = encoderFor $ \st ->
-   let ctx = stateContext st
-       make pp env = Array
+encodeState :: State a -> JSONEncoder a
+encodeState st =
+   let ctx   = stateContext st
+       get f = String (fromMaybe "" (f st))
+       make pp env = Array $
           [ String $ showId (exercise st)
           , String $ if withoutPrefix st
-                     then "NoPrefix"
+                     then "no prefix"
                      else show (statePrefix st)
           , pp
           , env
-          ]
-   in make <$> (encodeContext // ctx) <*> (encodeStateEnvironment // ctx)
+          ] ++ if isNothing (stateUser st) then [] else
+          [ Array [get stateUser, get stateSession, get stateStartTerm] ]
+   in make <$> encodeContext ctx <*> encodeStateEnvironment ctx
 
-encodeStateEnvironment :: JSONEncoder a (Context a)
-encodeStateEnvironment = makeEncoder $ \ctx ->
+encodeStateEnvironment :: Context a -> JSONEncoder a
+encodeStateEnvironment ctx = return $
    let loc = fromLocation (location ctx)
        env = (if null loc then id else insertRef (makeRef "location") loc)
            $ environment ctx
    in Object [ (showId a, String $ showValue a) | a <- bindings env ]
 
-encodeDerivation :: JSONEncoder a (Derivation (Rule (Context a), Environment) (Context a))
-encodeDerivation = encoderFor $ \d ->
+encodeDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> JSONEncoder a
+encodeDerivation d =
    let xs = [ (s, a) | (_, s, a) <- triples d ]
-   in jsonEncoder // (xs ::: tList (tPair (tPair tRule tEnvironment) tContext))
+   in jsonEncoder (xs ::: tList (tPair (tPair tRule tEnvironment) tContext))
 
-encodeDerivationText :: JSONEncoder a (Derivation String (Context a))
-encodeDerivationText = encoderFor $ \d ->
+encodeDerivationText :: Derivation String (Context a) -> JSONEncoder a
+encodeDerivationText d =
    let xs = [ (s, a) | (_, s, a) <- triples d ]
-   in jsonEncoder // (xs ::: tList (tPair tString tContext))
+   in jsonEncoder (xs ::: tList (tPair tString tContext))
 
-encodeResult :: JSONEncoder a (Submit.Result a)
-encodeResult = encoderFor $ \result -> Object <$>
+encodeResult :: Submit.Result a -> JSONEncoder a
+encodeResult result = Object <$>
    case result of
-      Submit.Buggy rs -> pure
+      Submit.Buggy rs -> return
          [ ("result", String "Buggy")
          , ("rules", Array $ map (String . showId) rs)
          ]
-      Submit.NotEquivalent s -> pure $
+      Submit.NotEquivalent s -> return $
          ("result", String "NotEquivalent") :
          [ ("reason", String s) | not (null s)]
       Submit.Ok rs st ->
@@ -140,26 +148,28 @@                 , ("rules", Array $ map (String . showId) rs)
                 , ("state", x)
                 ]
-         in f <$> jsonEncoder // (st ::: tState)
+         in f <$> jsonEncoder (st ::: tState)
       Submit.Detour rs st ->
          let f x =
                 [ ("result", String "Detour")
                 , ("rules", Array $ map (String . showId) rs)
                 , ("state", x)
                 ]
-         in f <$> jsonEncoder // (st ::: tState)
+         in f <$> jsonEncoder (st ::: tState)
       Submit.Unknown st ->
          let f x =
                 [ ("result", String "Unknown")
                 , ("state", x)
                 ]
-         in f <$> jsonEncoder // (st ::: tState)
+         in f <$> jsonEncoder (st ::: tState)
 
-encodeDiagnosis :: JSONEncoder a (Diagnose.Diagnosis a)
-encodeDiagnosis = encoderFor $ \diagnosis ->
+encodeDiagnosis :: Diagnose.Diagnosis a -> JSONEncoder a
+encodeDiagnosis diagnosis =
    case diagnosis of
+      Diagnose.SyntaxError s ->
+         return $ Object [("syntaxerror", String s)]
       Diagnose.NotEquivalent s ->
-         if null s then pure (Object [("notequiv", Null)])
+         if null s then return (Object [("notequiv", Null)])
                    else make "notequiv" [fromReason s]
       Diagnose.Buggy env r ->
          make "buggy" [fromEnv env, fromRule r]
@@ -176,32 +186,22 @@       Diagnose.Unknown b st ->
          make "unknown" [fromReady b, fromState st]
  where
-   make s = liftA (\xs -> Object [(s, Array xs)]) . sequence
-   fromEnv env      = jsonEncoder // (env ::: tEnvironment)
-   fromRule r       = pure (toJSON (showId r))
-   fromMaybeRule mr = pure (maybe Null (toJSON . showId) mr)
-   fromReady b      = pure (Object [("ready", toJSON b)])
-   fromState st     = jsonEncoder // (st ::: tState)
-   fromReason s     = pure (Object [("reason", toJSON s)])
-
-{-
-encodeTree :: Tree JSON -> JSON
-encodeTree (Node r ts) =
-  case r of
-    Array [x, t] -> Object
-       [ ("rootLabel", x)
-       , ("type", t)
-       , ("subForest", Array $ map encodeTree ts)
-       ]
-    _ -> error "ModeJSON: malformed tree!" -}
+   make s = fmap (\xs -> Object [(s, Array xs)]) . sequence
+   fromEnv env      = jsonEncoder (env ::: tEnvironment)
+   fromRule r       = return (toJSON (showId r))
+   fromMaybeRule mr = return (maybe Null (toJSON . showId) mr)
+   fromReady b      = return (Object [("ready", toJSON b)])
+   fromState st     = jsonEncoder (st ::: tState)
+   fromReason s     = return (Object [("reason", toJSON s)])
 
 jsonTuple :: [JSON] -> JSON
 jsonTuple xs =
-   case mapM f xs of
+   case catMaybes <$> mapM f xs of
       Just ys | distinct (map fst ys) -> Object ys
       _ -> Array xs
  where
-   f (Object [p]) = Just p
+   f (Object [p]) = Just (Just p)
+   f Null = Just Nothing
    f _ = Nothing
 
 ruleShortInfo :: Rule a -> JSON
src/Ideas/Encoding/EncoderXML.hs view
@@ -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 2019, 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,6 @@ -- Services using XML notation
 --
 -----------------------------------------------------------------------------
---  $Id: EncoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.EncoderXML
    ( XMLEncoder
@@ -20,12 +19,13 @@    ) where
 
 import Data.Char
+import Data.List
 import Data.Maybe
 import Data.Monoid
-import Ideas.Common.Library hiding (exerciseId, (:=), alternatives)
-import Ideas.Common.Utils (Some(..))
+import Ideas.Common.Library hiding (exerciseId)
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.OpenMathSupport
+import Ideas.Encoding.Request hiding (XML)
 import Ideas.Encoding.RulesInfo (rulesInfoXML)
 import Ideas.Encoding.StrategyInfo
 import Ideas.Service.Diagnose
@@ -34,12 +34,13 @@ import Ideas.Service.Types
 import Ideas.Text.OpenMath.Object
 import Ideas.Text.XML
+import Ideas.Utils.Prelude (munless)
 import qualified Ideas.Service.FeedbackText as FeedbackText
 import qualified Ideas.Service.ProblemDecomposition as PD
 
 -----------------
 
-type XMLEncoder a t = Encoder a t XMLBuilder
+type XMLEncoder a = EncoderX a XMLBuilder
 
 xmlEncoder :: TypedEncoder a XMLBuilder
 xmlEncoder =
@@ -49,95 +50,100 @@    (encodeDerivationText, tDerivation tString tContext) <?>
    (encodeDifficulty, tDifficulty) <?>
    (encodeMessage, FeedbackText.tMessage) <?>
-   encoderFor (\(val ::: tp) ->
-        case tp of
-           -- meta-information
-           Tag "RuleShortInfo" t ->
-              case equal t (Const Rule) of
-                 Just f  -> ruleShortInfo // f val
-                 Nothing -> fail "rule short info"
-           Tag "RulesInfo" _ ->
-              withExercise $ \ex ->
-              withOpenMath $ \useOM ->
-                 pure (rulesInfoXML ex (buildTerm useOM ex))
-           Tag "elem" t ->
-              tag "elem" (xmlEncoder // (val ::: t))
-           -- special cases for lists
-           List (Const Rule) ->
-              encodeAsList [ ruleShortInfo // r | r <- val ]
-           List t ->
-              encodeAsList [ xmlEncoder // (a ::: t) | a <- val ]
-           -- standard
-           Tag _ t    -> xmlEncoder // (val ::: t)
-           Iso iso t  -> xmlEncoder // (to iso val ::: t)
-           Pair t1 t2 -> xmlEncoder // (fst val ::: t1) <>
-                         xmlEncoder // (snd val ::: t2)
-           t1 :|: t2  -> case val of
-                            Left  a -> xmlEncoder // (a ::: t1)
-                            Right b -> xmlEncoder // (b ::: t2)
-           Unit       -> mempty
-           Const t    -> xmlEncoderConst // (val ::: t)
-           _ -> fail $ show tp)
+   \(val ::: tp) ->
+   case tp of
+      -- meta-information
+      Tag "RuleShortInfo" t ->
+         case equal t (Const Rule) of
+            Just f  -> ruleShortInfo (f val)
+            Nothing -> fail "rule short info"
+      Tag "RulesInfo" _ -> do
+         ex    <- getExercise
+         useOM <- useOpenMath <$> getRequest
+         return (rulesInfoXML ex (buildExpression useOM ex))
+      Tag "elem" t ->
+         tag "elem" (xmlEncoder (val ::: t))
+      -- special cases for lists
+      List (Const Rule) ->
+         encodeAsList [ ruleShortInfo r | r <- val ]
+      List t ->
+         encodeAsList [ xmlEncoder (a ::: t) | a <- val ]
+      -- standard
+      Tag _ t    -> xmlEncoder (val ::: t)
+      Iso iso t  -> xmlEncoder (to iso val ::: t)
+      Pair t1 t2 -> xmlEncoder (fst val ::: t1) <>
+                    xmlEncoder (snd val ::: t2)
+      t1 :|: t2  -> case val of
+                       Left  a -> xmlEncoder (a ::: t1)
+                       Right b -> xmlEncoder (b ::: t2)
+      Unit       -> mempty
+      Const t    -> xmlEncoderConst (val ::: t)
+      _ -> fail $ show tp
 
-xmlEncoderConst :: XMLEncoder a (TypedValue (Const a))
-xmlEncoderConst = encoderFor $ \tv@(val ::: tp) ->
+xmlEncoderConst :: TypedValue (Const a) -> XMLEncoder a
+xmlEncoderConst tv@(val ::: tp) =
    case tp of
       SomeExercise -> case val of
-                         Some a -> exerciseInfo // a
+                         Some a -> exerciseInfo a
       Strategy     -> builder (strategyToXML val)
       Rule         -> "ruleid" .=. show val
-      State        -> encodeState // val
-      Context      -> encodeContext // val
-      Location     -> encodeLocation // val
-      Environment  -> encodeEnvironment // val
-      Text         -> encodeText // val
+      Constraint   -> "constraint" .=. show val
+      State        -> encodeState val
+      Context      -> encodeContext val
+      Location     -> encodeLocation val
+      Environment  -> encodeEnvironment val
+      Term         -> builderXML (toOMOBJ val)
+      Text         -> encodeText val
       Bool         -> string (showBool val)
+      XML          -> builder val
       _            -> text tv
 
-encodeState :: XMLEncoder a (State a)
-encodeState = encoderFor $ \st -> element "state"
+encodeState :: State a -> XMLEncoder a
+encodeState st = element "state"
    [ if withoutPrefix st
      then mempty
      else element "prefix" [string (show (statePrefix st))]
-   , encodeContext // stateContext st
+   , encodeContext (stateContext st)
    ]
 
-encodeContext :: XMLEncoder a (Context a)
-encodeContext = withOpenMath $ \useOM -> exerciseEncoder $ \ex ctx ->
-   maybe (error "encodeContext") (buildTerm useOM ex) (fromContext ctx)
-   <>
-   let values = bindings (withLoc ctx)
-       loc    = fromLocation (location ctx)
-       withLoc
-          | null loc  = id
-          | otherwise = insertRef (makeRef "location") loc
-   in munless (null values) $ element "context"
-         [  element "item"
-               [ "name"  .=. showId tb
-               , case getTermValue tb of
-                    term | useOM ->
-                       builder (omobj2xml (toOMOBJ term))
-                    _ -> "value" .=. showValue tb
-               ]
-         | tb <- values
-         ]
+encodeContext :: Context a -> XMLEncoder a
+encodeContext ctx = do
+   ex    <- getExercise
+   useOM <- useOpenMath <$> getRequest
+   maybe (error "encodeContext") (buildExpression useOM ex) (fromContext ctx)
+      <>
+      let values = bindings (withLoc ctx)
+          loc    = fromLocation (location ctx)
+          withLoc
+             | null loc  = id
+             | otherwise = insertRef (makeRef "location") loc
+      in munless (null values) $ element "context"
+            [  element "item"
+                  [ "name"  .=. showId tb
+                  , case getTermValue tb of
+                       term | useOM ->
+                          builder (omobj2xml (toOMOBJ term))
+                       _ -> "value" .=. showValue tb
+                  ]
+            | tb <- values
+            ]
 
-buildTerm :: BuildXML b => Bool -> Exercise a -> a -> b
-buildTerm useOM ex
-   | useOM     = either msg (builder . toXML) . toOpenMath ex
+buildExpression :: BuildXML b => Bool -> Exercise a -> a -> b
+buildExpression useOM ex
+   | useOM     = either msg builderXML . toOpenMath ex
    | otherwise = tag "expr" . string . prettyPrinter ex
  where
    msg s = error ("Error encoding term in OpenMath: " ++ s)
 
-encodeLocation :: XMLEncoder a Location
-encodeLocation = encoderFor $ \loc -> "location" .=. show loc
+encodeLocation :: Location -> XMLEncoder a
+encodeLocation loc = "location" .=. show loc
 
-encodeEnvironment :: HasEnvironment env => XMLEncoder a env
-encodeEnvironment = encoderFor $ \env ->
-   mconcat [ encodeTypedBinding // b | b <- bindings env ]
+encodeEnvironment :: HasEnvironment env => env -> XMLEncoder a
+encodeEnvironment env = mconcat [ encodeTypedBinding b | b <- bindings env ]
 
-encodeTypedBinding :: XMLEncoder a Binding
-encodeTypedBinding = withOpenMath $ \useOM -> makeEncoder $ \tb ->
+encodeTypedBinding :: Binding -> XMLEncoder a
+encodeTypedBinding tb = do
+   useOM <- useOpenMath <$> getRequest
    tag "argument" $
       ("description" .=. showId tb) <>
       case getTermValue tb of
@@ -145,91 +151,94 @@             omobj2xml $ toOMOBJ term
          _ -> string (showValue tb)
 
-encodeDerivation :: XMLEncoder a (Derivation (Rule (Context a), Environment) (Context a))
-encodeDerivation = encoderFor $ \d ->
+encodeDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> XMLEncoder a
+encodeDerivation d =
    let xs = [ (s, a) | (_, s, a) <- triples d ]
-   in xmlEncoder // (xs ::: tList (tPair (tPair tRule tEnvironment) tContext))
+   in xmlEncoder (xs ::: tList (tPair (tPair tRule tEnvironment) tContext))
 
-encodeDerivationText :: XMLEncoder a (Derivation String (Context a))
-encodeDerivationText = encoderFor $ \d -> encodeAsList
-   [ ("ruletext" .=. s) <> encodeContext // a
+encodeDerivationText :: Derivation String (Context a) -> XMLEncoder a
+encodeDerivationText d = encodeAsList
+   [ ("ruletext" .=. s) <> encodeContext a
    | (_, s, a) <- triples d
    ]
 
-ruleShortInfo :: XMLEncoder a (Rule (Context a))
-ruleShortInfo = makeEncoder $ \r -> mconcat
+ruleShortInfo :: Rule (Context a) -> XMLEncoder a
+ruleShortInfo r = mconcat
    [ "name"        .=. showId r
    , "buggy"       .=. showBool (isBuggy r)
    , "arguments"   .=. show (length (getRefs r))
    , "rewriterule" .=. showBool (isRewriteRule r)
    ]
 
-encodeDifficulty :: XMLEncoder a Difficulty
-encodeDifficulty = makeEncoder $ \d ->
+encodeDifficulty :: Difficulty -> XMLEncoder a
+encodeDifficulty d =
    "difficulty" .=. show d
 
-encodeText :: XMLEncoder a Text
-encodeText = encoderFor $ \txt ->
-   mconcat [ encodeItem // item | item <- textItems txt ]
+encodeText :: Text -> XMLEncoder a
+encodeText txt = do
+   ex    <- getExercise
+   useOM <- useOpenMath <$> getRequest
+   mconcat (intersperse (string " ") [ encodeItem ex useOM item | item <- textItems txt ])
  where
-   encodeItem = withOpenMath $ \useOM -> exerciseEncoder $ \ex item ->
+   encodeItem ex useOM item =
       case item of
          TextTerm a -> fromMaybe (text item) $ do
             v <- hasTermView ex
             b <- match v a
-            return (buildTerm useOM ex b)
+            return (buildExpression useOM ex b)
          _ -> text item
 
-encodeMessage :: XMLEncoder a FeedbackText.Message
-encodeMessage = encoderFor $ \msg ->
+encodeMessage :: FeedbackText.Message -> XMLEncoder a
+encodeMessage msg =
    element "message"
       [ case FeedbackText.accept msg of
            Just b  -> "accept" .=. showBool b
            Nothing -> mempty
-      , encodeText // FeedbackText.text msg
+      , encodeText (FeedbackText.text msg)
       ]
 
-encodeDiagnosis :: XMLEncoder a (Diagnosis a)
-encodeDiagnosis = encoderFor $ \diagnosis ->
+encodeDiagnosis :: Diagnosis a -> XMLEncoder a
+encodeDiagnosis diagnosis =
    case diagnosis of
+      SyntaxError s -> element "syntaxerror" [string s]
       Buggy env r -> element "buggy"
-         [encodeEnvironment // env, "ruleid" .=. showId r]
+         [encodeEnvironment env, "ruleid" .=. showId r]
       NotEquivalent s ->
           if null s then emptyTag "notequiv"
                     else element "notequiv" [ "reason" .=.  s ]
       Similar b st -> element "similar"
-         ["ready" .=. showBool b, encodeState // st]
+         ["ready" .=. showBool b, encodeState st]
       WrongRule b st mr -> element "wrongrule" $
-         [ "ready" .=. showBool b, encodeState // st ] ++
+         [ "ready" .=. showBool b, encodeState st ] ++
          maybe [] (\r -> ["ruleid" .=. showId r]) mr
       Expected b st r -> element "expected"
-         ["ready" .=. showBool b, encodeState // st, "ruleid" .=. showId r]
+         ["ready" .=. showBool b, encodeState st, "ruleid" .=. showId r]
       Detour b st env r -> element "detour"
-         [ "ready" .=. showBool b, encodeState // st
-         , encodeEnvironment // env, "ruleid" .=. showId r
+         [ "ready" .=. showBool b, encodeState st
+         , encodeEnvironment env, "ruleid" .=. showId r
          ]
       Correct b st -> element "correct"
-         ["ready" .=. showBool b, encodeState // st]
+         ["ready" .=. showBool b, encodeState st]
       Unknown b st -> element "unknown"
-         ["ready" .=. showBool b, encodeState // st]
+         ["ready" .=. showBool b, encodeState st]
 
-encodeDecompositionReply :: XMLEncoder a (PD.Reply a)
-encodeDecompositionReply = encoderFor $ \reply ->
+encodeDecompositionReply :: PD.Reply a -> XMLEncoder a
+encodeDecompositionReply reply =
    case reply of
       PD.Ok loc st ->
-         element "correct" [encLoc loc, encodeState // st]
+         element "correct" [encLoc loc, encodeState st]
       PD.Incorrect eq loc st env ->
          element "incorrect"
             [ "equivalent" .=. showBool eq
             , encLoc loc
-            , encodeState // st
-            , encodeEnvironment // env
+            , encodeState st
+            , encodeEnvironment env
             ]
  where
     encLoc = tag "location" . text
 
-exerciseInfo :: XMLEncoder a (Exercise b)
-exerciseInfo = encoderFor $ \ex -> mconcat
+exerciseInfo :: Exercise b -> XMLEncoder a
+exerciseInfo ex = mconcat
    [ "exerciseid"  .=. showId ex
    , "description" .=. description ex
    , "status"      .=. show (status ex)
@@ -238,7 +247,7 @@ ------------------------------------------------
 -- helpers
 
-encodeAsList :: [XMLEncoder a t] -> XMLEncoder a t
+encodeAsList :: [XMLEncoder a] -> XMLEncoder a
 encodeAsList = element "list" . map (tag "elem")
 
 showBool :: Bool -> String
src/Ideas/Encoding/Evaluator.hs view
@@ -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 2019, 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,61 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Evaluator.hs 7524 2015-04-08 07:31:15Z 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.Encoding.Logging
+import Ideas.Encoding.Options
+import Ideas.Service.Diagnose
 import Ideas.Service.Types
+import Ideas.Utils.Decoding
 
 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 :: Options -> EvalResult a c -> Type a b -> (b -> Record -> Record) -> IO ()
+logType opts res tp f =
+   case concatMap (findValuesOfType tp) (values res) of
+      []   -> return ()
+      hd:_ -> changeLog (logRef opts) (f hd)
+
+evalService :: Exercise a -> Options -> Evaluator a b c -> Service -> b -> IO c
+evalService ex opts f srv b = do
+   res <- eval ex opts f b (serviceFunction srv)
+   logType opts res tState addState
+   logType opts res tRule $ \rl r -> r {ruleid = showId rl}
+   logType opts res tDiagnosis $ \d r -> r {serviceinfo = show d}
+   return (evalResult res)
+
+eval :: Exercise a -> Options -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c)
+eval ex 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   <- runDecoder (dec t1) (ex, 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 <- runEncoder (enc tv) (ex, opts)
+            return $ EvalResult [] tv c
src/Ideas/Encoding/LinkManager.hs view
@@ -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 2019, 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,12 +12,11 @@ -- Manages links to information
 --
 -----------------------------------------------------------------------------
---  $Id: LinkManager.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.LinkManager
-   ( LinkManager(..)
-   , dynamicLinks, stateToXML
-   , staticLinks, linksUp, pathLevel, (</>)
+   ( LinkManager(..), makeLinkManager
+   , stateToXML
+   -- , pathLevel, (</>)
      -- links to services and exercises
    , linkToIndex, linkToExercises, linkToServices, linkToService
      -- links to exercise information
@@ -26,22 +25,24 @@      -- links to state information (dynamic)
    , linkToState, linkToFirsts, linkToApplications, linkToDerivation
    , linkToMicrosteps
+   , escapeInURL
    ) where
 
 import Data.Maybe
+import Data.Monoid
 import Ideas.Common.Library
-import Ideas.Encoding.Encoder
 import Ideas.Encoding.EncoderXML
+import Ideas.Encoding.Options
 import Ideas.Service.State
 import Ideas.Service.Types
 import Ideas.Text.HTML
 import Ideas.Text.XML
+import Ideas.Utils.Decoding
 
 data LinkManager = LinkManager
    { urlForCSS           :: String -> String
    , urlForImage         :: String -> String
    , urlForRequest       :: String
-   , isStatic            :: Bool
      -- links to services and exercises
    , urlForIndex         :: String
    , urlForExercises     :: String
@@ -51,6 +52,7 @@    , urlForExercise      :: forall a . Exercise a -> String
    , urlForStrategy      :: forall a . Exercise a -> String
    , urlForRules         :: forall a . Exercise a -> String
+   , urlForConstraints   :: forall a . Exercise a -> String
    , urlForExamples      :: forall a . Exercise a -> String
    , urlForDerivations   :: forall a . Exercise a -> String
    , urlForRule          :: forall a . Exercise a -> Rule (Context a) -> String
@@ -131,12 +133,11 @@ ---------------------------------------------------------------------
 -- Dynamic links
 
-dynamicLinks :: String -> LinkManager
-dynamicLinks cgiBinary = LinkManager
-   { isStatic        = False
-   , urlForRequest   = prefix
-   , urlForCSS       = ("http://ideas.cs.uu.nl/css/" ++)
-   , urlForImage     = ("http://ideas.cs.uu.nl/images/" ++)
+makeLinkManager :: String -> String -> LinkManager
+makeLinkManager base cgiBinary = LinkManager
+   { urlForRequest   = prefix
+   , urlForCSS       = \s -> base ++ "css/" ++ s
+   , urlForImage     = \s -> base ++ "images/" ++ s
    , urlForIndex     = url $ simpleRequest "index"
    , urlForExercises = url $ simpleRequest "exerciselist"
    , urlForServices  = url $ simpleRequest "servicelist"
@@ -145,6 +146,7 @@    , urlForExercise    = url . exerciseRequest "exerciseinfo"
    , urlForStrategy    = url . exerciseRequest "strategyinfo"
    , urlForRules       = url . exerciseRequest "rulelist"
+   , urlForConstraints = url . exerciseRequest "constraintlist"
    , urlForTestReport  = url . exerciseRequest "testreport"
    , urlForExamples    = url . exerciseRequest "examples"
    , urlForDerivations = url . exerciseRequest "examplederivations"
@@ -187,7 +189,7 @@ -- assume nothing goest wrong
 stateToXML :: State a -> XMLBuilder
 stateToXML st = fromMaybe (error "LinkManager: Invalid state") $
-   run encodeState (simpleOptions (exercise st)) st
+   runEncoder (encodeState st) (exercise st, optionHtml mempty)
 
 linkWith :: (a -> String) -> a -> HTMLBuilder -> HTMLBuilder
 linkWith f = link . escapeInURL . f
@@ -201,80 +203,4 @@    f '%' = "%25"
    f '#' = "%23"
    f ';' = "%3B"
-   f c   = [c]
-
----------------------------------------------------------------------
--- Static links
-
-staticLinks :: LinkManager
-staticLinks = LinkManager
-   { isStatic        = True
-   , urlForCSS       = id
-   , urlForImage     = id
-   , urlForRequest   = ""
-   , -- links to services and exercises
-     urlForIndex     = "index.html"
-   , urlForExercises = "exercises.html"
-   , urlForServices  = "services.html"
-   , urlForService   = \srv -> "services" </> idToFilePath srv
-     -- links to exercise information
-   , urlForExercise    = idToFilePath
-   , urlForStrategy    = idToFilePathWith "-strategy.html"
-   , urlForRules       = idToFilePathWith "-rules.html"
-   , urlForExamples    = idToFilePathWith "-examples.html"
-   , urlForDerivations = idToFilePathWith "-derivations.html"
-   , urlForRule        = \ex r -> idToFilePathWith ("/" ++ showId r ++ ".html") ex
-   , urlForTestReport  = idToFilePathWith "-testreport.html"
-     -- dynamic exercise information
-   , urlForRandomExample = \_ _ -> ""
-     -- dynamic state information
-   , urlForState        = const ""
-   , urlForFirsts       = const ""
-   , urlForApplications = const ""
-   , urlForDerivation   = const ""
-   , urlForMicrosteps   = const ""
-   }
-
-linksUp :: Int -> LinkManager -> LinkManager
-linksUp n lm = lm
-   { isStatic        = isStatic lm
-     -- links to services and exercises
-   , urlForIndex     = f0 urlForIndex
-   , urlForExercises = f0 urlForExercises
-   , urlForServices  = f0 urlForServices
-   , urlForService   = f1 urlForService
-     -- links to exercise information
-   , urlForExercise    = f1 urlForExercise
-   , urlForStrategy    = f1 urlForStrategy
-   , urlForRules       = f1 urlForRules
-   , urlForExamples    = f1 urlForExamples
-   , urlForDerivations = f1 urlForDerivations
-   , urlForRule        = f2 urlForRule
-     -- dynamic exercise information
-   , urlForRandomExample = f2 urlForRandomExample
-     -- dynamic state information
-   , urlForState        = f1 urlForState
-   , urlForFirsts       = f1 urlForFirsts
-   , urlForApplications = f1 urlForApplications
-   , urlForDerivation   = f1 urlForDerivation
-   , urlForMicrosteps   = f1 urlForMicrosteps
-   }
- where
-   f0 g   = pathUp n $ g lm
-   f1 g   = pathUp n . g lm
-   f2 g x = pathUp n . g lm x
-
-pathUp :: Int -> FilePath -> FilePath
-pathUp n file = concat (replicate n "../") ++ file
-
-pathLevel :: FilePath -> Int
-pathLevel = length . filter (=='/')
-
-idToFilePath :: HasId a => a -> FilePath
-idToFilePath = idToFilePathWith ".html"
-
-idToFilePathWith :: HasId a => String -> a -> FilePath
-idToFilePathWith suffix a = foldr (</>) (unqualified a ++ suffix) (qualifiers a)
-
-(</>) :: String -> FilePath -> FilePath
-x </> y = x ++ "/" ++ y+   f c   = [c]
+ src/Ideas/Encoding/Logging.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE CPP, FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Encoding.Logging
+   ( Record(..), addRequest, addState
+   , LogRef, makeLogRef, defaultLogRef, enableLogging, disableLogging
+   , changeLog, logEnabled, logRecord, logRecordWith, printLog
+   , selectFrom
+   , getRecord
+   , getFilePath
+   ) where
+
+import Control.Monad
+import Data.Char
+import Data.IORef
+import Data.Maybe
+import Data.Semigroup (Semigroup(..))
+import Data.Time
+import Ideas.Encoding.Request (Request, Schema(..))
+import Ideas.Service.State
+import qualified Ideas.Encoding.Request as R
+
+#ifdef DB
+import Data.List
+import Database.HDBC
+import Database.HDBC.Sqlite3 (connectSqlite3, setBusyTimeout)
+#endif
+
+type Diff = NominalDiffTime
+type Time = UTCTime
+
+-- | The Record datatype is based on the Ideas Request Logging Schema version 2.
+data Record = Record
+   { useLogging   :: Bool
+     -- 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 True "" "" "" "" "" "" "" "" "" "" 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)
+   }
+
+---------------------------------------------------------------------
+
+data LogRef = NoRef | LogRef FilePath Schema (IORef Record)
+
+instance Semigroup LogRef where
+   NoRef <> r = r
+   r <> _     = r
+
+instance Monoid LogRef where
+   mempty  = NoRef
+   mappend = (<>)
+
+defaultLogRef :: IO LogRef
+defaultLogRef = makeLogRef "requests.db" V2
+
+makeLogRef :: FilePath -> Schema -> IO LogRef
+makeLogRef file schema = do
+   r   <- makeRecord
+   ref <- newIORef r
+   return (LogRef file schema ref)
+
+enableLogging :: LogRef -> IO ()
+enableLogging = flip changeLog (\r -> r {useLogging = True})
+
+disableLogging :: LogRef -> IO ()
+disableLogging = flip changeLog (\r -> r {useLogging = False})
+
+whenLogging :: LogRef -> IO () -> IO ()
+whenLogging logRef m = do
+   r <- getRecord logRef
+   when (useLogging r) m
+
+getRecord :: LogRef -> IO Record
+getRecord NoRef          = return record
+getRecord (LogRef _ _ r) = readIORef r
+
+getFilePath :: LogRef -> Maybe FilePath
+getFilePath NoRef = Nothing
+getFilePath (LogRef fp _ _) = Just fp
+
+changeLog :: LogRef -> (Record -> Record) -> IO ()
+changeLog NoRef          _ = return ()
+changeLog (LogRef _ _ r) f = modifyIORef r f
+
+printLog :: LogRef -> IO ()
+printLog logRef = do
+   putStrLn "-- log information"
+   getRecord logRef >>= print
+
+--------------------------------------------------------------------------------
+
+logEnabled :: Bool
+logRecord  :: LogRef -> IO ()
+selectFrom :: FilePath -> String -> [String] -> ([String] -> IO a) -> IO [a]
+
+#ifdef DB
+logEnabled = True
+#else
+-- without logging
+logEnabled         = False
+logRecord _        = return ()
+selectFrom _ _ _ _ = return []
+
+logRecordWith :: LogRef -> c -> IO ()
+logRecordWith _ _ = 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
+      ]
+
+logRecord NoRef  = return ()
+logRecord logRef@(LogRef file _ _) =
+   (whenLogging logRef) $ do
+      -- connect to database
+      conn <- connectSqlite3 file
+      setBusyTimeout conn 200 -- milliseconds
+      logRecordWith logRef conn
+      -- close the connection to the database
+      disconnect conn
+    `catchSql` \_ ->
+      return ()
+
+logRecordWith :: IConnection c => LogRef -> c -> IO ()
+logRecordWith NoRef _  = return ()
+logRecordWith logRef@(LogRef _ schema _) 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
+ `catchSql` \_ ->
+   return ()
+
+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
+
+selectFrom database table columns f = do
+   let sql    = "SELECT " ++ commas (map safe columns) ++ " from " ++ safe table
+       commas = intercalate ","
+       safe   = filter isAlphaNum
+   con  <- connectSqlite3 database
+   stat <- prepare con sql
+   _    <- execute stat []
+   rows <- fetchAllRows stat
+   xs   <- mapM (f . map fromSql) rows
+   disconnect con
+   return xs
+#endif
src/Ideas/Encoding/ModeJSON.hs view
@@ -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 2019, 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,27 +11,32 @@ -- Services using JSON notation
 --
 -----------------------------------------------------------------------------
---  $Id: ModeJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.ModeJSON (processJSON) where
 
+import Control.Monad
 import Data.Char
+import Data.Maybe
+import Data.Semigroup ((<>))
 import Ideas.Common.Library hiding (exerciseId)
-import Ideas.Common.Utils (Some(..), timedSeconds)
 import Ideas.Encoding.DecoderJSON
-import Ideas.Encoding.Encoder (makeOptions)
 import Ideas.Encoding.EncoderJSON
 import Ideas.Encoding.Evaluator
+import Ideas.Encoding.Logging (changeLog, errormsg)
+import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin, logRef)
+import Ideas.Encoding.Request
 import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
 import Ideas.Text.JSON
+import Ideas.Utils.Prelude (timedSeconds)
 
-processJSON :: Maybe Int -> Maybe String -> DomainReasoner -> String -> IO (Request, String, String)
-processJSON maxTime cgiBin dr input = do
-   json <- either fail return (parseJSON input)
-   req  <- jsonRequest cgiBin json
+processJSON :: Options -> DomainReasoner -> String -> IO (Request, String, String)
+processJSON options dr txt = do
+   json <- either fail return (parseJSON txt)
+   req  <- jsonRequest options json
    resp <- jsonRPC json $ \fun arg ->
-              maybe id timedSeconds maxTime (myHandler dr req fun arg)
+              maybe id timedSeconds (maxTime options) (myHandler options dr req fun arg)
+   unless (responseError resp == Null) $
+      changeLog (logRef options) (\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")
@@ -47,7 +52,7 @@       Array (hd:_) -> extractExerciseId hd
       _ -> fail "no code"
  where
-   p c = not (isAlphaNum c || isSpace c || c `elem` ".-")
+   p c = not (isAlphaNum c || isSpace c || c `elem` ".-_")
 
 addVersion :: String -> JSON -> JSON
 addVersion str json =
@@ -57,40 +62,52 @@  where
    info = ("version", String str)
 
-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"
+jsonRequest :: Monad m => Options -> JSON -> m Request
+jsonRequest options json = do
    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
-   return emptyRequest
-      { serviceId  = srv
-      , exerciseId = exId
-      , user       = uid
-      , source     = src
-      , cgiBinary  = cgiBin
-      , dataformat = JSON
-      , encoding   = enc
+   srv  <- stringOption  "method"      json newId
+   src  <- stringOption  "source"      json id
+   rinf <- stringOption  "requestinfo" json id
+   seed <- stringOptionM "randomseed"  json (defaultSeed options) (return . readM)
+   enc  <- stringOptionM "encoding"    json [] readEncoding
+   sch  <- stringOptionM "logging"     json Nothing (fmap Just . readSchema)
+   return mempty
+      { serviceId   = srv
+      , exerciseId  = exId
+      , source      = src
+      , cgiBinary   = cgiBin options
+      , requestInfo = rinf
+      , logSchema   = sch
+      , randomSeed  = seed
+      , dataformat  = Just JSON
+      , encoding    = enc
       }
 
-myHandler :: DomainReasoner -> Request -> RPCHandler
-myHandler dr request fun json = do
+-- Use a fixed seed for random number generation for command-line invocations
+defaultSeed :: Options -> Maybe Int
+defaultSeed options
+   | isJust (cgiBin options) = Nothing
+   | otherwise = Just 2805 -- magic number
+
+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 :: Options -> DomainReasoner -> Request -> RPCHandler
+myHandler opt1 dr request fun json = do
    srv <- findService dr (newId fun)
-   Some options <- makeOptions dr request
-   evalService options jsonEvaluator srv json
+   Some ex <- case exerciseId request of
+                 Just a  -> findExercise dr a
+                 Nothing -> return (Some emptyExercise)
+   opt2 <- makeOptions dr request
+   let options = opt1 <> opt2
+   evalService ex options jsonEvaluator srv json
 
 jsonEvaluator :: Evaluator a JSON JSON
 jsonEvaluator = Evaluator jsonDecoder jsonEncoder
src/Ideas/Encoding/ModeXML.hs view
@@ -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 2019, 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,42 +11,45 @@ -- Services using XML notation
 --
 -----------------------------------------------------------------------------
---  $Id: ModeXML.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.ModeXML (processXML) where
 
 import Control.Exception
 import Control.Monad
-import Data.Maybe
-import Ideas.Common.Library hiding (exerciseId, (:=))
-import Ideas.Common.Utils (Some(..), timedSeconds)
+import Data.Monoid
+import Ideas.Common.Library hiding (exerciseId)
 import Ideas.Encoding.DecoderXML
-import Ideas.Encoding.Encoder (makeOptions)
 import Ideas.Encoding.EncoderHTML
 import Ideas.Encoding.EncoderXML
 import Ideas.Encoding.Evaluator
+import Ideas.Encoding.Logging (changeLog, errormsg)
+import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin, logRef)
+import Ideas.Encoding.Request
 import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
 import Ideas.Text.HTML
 import Ideas.Text.XML
-import Prelude hiding (catch)
-import System.IO.Error hiding (catch)
+import Ideas.Utils.Prelude (timedSeconds)
+import System.IO.Error
 
-processXML :: Maybe Int -> Maybe String -> DomainReasoner -> String -> IO (Request, String, String)
-processXML maxTime cgiBin dr input = do
-   xml  <- either fail return (parseXML input)
-   req  <- xmlRequest cgiBin xml
-   resp <- maybe id timedSeconds maxTime (xmlReply dr req xml)
+processXML :: Options -> DomainReasoner -> String -> IO (Request, String, String)
+processXML options dr txt = do
+   xml  <- either fail return (parseXML txt)
+   req  <- xmlRequest (cgiBin options) xml
+   resp <- maybe id timedSeconds (maxTime options) (xmlReply options dr req xml)
     `catch` handler
    let showXML | compactOutput req = compactXML
-               | otherwise = show
+               | otherwise = prettyXML
+       showHtmlDoc doc = "<!DOCTYPE html>" ++ compactXML doc
    if htmlOutput req
-      then return (req, showXML resp, "text/html")
+      then return (req, showHtmlDoc resp, "text/html")
       else let out = addVersion (version dr) resp
            in return (req, showXML out, "application/xml")
  where
-   handler :: IOException -> IO XML
-   handler = return . resultError . ioeGetErrorString
+   handler :: SomeException -> IO XML
+   handler e = resultError options $
+      case fromException e of
+         Just ioe -> ioeGetErrorString ioe
+         Nothing  -> show e
 
 addVersion :: String -> XML -> XML
 addVersion s xml =
@@ -54,53 +57,64 @@    in xml { attributes = attributes xml ++ info }
 
 xmlRequest :: Monad m => Maybe String -> XML -> m Request
-xmlRequest cgiBin xml = do
+xmlRequest ms xml = do
    unless (name xml == "request") $
       fail "expected xml tag request"
    enc  <- case findAttribute "encoding" xml of
               Just s  -> readEncoding s
               Nothing -> return []
-   return emptyRequest
-      { serviceId      = fmap newId $ findAttribute "service" xml
+   return mempty
+      { serviceId      = newId <$> findAttribute "service" xml
       , exerciseId     = extractExerciseId xml
-      , user           = findAttribute "userid" xml
       , source         = findAttribute "source" xml
+      , cgiBinary      = ms
+      , requestInfo    = findAttribute "requestinfo" xml
+      , logSchema      = findAttribute "logging" xml >>= readSchema
       , feedbackScript = findAttribute "script" xml
-      , cgiBinary      = cgiBin
-      , dataformat     = XML
+      , randomSeed     = defaultSeed ms $
+                            findAttribute "randomseed" xml >>= readM
+      , dataformat     = Just XML
       , encoding       = enc
       }
 
-xmlReply :: DomainReasoner -> Request -> XML -> IO XML
-xmlReply dr request xml = do
+-- Use a fixed seed for random number generation for command-line invocations
+defaultSeed :: Maybe String -> Maybe Int -> Maybe Int
+defaultSeed Nothing Nothing = Just 2805 -- magic number
+defaultSeed _ m = m
+
+xmlReply :: Options -> DomainReasoner -> Request -> XML -> IO XML
+xmlReply opt1 dr request xml = do
    srv <- case serviceId request of
              Just a  -> findService dr a
              Nothing -> fail "No service"
 
-   Some options <- makeOptions dr request
+   Some ex <- case exerciseId request of
+                 Just a  -> findExercise dr a
+                 Nothing -> return (Some emptyExercise)
 
-   -- HTML evaluator
+   opt2 <- makeOptions dr request
+   let options = opt1 <> opt2
+
    if htmlOutput request
-      then do
-         res <- evalService options (htmlEvaluator dr) srv xml
-         return (toXML res)
+      -- HTML evaluator
+      then toXML <$> evalService ex options (htmlEvaluator dr) srv xml
       -- xml evaluator
-      else do
-         res <- evalService options xmlEvaluator srv xml
-         return (resultOk res)
+      else resultOk <$> evalService ex options xmlEvaluator srv xml
 
 extractExerciseId :: Monad m => XML -> m Id
-extractExerciseId = liftM newId . findAttribute "exerciseid"
+extractExerciseId = fmap newId . findAttribute "exerciseid"
 
 resultOk :: XMLBuilder -> XML
 resultOk body = makeXML "reply" $
    ("result" .=. "ok")
    <> body
 
-resultError :: String -> XML
-resultError txt = makeXML "reply" $
-   ("result" .=. "error")
-   <> tag "message" (string txt)
+resultError :: Options -> String -> IO XML
+resultError options msg = do
+   changeLog (logRef options) (\r -> r {errormsg = msg})
+   return $ makeXML "reply" $
+      ("result" .=. "error")
+      <> tag "message" (string msg)
 
 ------------------------------------------------------------
src/Ideas/Encoding/OpenMathSupport.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: OpenMathSupport.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.OpenMathSupport
    ( -- * Conversion functions to/from OpenMath
@@ -22,10 +21,10 @@ import Data.Char
 import Data.List
 import Ideas.Common.Library
-import Ideas.Common.Utils.Uniplate
 import Ideas.Text.OpenMath.Dictionary.Arith1
 import Ideas.Text.OpenMath.Dictionary.Fns1
 import Ideas.Text.OpenMath.Object
+import Ideas.Utils.Uniplate
 import qualified Ideas.Text.OpenMath.Dictionary.List1 as OM
 import qualified Ideas.Text.OpenMath.Symbol as OM
 
@@ -73,8 +72,8 @@          OMI n  -> return (TNum n)
          OMF a  -> return (TFloat a)
          OMA xs -> case xs of
-                      OMS s:ys | s == OM.listSymbol -> liftM TList (mapM rec ys)
-                               | otherwise -> liftM (function (newSymbol s)) (mapM rec ys)
+                      OMS s:ys | s == OM.listSymbol -> TList <$> mapM rec ys
+                               | otherwise -> function (newSymbol s) <$> mapM rec ys
                       _ -> fail "Invalid OpenMath object"
          OMBIND binder xs body ->
             rec (OMA (binder:map OMV xs++[body]))
+ src/Ideas/Encoding/Options.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Encoding.Options
+   ( Options, makeOptions, optionBaseUrl
+   , script, request, qcGen, baseUrl, maxTime, logRef
+   , cgiBin, optionCgiBin, optionHtml
+   ) where
+
+import Control.Applicative
+import Data.Maybe
+import Data.Semigroup as Sem
+import Ideas.Encoding.Logging (LogRef)
+import Ideas.Encoding.Request
+import Ideas.Service.DomainReasoner
+import Ideas.Service.FeedbackScript.Parser (parseScriptSafe, Script)
+import Test.QuickCheck.Random
+
+-------------------------------------------------------------------
+-- Options
+
+cgiBin :: Options -> Maybe String
+cgiBin = cgiBinary . request
+
+optionCgiBin :: String -> Options -> Options
+optionCgiBin s options = options {request = (request options) {cgiBinary = Just s}}
+
+data Options = Options
+   { request   :: Request      -- meta-information about the request
+   , qcGen     :: Maybe QCGen  -- random number generator
+   , script    :: Script       -- feedback script
+   , baseUrl   :: Maybe String -- for html-encoder's css and image files
+   , maxTime   :: Maybe Int    -- timeout for services, in seconds
+   , logRef    :: LogRef       -- reference for logging to database
+   }
+
+instance Sem.Semigroup Options where
+   x <> y = Options
+      { request   = request x <> request y
+      , qcGen     = make qcGen
+      , script    = script x <> script y
+      , baseUrl   = make baseUrl
+      , maxTime   = make maxTime
+      , logRef    = logRef x <> logRef y
+      }
+    where
+      make f = f x <|> f y
+
+instance Monoid Options where
+   mempty  = Options mempty Nothing mempty Nothing Nothing mempty
+   mappend = (<>)
+
+optionHtml :: Options -> Options
+optionHtml options = options
+   { request = (request options) {encoding = [EncHTML]} }
+
+optionBaseUrl :: String -> Options -> Options
+optionBaseUrl base options = options {baseUrl = Just base}
+
+makeOptions :: DomainReasoner -> Request -> IO Options
+makeOptions dr req = do
+   gen <- maybe newQCGen (return . mkQCGen) (randomSeed req)
+   scr <- case feedbackScript req of
+             Just s  -> parseScriptSafe s
+             Nothing -> defaultScript dr (fromMaybe mempty (exerciseId req))
+   return $ mempty
+      { request = req
+      , qcGen   = Just gen
+      , script  = scr
+      }
+ src/Ideas/Encoding/Request.hs view
@@ -0,0 +1,131 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Encoding.Request where
+
+import Control.Applicative
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Semigroup as Sem
+import Ideas.Common.Library hiding (exerciseId)
+import Ideas.Utils.Prelude
+
+data Request = Request
+   { serviceId      :: Maybe Id
+   , exerciseId     :: Maybe Id
+   , source         :: Maybe String
+   , feedbackScript :: Maybe String
+   , requestInfo    :: Maybe String
+   , cgiBinary      :: Maybe String
+   , logSchema      :: Maybe Schema     -- should be yes (default)/no
+   , randomSeed     :: Maybe Int
+   , dataformat     :: Maybe DataFormat -- default: XML
+   , encoding       :: [Encoding]
+   }
+
+instance Sem.Semigroup Request where
+   x <> y = Request
+      { serviceId      = make serviceId
+      , exerciseId     = make exerciseId
+      , source         = make source
+      , feedbackScript = make feedbackScript
+      , requestInfo    = make requestInfo
+      , cgiBinary      = make cgiBinary
+      , logSchema      = make logSchema
+      , randomSeed     = make randomSeed
+      , dataformat     = make dataformat
+      , encoding       = encoding x <> encoding y
+      }
+    where
+      make f = f x <|> f y
+
+instance Monoid Request where
+   mempty = Request Nothing Nothing Nothing Nothing
+                    Nothing Nothing Nothing Nothing Nothing []
+   mappend = (<>)
+
+data Schema = V1 | V2 | NoLogging deriving (Show, Eq)
+
+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
+
+data Encoding = EncHTML      -- html page as output
+              | EncOpenMath  -- encode terms in OpenMath
+              | EncString    -- encode terms as strings
+              | EncCompact   -- compact ouput
+              | EncPretty    -- pretty output
+              | EncJSON      -- encode terms in JSON
+ deriving Eq
+
+instance Show Encoding where
+   showList xs rest = intercalate "+" (map show xs) ++ rest
+   show EncHTML     = "html"
+   show EncOpenMath = "openmath"
+   show EncString   = "string"
+   show EncCompact  = "compact"
+   show EncPretty   = "pretty"
+   show EncJSON     = "json"
+
+htmlOutput :: Request -> Bool
+htmlOutput = (EncHTML `elem`) . encoding
+
+compactOutput :: Request -> Bool
+compactOutput req =
+   case (EncCompact `elem` xs, EncPretty `elem` xs) of
+      (True, False) -> True
+      (False, True) -> False
+      _             -> isJust (cgiBinary req)
+ where
+   xs = encoding req
+
+useOpenMath :: Request -> Bool
+useOpenMath r =
+   case dataformat r of
+      Just JSON -> False
+      _ -> all (`notElem` encoding r) [EncString, EncHTML]
+
+useJSONTerm :: Request -> Bool
+useJSONTerm r =
+   case dataformat r of
+      Just JSON -> EncJSON `elem` encoding r
+      _ -> False
+
+useLogging :: Request -> Bool
+useLogging r = EncHTML `notElem` encoding r && logSchema r /= Just NoLogging
+
+discoverDataFormat :: Monad m => String -> m DataFormat
+discoverDataFormat xs =
+   case dropWhile isSpace xs of
+      '<':_ -> return XML
+      '{':_ -> return JSON
+      _     -> fail "Unknown data format"
+
+readEncoding :: Monad m => String -> m [Encoding]
+readEncoding = mapM (f . map toLower) . splitsWithElem '+'
+ where
+   f "html"     = return EncHTML
+   f "openmath" = return EncOpenMath
+   f "string"   = return EncString
+   f "compact"  = return EncCompact
+   f "pretty"   = return EncPretty
+   f "json"     = return EncJSON
+   f s          = fail $ "Invalid encoding: " ++ s
src/Ideas/Encoding/RulePresenter.hs view
@@ -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 2019, 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,14 +9,13 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: RulePresenter.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.RulePresenter (ruleToHTML) where
 
 import Data.List
 import Data.Maybe
+import Data.Monoid
 import Ideas.Common.Library
-import Ideas.Common.Utils (Some(..))
 import Ideas.Text.HTML
 
 ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder
@@ -46,12 +45,12 @@          TFloat a  -> show a
          TMeta n   -> showMeta ex n
          TCon s xs -> concatMap (either id recp) $
-                      let txt = spaced (Left (show s) : map Right xs)
+                      let txt = withSpaces (Left (show s) : map Right xs)
                       in fromMaybe txt (specialSymbol s xs)
          TList xs  -> "[" ++ intercalate ", " (map rec xs) ++ "]"
 
-   recp term = parIf (isCon term) (rec term)
-   spaced    = intersperse (Left " ")
+   recp term  = parIf (isCon term) (rec term)
+   withSpaces = intersperse (Left " ")
 
    isCon (TCon _ xs) = not (null xs)
    isCon _           = False
src/Ideas/Encoding/RulesInfo.hs view
@@ -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 2019, 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,24 +9,26 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: RulesInfo.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Encoding.RulesInfo
    ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap
    ) where
 
 import Data.Char
+import Data.Monoid
 import Ideas.Common.Library
-import Ideas.Common.Utils (Some(..))
 import Ideas.Encoding.OpenMathSupport (toOMOBJ)
 import Ideas.Text.OpenMath.FMP
 import Ideas.Text.OpenMath.Object
 import Ideas.Text.XML hiding (name)
+import Ideas.Utils.Prelude (munless)
 import qualified Data.Map as M
 
 rulesInfoXML :: Exercise a -> (a -> XMLBuilder) -> XMLBuilder
 rulesInfoXML ex enc = mconcat (map ruleInfoXML (ruleset ex))
  where
+   exampleMap = collectExamples ex
+
    ruleInfoXML r = element "rule"
       [ "name"        .=. showId r
       , "buggy"       .=. f (isBuggy r)
@@ -50,7 +52,7 @@                 ]
       -- Examples
       , mconcat [ element "example" [enc a, enc b]
-                | let pairs = M.findWithDefault [] (getId r) (collectExamples ex)
+                | let pairs = M.findWithDefault [] (getId r) exampleMap
                 , (a, b) <- take 3 pairs
                 ]
       ]
@@ -66,7 +68,7 @@ type ExampleMap a = M.Map Id [(a, a)]
 
 collectExamples :: Exercise a -> ExampleMap a
-collectExamples ex = foldr (add . snd) M.empty (examples ex)
+collectExamples ex = foldr add M.empty (examplesAsList ex)
  where
    add a m = let f = foldr g m . maybe [] triples
                  g (x, (r, _), y) =
src/Ideas/Encoding/StrategyInfo.hs view
@@ -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 2019, 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,59 @@ -- Converting a strategy to XML, and the other way around.
 --
 -----------------------------------------------------------------------------
---  $Id: StrategyInfo.hs 7524 2015-04-08 07:31:15Z 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 Data.Monoid
+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.CyclicTree
+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
-
-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
-                        ]
-
-cfgItem :: String -> XMLBuilder -> XMLBuilder
-cfgItem 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
+strategyTreeToXML :: StrategyTree a -> XML
+strategyTreeToXML tree = makeXML "label" $
+   case isLabel tree of
+      Just (l, a) -> nameAttr l <> strategyTreeBuilder a
+      _ -> strategyTreeBuilder tree
 
-isOrElse :: Core a -> Maybe (Core a, Core a)
-isOrElse (a :|>: b) = Just (a, b)
-isOrElse _ = Nothing
+strategyTreeBuilder :: StrategyTree a -> XMLBuilder
+strategyTreeBuilder = builder . fold emptyAlg
+   { fNode = \def xs ->
+        case xs of
+           [x] | isConfigId def
+             -> addProperty (show def) x
+           _ -> makeXML (show def) (mconcat (map builder xs))
+   , fLeaf = \r ->
+        makeXML "rule" ("name" .=. show r)
+   , fLabel = \l a ->
+        makeXML "label" (nameAttr l <> builder a)
+   , fRec = \n a ->
+        makeXML "rec" (("var" .=. show n) <> builder a)
+   , fVar = \n ->
+        makeXML "var" ("var" .=. show n)
+   }
 
-isInterleave :: Core a -> Maybe (Core a, Core a)
-isInterleave (a :%: b) = Just (a, b)
-isInterleave _ = Nothing
+addProperty :: String -> XML -> XML
+addProperty s a =
+   if name a `elem` ["label", "rule"]
+   then a { attributes = attributes a ++ [s := "true"] }
+   else a
 
 -----------------------------------------------------------------------
 -- XML to strategy
 
+{-
 xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) ->  XML -> m (Strategy a)
 xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g
  where
@@ -111,17 +76,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 +104,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 +112,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 +132,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)
+      ]
+
+-}
− src/Ideas/Main/BlackBoxTests.hs 
@@ -1,117 +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)
---
------------------------------------------------------------------------------
---  $Id: BlackBoxTests.hs 7528 2015-04-08 09:44:10Z bastiaan $
-
-module Ideas.Main.BlackBoxTests (blackBoxTests) where
-
-import Control.Monad
-import Data.Char
-import Data.List
-import Ideas.Common.Utils (useFixedStdGen, snd3)
-import Ideas.Common.Utils.TestSuite
-import Ideas.Encoding.ModeJSON
-import Ideas.Encoding.ModeXML
-import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
-import System.Directory
-import System.IO
-import qualified Data.Algorithm.Diff as Diff
-
--- Returns the number of tests performed
-blackBoxTests :: DomainReasoner -> String -> IO TestSuite
-blackBoxTests dr path = do
-   -- analyse content
-   xs0 <- getDirectoryContents path
-   let (xml,  xs1) = partition (".xml"  `isSuffixOf`) xs0
-       (json, xs2) = partition (".json" `isSuffixOf`) xs1
-       xs3         = map (path </>) (filter ((/= ".") . take 1) xs2)
-   -- recursively visit subdirectories
-   subs <- filterM doesDirectoryExist xs3
-   rest <- mapM (blackBoxTests dr) subs
-   return $ suite ("Directory " ++ simplerDirectory path) $
-      [ doBlackBoxTest dr JSON (path </> x)
-      | x <- json
-      ] ++
-      [ doBlackBoxTest dr XML (path </> x)
-      | x <- xml
-      ] ++
-      rest
-
-doBlackBoxTest :: DomainReasoner -> DataFormat -> FilePath -> TestSuite
-doBlackBoxTest dr format path =
-   assertMessageIO (stripDirectoryPart path) $ do
-      -- Comparing output with expected output
-      useFixedStdGen -- fix the random number generator
-      withFile path ReadMode $ \h1 -> do
-         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)
-         withFile expPath ReadMode $ \h2 -> do
-            hSetBinaryMode h2 True
-            expt <- hGetContents h2
-            -- Force evaluation of the result, to make sure that
-            -- all file handles are closed afterwards.
-            let list1 = prepare expt
-                list2 = prepare out
-                msg   = unlines (path : diffs list1 list2)
-            if list1 == list2 then return mempty else do
-               force msg -- force evaluation of message before closing files
-               return (message msg)
- where
-   expPath = baseOf path ++ ".exp"
-   baseOf  = reverse . drop 1 . dropWhile (/= '.') . reverse
-
-force :: String -> IO ()
-force s | sum (map ord s) >= 0 = return ()
-        | otherwise = error "force"
-
-prepare :: String -> [String]
-prepare = filter (not . null) . lines . filter (/= '\r') . noVersion
- where
-   noVersion s | "version\": \"" `isPrefixOf` s =
-      "version\": \"X" ++ dropWhile (/='"') (drop 11 s)
-   noVersion s | "version=\"" `isPrefixOf` s =
-      "version=\"X" ++ dropWhile (/='"') (drop 9 s)
-   noVersion (x:xs) = x:noVersion xs
-   noVersion [] = []
-
-diffs :: [String] -> [String] -> [String]
-diffs xs ys = concatMap f $ Diff.getDiff xs ys
- where
-   f (Diff.First a)  = ["- " ++ a]
-   f (Diff.Second a) = ["+ " ++ a]
-   f _ = []
-
-simplerDirectory :: String -> String
-simplerDirectory s
-   | "../"   `isPrefixOf` s = simplerDirectory (drop 3 s)
-   | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s)
-   | otherwise = s
-
-stripDirectoryPart :: String -> String
-stripDirectoryPart = reverse . takeWhile (/= '/') . reverse
-
-(</>) :: FilePath -> FilePath -> FilePath
-x </> y = x ++ "/" ++ y
-
-{-
-logicConfluence :: IO ()
-logicConfluence = reportTest "logic rules" (isConfluent f rs)
- where
-   f    = normalizeWith ops . normalFormWith ops rs
-   ops  = map makeCommutative Logic.logicOperators
-   rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd]
-   rs   = [ r | RewriteRule r <- concatMap transformations rwrs ]
-   -- eqs  = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ]
--}
+ src/Ideas/Main/CGI.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}
+-- Original source: https://hackage.haskell.org/package/wai-extra-3.0.20.0/docs/Network-Wai-Handler-CGI.html
+module Ideas.Main.CGI (run) where
+
+import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)
+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
+import Control.Arrow ((***))
+import Control.Monad (unless, void)
+import Data.ByteString.Lazy.Internal (defaultChunkSize)
+import Data.Char (toLower)
+import Data.Function (fix)
+import Data.IORef
+import Data.Maybe (fromMaybe)
+import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)
+import Network.Socket (getAddrInfo, addrAddress)
+import Network.Wai
+import Network.Wai.Internal
+import System.Environment (getEnvironment)
+import System.IO (Handle)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Streaming.ByteString.Builder as Blaze
+import qualified Data.String as String
+import qualified Network.HTTP.Types as H
+import qualified System.IO
+
+safeRead :: Read a => a -> String -> a
+safeRead d s =
+  case reads s of
+    ((x, _):_) -> x
+    [] -> d
+
+lookup' :: String -> [(String, String)] -> String
+lookup' key pairs = fromMaybe "" $ lookup key pairs
+
+-- | Run an application using CGI.
+run :: Application -> IO ()
+run app = do
+    vars <- getEnvironment
+    let input = requestBodyHandle System.IO.stdin
+        output = B.hPut System.IO.stdout
+    runGeneric vars input output Nothing app
+
+-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to
+-- use the same code as CGI. Most users will not need this function, and can
+-- stick with 'run' or 'runSendfile'.
+runGeneric
+     :: [(String, String)] -- ^ all variables
+     -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input
+     -> (B.ByteString -> IO ()) -- ^ destination for output
+     -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
+     -> Application
+     -> IO ()
+runGeneric vars inputH outputH xsendfile app = do
+    let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
+        pinfo = lookup' "PATH_INFO" vars
+        qstring = lookup' "QUERY_STRING" vars
+        contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
+        remoteHost' =
+            let s = fromMaybe "" (lookup "REMOTE_HOST" vars)
+            in fromMaybe s (lookup "REMOTE_ADDR" vars)
+
+        isSecure' =
+            case map toLower $ lookup' "SERVER_PROTOCOL" vars of
+                "https" -> True
+                _ -> False
+    addrs <- getAddrInfo Nothing (Just remoteHost') Nothing
+    requestBody' <- inputH contentLength
+    let addr =
+            case addrs of
+                a:_ -> addrAddress a
+                [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
+        reqHeaders = map (cleanupVarName *** B.pack) vars
+        env = Request
+            { requestMethod = rmethod
+            , rawPathInfo = B.pack pinfo
+            , pathInfo = H.decodePathSegments $ B.pack pinfo
+            , rawQueryString = B.pack qstring
+            , queryString = H.parseQuery $ B.pack qstring
+            , requestHeaders = reqHeaders
+            , isSecure = isSecure'
+            , remoteHost = addr
+            , httpVersion = H.http11 -- FIXME
+            , requestBody = requestBody'
+            , vault = mempty
+            , requestBodyLength = KnownLength $ fromIntegral contentLength
+            , requestHeaderHost = lookup "host" reqHeaders
+            , requestHeaderRange = lookup hRange reqHeaders
+            , requestHeaderReferer = lookup "referer" reqHeaders
+            , requestHeaderUserAgent = lookup "user-agent" reqHeaders
+            }
+    void $ app env $ \res ->
+        case (xsendfile, res) of
+            (Just sf, ResponseFile s hs fp Nothing) -> do
+                mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
+                return ResponseReceived
+            _ -> do
+                let (s, hs, wb) = responseToStream res
+                (blazeRecv, blazeFinish) <- Blaze.newByteStringBuilderRecv Blaze.defaultStrategy
+                wb $ \b -> do
+                    let sendBuilder builder = do
+                            popper <- blazeRecv builder
+                            fix $ \loop -> do
+                                bs <- popper
+                                unless (B.null bs) $ do
+                                    outputH bs
+                                    loop
+                    sendBuilder $ headers s hs `mappend` fromChar '\n'
+                    b sendBuilder (sendBuilder flush)
+                blazeFinish >>= maybe (return ()) outputH
+                return ResponseReceived
+  where
+    headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
+    status (Status i m) = (fromByteString "Status", mconcat
+        [ fromString $ show i
+        , fromChar ' '
+        , fromByteString m
+        ])
+    header' (x, y) = (fromByteString $ CI.original x, fromByteString y)
+    header (x, y) = mconcat
+        [ x
+        , fromByteString ": "
+        , y
+        , fromChar '\n'
+        ]
+    sfBuilder s hs sf fp = mconcat
+        [ headers s hs
+        , header (fromByteString sf, fromString fp)
+        , fromChar '\n'
+        , fromByteString sf
+        , fromByteString " not supported"
+        ]
+    fixHeaders h =
+        case lookup hContentType h of
+            Nothing -> (hContentType, "text/html; charset=utf-8") : h
+            Just _ -> h
+
+cleanupVarName :: String -> CI.CI B.ByteString
+cleanupVarName "CONTENT_TYPE" = hContentType
+cleanupVarName "CONTENT_LENGTH" = hContentLength
+cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
+cleanupVarName s =
+    case s of
+        'H':'T':'T':'P':'_':a:as -> String.fromString $ a : helper' as
+        _ -> String.fromString s -- FIXME remove?
+  where
+    helper' ('_':x:rest) = '-' : x : helper' rest
+    helper' (x:rest) = toLower x : helper' rest
+    helper' [] = []
+
+requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString)
+requestBodyHandle h = requestBodyFunc $ \i -> do
+    bs <- B.hGet h i
+    return $ if B.null bs then Nothing else Just bs
+
+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)
+requestBodyFunc get count0 = do
+    ref <- newIORef count0
+    return $ do
+        count <- readIORef ref
+        if count <= 0
+            then return B.empty
+            else do
+                mbs <- get $ min count defaultChunkSize
+                writeIORef ref $ count - maybe 0 B.length mbs
+                return $ fromMaybe B.empty mbs
+ src/Ideas/Main/CmdLineOptions.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Command-Line Options
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Main.CmdLineOptions
+   ( CmdLineOption(..), getCmdLineOptions
+   , versionText, helpText, shortVersion, fullVersion
+   ) where
+
+import Data.Maybe
+import Ideas.Encoding.Logging (logEnabled)
+import Ideas.Main.Revision
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+
+data CmdLineOption
+   = Version | Help | PrintLog
+   | InputFile String | Rerun String | Test FilePath
+   | MakeScriptFor String | AnalyzeScript FilePath
+ deriving Eq
+
+header :: String
+header =
+   "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++
+   "Copyright 2019, Open Universiteit Nederland\n" ++
+   versionText ++
+   "\n\nUsage: ideas [OPTION]     (by default, CGI protocol)\n" ++
+   "\nOptions:"
+
+versionText :: String
+versionText =
+  "version " ++ ideasVersion ++ ", revision " ++ ideasRevision ++
+  ", logging " ++ (if logEnabled then "enabled" else "disabled")
+
+helpText :: String
+helpText = usageInfo header options
+
+fullVersion :: String
+fullVersion = "version " ++ ideasVersion ++ " (revision "
+           ++ ideasRevision ++ ", " ++ ideasLastChanged ++ ")"
+
+shortVersion :: String
+shortVersion = ideasVersion ++ " (" ++ ideasRevision ++ ")"
+
+options :: [OptDescr CmdLineOption]
+options =
+   [ 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 ""  ["rerun"]          rerunArg         "rerun inputs from database"
+   , 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, rerunArg, testArg, makeScrArg, analyzeScrArg :: ArgDescr CmdLineOption
+fileArg       = ReqArg InputFile "FILE"
+rerunArg      = ReqArg Rerun "DATABASE"
+testArg       = OptArg (Test . fromMaybe "test") "DIR"
+makeScrArg    = ReqArg MakeScriptFor "ID"
+analyzeScrArg = ReqArg AnalyzeScript "FILE"
+
+getCmdLineOptions :: IO [CmdLineOption]
+getCmdLineOptions = do
+   args <- getArgs
+   case getOpt Permute options args of
+      (flags, [], []) -> return flags
+      (_, _, errs) -> do
+         putStrLn (concat errs ++ helpText)
+         exitFailure
src/Ideas/Main/Default.hs view
@@ -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 2019, 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,123 +11,193 @@ -- Main module for feedback services
 --
 -----------------------------------------------------------------------------
---  $Id: Default.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Main.Default
-   ( defaultMain, defaultCGI
+   ( defaultMain, defaultMainWith, defaultCGI
      -- extra exports
-   , Some(..), serviceList, metaServiceList, Service
+   , serviceList, metaServiceList, Service
    , module Ideas.Service.DomainReasoner
    ) where
 
 import Control.Exception
 import Control.Monad
+import Data.ByteString (ByteString, unpack)
+import Data.Char
 import Data.Maybe
-import Data.Time
-import Ideas.Common.Utils (useFixedStdGen, Some(..))
-import Ideas.Common.Utils.TestSuite
+import Data.Monoid
+import Data.String
 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.Encoding.Options (Options, maxTime, optionCgiBin, logRef)
+import Ideas.Encoding.Request
+import Ideas.Main.CmdLineOptions hiding (fullVersion)
 import Ideas.Service.DomainReasoner
 import Ideas.Service.FeedbackScript.Analysis
-import Ideas.Service.Request
 import Ideas.Service.ServiceList
 import Ideas.Service.Types (Service)
-import Network.CGI
-import Prelude hiding (catch)
+import Ideas.Text.XML.Unicode (decoding)
+import Ideas.Utils.BlackBoxTests
+import Ideas.Utils.Prelude
+import Ideas.Utils.TestSuite
+import Network.HTTP.Types
 import System.IO
-import System.IO.Error (ioeGetErrorString)
+import qualified Ideas.Encoding.Logging as Log
+import qualified Ideas.Main.CGI as CGI
+import qualified Ideas.Main.CmdLineOptions as Options
+import qualified Network.Wai as WAI
 
 defaultMain :: DomainReasoner -> IO ()
-defaultMain dr = do
-   flags <- getFlags
-   if null flags
-      then defaultCGI dr
-      else defaultCommandLine dr flags
+defaultMain = defaultMainWith mempty
 
+defaultMainWith :: Options -> DomainReasoner -> IO ()
+defaultMainWith options dr = do
+   -- create a record for logging (use only if not already provided)
+   ref <- Log.defaultLogRef
+   let newOptions = options {logRef = logRef options <> ref}
+   -- inspect command-line options
+   cmdLineOptions <- getCmdLineOptions
+   if null cmdLineOptions
+      then defaultCGI newOptions dr
+      else defaultCommandLine newOptions (addVersion dr) cmdLineOptions
+
 -- Invoked as a cgi binary
-defaultCGI :: DomainReasoner -> IO ()
-defaultCGI dr = runCGI $ handleErrors $ do
+defaultCGI :: Options -> DomainReasoner -> IO ()
+defaultCGI options dr = CGI.run $ \req respond -> do
    -- query environment
-   startTime <- liftIO getCurrentTime
-   addr      <- remoteAddr       -- the IP address of the remote host
-   cgiBin    <- scriptName       -- get name of binary
-   input     <- inputOrDefault
+   let script = fromMaybe "" (findHeader "CGI-Script-Name" req) -- get name of binary
+       addr   = fromMaybe "" (findHeader "REMOTE_ADDR" req)     -- the IP address of the remote host
+   input   <- inputOrDefault req >>= decoding
    -- process request
-   (req, txt, ctp) <- liftIO $
-      process dr (Just cgiBin) input
+   (preq, txt, ctp) <-
+      process (optionCgiBin script options) dr input
+   -- store request in log reference
+   Log.changeLog (logRef options) $ \r -> Log.addRequest preq r
+      { Log.ipaddress = addr
+      , Log.version   = shortVersion
+      , Log.input     = input
+      , Log.output    = txt
+      }
    -- log request to database
-   when (useLogging req) $
-      liftIO $ logMessage req input txt addr startTime
+   when (useLogging preq) $
+      Log.logRecord (logRef options)
    -- write header and output
-   setHeader "Content-type" ctp
-   -- Cross-Origin Resource Sharing (CORS) prevents browser warnings
-   -- about cross-site scripting
-   setHeader "Access-Control-Allow-Origin" "*"
-   output txt
+   respond $ WAI.responseLBS
+      status200
+      [ (fromString "Content-Type", fromString ctp)
+        -- Cross-Origin Resource Sharing (CORS) prevents browser warnings
+        -- about cross-site scripting
+      , (fromString "Access-Control-Allow-Origin", fromString "*")
+      ]
+      (fromString txt)
 
-inputOrDefault :: CGI String
-inputOrDefault = do
-   inHtml <- acceptsHTML
-   ms     <- getInput "input" -- read variable 'input'
-   case ms of
+inputOrDefault :: WAI.Request -> IO String
+inputOrDefault req = do
+   maybeInput <- inputFromRequest req
+   case maybeInput of
       Just s -> return s
       Nothing
-         | inHtml    -> return defaultBrowser
-         | otherwise -> fail "environment variable 'input' is empty"
+         | acceptsHTML -> return defaultBrowser
+         | otherwise   -> fail "environment variable 'input' is empty"
  where
    -- Invoked from browser
    defaultBrowser :: String
    defaultBrowser = "<request service='index' encoding='html'/>"
 
-   acceptsHTML :: CGI Bool
-   acceptsHTML = do
-      maybeAcceptCT <- requestAccept
-      let htmlCT = ContentType "text" "html" []
-          xs = negotiate [htmlCT] maybeAcceptCT
-      return (isJust maybeAcceptCT && not (null xs))
+   acceptsHTML :: Bool
+   acceptsHTML = "text/html" `elem` accepts req
 
 -- Invoked from command-line with flags
-defaultCommandLine :: DomainReasoner -> [Flag] -> IO ()
-defaultCommandLine dr flags = do
+defaultCommandLine :: Options -> DomainReasoner -> [CmdLineOption] -> IO ()
+defaultCommandLine options dr cmdLineOptions = do
    hSetBinaryMode stdout True
-   useFixedStdGen -- always use a predictable "random" number generator
-   mapM_ doAction flags
+   mapM_ doAction cmdLineOptions
  where
-   doAction flag =
-      case flag of
+   doAction cmdLineOption =
+      case cmdLineOption of
          -- information
          Version -> putStrLn ("IDEAS, " ++ versionText)
          Help    -> putStrLn helpText
          -- process input file
+         Rerun database ->
+            processDatabase dr database
          InputFile file ->
             withBinaryFile file ReadMode $ \h -> do
-               input <- hGetContents h
-               (_, txt, _) <- process dr Nothing input
+               input  <- hGetContents h >>= decoding
+               (req, txt, _) <- process options dr input
                putStrLn txt
+               when (PrintLog `elem` cmdLineOptions) $ do
+                  Log.changeLog (logRef options) $ \r -> Log.addRequest req r
+                     { Log.ipaddress = "command-line"
+                     , Log.version   = shortVersion
+                     , Log.input     = input
+                     , Log.output    = txt
+                     }
+                  Log.printLog (logRef options)
          -- blackbox tests
          Test dir -> do
-            tests  <- blackBoxTests dr dir
+            tests  <- blackBoxTests (makeTestRunner dr) ["xml", "json"] dir
             result <- runTestSuiteResult True tests
             printSummary result
-         -- generate documentation pages
-         MakePages dir ->
-            makeDocumentation dr dir
          -- 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
+processDatabase :: DomainReasoner -> FilePath -> IO ()
+processDatabase dr database = do
+   (n, time) <- getDiffTime $ do
+      rows <- Log.selectFrom database "requests" ["input"] $ \row -> do
+         txt <- headM row
+         (_, out, _) <- process mempty dr txt
+         putStrLn out
+      return (length rows)
+   putStrLn $ "processed " ++ show n ++ " requests in " ++ show time
+
+process :: Options -> DomainReasoner -> String -> IO (Request, String, String)
+process options dr input = do
    format <- discoverDataFormat input
-   run format (Just 5) cgiBin dr input
- `catch` \ioe ->
-   let msg = "Error: " ++ ioeGetErrorString ioe
-   in return (emptyRequest, msg, "text/plain")
+   run format options {maxTime = Just 5} (addVersion dr) input
+ `catch` \e -> do
+   let msg = "Error: " ++ show (e :: SomeException)
+   Log.changeLog (logRef options) (\r -> r { Log.errormsg = msg })
+   return (mempty, msg, "text/plain")
  where
    run XML  = processXML
-   run JSON = processJSON+   run JSON = processJSON
+
+makeTestRunner :: DomainReasoner -> String -> IO String
+makeTestRunner dr input = do
+   (_, out, _) <- decoding input >>= process mempty dr
+   return out
+
+addVersion :: DomainReasoner -> DomainReasoner
+addVersion dr = dr
+   { version     = update version Options.shortVersion
+   , fullVersion = update fullVersion Options.fullVersion
+   }
+ where
+   update f s = if null (f dr) then s else f dr
+
+-- local helper functions
+
+findHeader :: String -> WAI.Request -> Maybe String
+findHeader s = fmap fromByteString . lookup (fromString s) . WAI.requestHeaders
+
+inputFromRequest :: WAI.Request -> IO (Maybe String)
+inputFromRequest req =
+   -- first try query string (for GET requests) ...
+   case inputFromQuery (WAI.queryString req) of
+      Just s  -> return (Just s)
+      Nothing -> do
+         -- ... then try request body (for POST requests)
+         body <- WAI.requestBody req
+         return (inputFromQuery (parseQuery body))
+
+inputFromQuery :: Query -> Maybe String
+inputFromQuery = fmap fromByteString . join . lookup (fromString "input")
+
+accepts :: WAI.Request -> [String]
+accepts = maybe [] (splitsWithElem ',') . findHeader "Accept"
+
+fromByteString :: ByteString -> String
+fromByteString = map (chr . fromEnum) . unpack
− src/Ideas/Main/Documentation.hs 
@@ -1,63 +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)
---
--- Manages links to information
---
------------------------------------------------------------------------------
---  $Id: Documentation.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Main.Documentation (makeDocumentation) where
-
-import Control.Monad
-import Ideas.Common.Library
-import Ideas.Common.Utils
-import Ideas.Encoding.Encoder (run, simpleOptions)
-import Ideas.Encoding.EncoderHTML
-import Ideas.Encoding.LinkManager
-import Ideas.Service.BasicServices
-import Ideas.Service.DomainReasoner
-import Ideas.Service.Types
-import Ideas.Text.HTML
-import System.Directory
-import System.FilePath (takeDirectory)
-
-makeDocumentation :: DomainReasoner -> String -> IO ()
-makeDocumentation dr dir = do
-   putStrLn "Generating index pages"
-   makeIndex urlForIndex     (dr ::: tDomainReasoner)
-   makeIndex urlForExercises (exercises dr ::: tList tSomeExercise)
-   makeIndex urlForServices  (services dr ::: tList tService)
-   putStrLn "Generating service pages"
-   forM_ (services dr) $ \srv ->
-      makeIndex (`urlForService` srv) (srv ::: tService)
-   putStrLn "Generating exercise pages"
-   forM_ (exercises dr) $ \(Some ex) -> do
-      makeEx ex urlForExercise    (ex ::: tExercise)
-      makeEx ex urlForStrategy    (toStrategy (strategy ex) ::: tStrategy)
-      makeEx ex urlForRules       (ruleset ex ::: tList tRule)
-      makeEx ex urlForExamples    (map (second (inContext ex)) (examples ex) ::: tList (tPair tDifficulty tContext))
-      makeEx ex urlForDerivations (exampleDerivations ex ::: tError (tList (tDerivation (tPair tRule tEnvironment) tContext)))
-      forM_ (ruleset ex) $ \r ->
-         make ex (urlForRule lm ex r) (r ::: tRule)
- where
-   lm = staticLinks
-   makeIndex f = make emptyExercise (f lm)
-   makeEx ex f = make ex (f lm ex)
-   make ex url tv = do
-      let enc = htmlEncoderAt (pathLevel url) dr
-      html <- run enc (simpleOptions ex) tv
-      safeWrite (dir </> url) (showHTML html)
-
-safeWrite :: FilePath -> String -> IO ()
-safeWrite filename txt = do
-   let dirpart = takeDirectory filename
-   unless (null dirpart) (createDirectoryIfMissing True dirpart)
-   putStrLn $ "- " ++ filename
-   writeFile filename txt
− src/Ideas/Main/LoggingDatabase.hs 
@@ -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
− src/Ideas/Main/Options.hs 
@@ -1,81 +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)
---
--- Options and command-line flags for services
---
------------------------------------------------------------------------------
---  $Id: Options.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Main.Options
-   ( Flag(..), getFlags
-   , versionText, helpText, shortVersion, fullVersion
-   ) where
-
-import Data.Maybe
-import Ideas.Main.LoggingDatabase (logEnabled)
-import Ideas.Main.Revision
-import System.Console.GetOpt
-import System.Environment
-import System.Exit
-
-data Flag = Version | Help | InputFile String
-          | MakePages FilePath | Test FilePath
-          | MakeScriptFor String | AnalyzeScript FilePath
-   deriving Eq
-
-header :: String
-header =
-   "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++
-   "Copyright 2015, Open Universiteit Nederland\n" ++
-   versionText ++
-   "\n\nUsage: ideas [OPTION]     (by default, CGI protocol)\n" ++
-   "\nOptions:"
-
-versionText :: String
-versionText =
-  "version " ++ ideasVersion ++ ", revision " ++ show ideasRevision ++
-  ", logging " ++ (if logEnabled then "enabled" else "disabled")
-
-helpText :: String
-helpText = usageInfo header options
-
-fullVersion :: String
-fullVersion = "version " ++ ideasVersion ++ " (revision "
-           ++ show ideasRevision ++ ", " ++ ideasLastChanged ++ ")"
-
-shortVersion :: String
-shortVersion = ideasVersion ++ " (" ++ show ideasRevision ++ ")"
-
-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"
-   ]
-
-fileArg, testArg, pagesArg, makeScrArg, analyzeScrArg :: ArgDescr Flag
-fileArg       = ReqArg InputFile "FILE"
-testArg       = OptArg (Test . fromMaybe "test") "DIR"
-pagesArg      = OptArg (MakePages . fromMaybe "docs") "DIR"
-makeScrArg    = ReqArg MakeScriptFor "ID"
-analyzeScrArg = ReqArg AnalyzeScript "FILE"
-
-getFlags :: IO [Flag]
-getFlags = do
-   args <- getArgs
-   case getOpt Permute options args of
-      (flags, [], []) -> return flags
-      (_, _, errs) -> do
-         putStrLn (concat errs ++ helpText)
-         exitFailure
src/Ideas/Main/Revision.hs view
@@ -2,10 +2,10 @@ module Ideas.Main.Revision where  ideasVersion :: String-ideasVersion = "1.3"+ideasVersion = "1.8" -ideasRevision :: Int-ideasRevision = 7519+ideasRevision :: String+ideasRevision = "26fe80bf0f02342b55587676d6d34fd4bbcd3cad"  ideasLastChanged :: String-ideasLastChanged = "wo, 08 apr 2015"+ideasLastChanged = "Mon Sep 9 12:42:00 2019 +0200"
src/Ideas/Service/BasicServices.hs view
@@ -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 2019, 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,45 +9,49 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: BasicServices.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.BasicServices
    ( -- * Basic Services
-     stepsremaining, findbuggyrules, allfirsts, solution
-   , onefirst, applicable, allapplications, apply, generate, create
+     stepsremaining, findbuggyrules, allfirsts, solution, solutionMaxSteps
+   , onefirst, onefinal, applicable, allapplications, apply, generate, create
    , StepInfo, tStepInfo, exampleDerivations, recognizeRule
    ) where
 
 import Control.Monad
 import Data.List
 import Data.Maybe
+import Ideas.Common.Examples
 import Ideas.Common.Library hiding (applicable, apply, ready)
 import Ideas.Common.Traversal.Navigator (downs, navigateTo)
-import Ideas.Common.Utils (fst3)
 import Ideas.Service.State
 import Ideas.Service.Types
-import System.Random
+import Ideas.Utils.Prelude (fst3)
+import Test.QuickCheck.Random
+import qualified Data.Set as S
 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 :: QCGen -> Exercise a -> Maybe Difficulty -> Maybe String -> Either String (State a)
+generate rng ex md userId =
    case randomTerm rng ex md of
-      Just a  -> return (emptyState ex a)
+      Just a  -> Right $ startState rng ex userId a
       Nothing -> Left "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 :: QCGen -> Exercise a -> String -> Maybe String -> Either String (State a)
+create rng ex txt userId =
+   case parser ex txt of
+      Left err -> Left err
+      Right a
+         | evalPredicate (Library.ready ex) a -> Left "Is ready"
+         | evalPredicate (Library.suitable ex) a -> Right $ startState rng ex userId a
+         | otherwise -> Left "Not suitable"
 
 -- TODO: add a location to each step
 solution :: Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a))
-solution mcfg state =
+solution = solutionMaxSteps 50
+
+solutionMaxSteps :: Int -> Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a))
+solutionMaxSteps maxSteps mcfg state =
    mapSecond (biMap (\(r, _, as) -> (r, as)) stateContext) $
    case mcfg of
       _ | withoutPrefix state -> Left "Prefix is required"
@@ -56,14 +60,13 @@       -- 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))
-      _ -> rec timeout d0 state
+             newPrefix   = emptyPrefix newStrategy (stateContext state)
+         in rec maxSteps d0 state { statePrefix = newPrefix }
+      _ -> rec maxSteps d0 state
  where
    d0   = emptyDerivation state
    ex   = exercise state
    prfx = statePrefix state
-   timeout = 50 :: Int
 
    rec i acc st =
       case onefirst st of
@@ -72,7 +75,7 @@             | i <= 0    -> Left msg
             | otherwise -> rec (i-1) (acc `extend` ((r, l, as), newState)) newState
     where
-      msg = "Time out after " ++ show timeout ++ " steps. " ++
+      msg = "Time out after " ++ show maxSteps ++ " steps. " ++
             show (biMap fst3 (prettyPrinterContext ex . stateContext) acc)
 
 type StepInfo a = (Rule (Context a), Location, Environment) -- find a good place
@@ -86,7 +89,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)
@@ -102,6 +105,9 @@       Right (hd:_) -> Right hd
       Left msg     -> Left msg
 
+onefinal :: State a -> Either String (Context a)
+onefinal = fmap lastTerm . solution Nothing
+
 applicable :: Location -> State a -> [Rule (Context a)]
 applicable loc state =
    let p r = not (isBuggy r) && Apply.applicable r (setLocation loc (stateContext state))
@@ -116,7 +122,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,9 +152,36 @@    ca = setLocation loc (stateContext state)
    applyOff  = -- scenario 2: off-strategy
       case transApplyWith env (transformation r) ca of
-         (new, _):_ -> Right (makeNoState (exercise state) new)
-         []         -> Left ("Cannot apply " ++ show r)
+         (new, _):_ -> Right (restart (state {stateContext = new, statePrefix = noPrefix}))
+         [] ->
+            -- first check the environment (exercise-specific property)
+            case environmentCheck of
+               Just msg ->
+                  Left msg
+               Nothing ->
+                  -- try to find a buggy rule
+                  case siblingsFirst [ (br, envOut) | br <- ruleset (exercise state), isBuggy br,  (_, envOut) <- transApplyWith env (transformation br) ca ] of
+                     []  -> Left ("Cannot apply " ++ show r)
+                     brs -> Left ("Buggy rule " ++ intercalate "+" (map pp brs))
+    where
+      pp (br, envOut)
+         | noBindings envOut = show br
+         | otherwise         = show br ++ " {" ++ show envOut ++ "}"
 
+   siblingsFirst xs = ys ++ zs
+    where
+      (ys, zs) = partition (siblingInCommon r . fst) xs
+
+   environmentCheck :: Maybe String
+   environmentCheck = do
+      p <- getProperty "environment-check" (exercise state)
+      p env
+
+siblingInCommon :: Rule a -> Rule a -> Bool
+siblingInCommon r1 r2 = not (S.null (getSiblings r1 `S.intersection` getSiblings r2))
+ where
+   getSiblings r = S.fromList (getId r : ruleSiblings r)
+
 stepsremaining :: State a -> Either String Int
 stepsremaining = mapSecond derivationLength . solution Nothing
 
@@ -174,4 +207,4 @@       concatMap rec (downs x)
 
 exampleDerivations :: Exercise a -> Either String [Derivation (Rule (Context a), Environment) (Context a)]
-exampleDerivations ex = mapM (solution Nothing . emptyState ex . snd) (examples ex)+exampleDerivations ex = mapM (solution Nothing . emptyState ex) (examplesAsList ex)
src/Ideas/Service/Diagnose.hs view
@@ -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 2019, 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,14 @@ -- Diagnose a term submitted by a student
 --
 -----------------------------------------------------------------------------
---  $Id: Diagnose.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.Diagnose
-   ( Diagnosis(..), tDiagnosis, diagnose, restartIfNeeded, newState
-   , difference, differenceEqual
+   ( Diagnosis(..), tDiagnosis, diagnose
+   , getState, getStateAndReady
+   , difference
    ) 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 +31,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,33 +45,35 @@ 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
+getState :: Diagnosis a -> Maybe (State a)
+getState = fmap fst . getStateAndReady
+
+getStateAndReady :: Diagnosis a -> Maybe (State a, Bool)
+getStateAndReady d =
+   case d of
+      SyntaxError _    -> Nothing
       Buggy _ _        -> Nothing
       NotEquivalent _  -> Nothing
-      Similar  _ s     -> Just s
-      WrongRule _ s _  -> Just s
-      Expected _ s _   -> Just s
-      Detour   _ s _ _ -> Just s
-      Correct  _ s     -> Just s
-      Unknown  _ s     -> Just s
+      Similar b s      -> Just (s, b)
+      WrongRule b s _  -> Just (s, b)
+      Expected b s _   -> Just (s, b)
+      Detour b s _  _  -> Just (s, b)
+      Correct  b s     -> Just (s, b)
+      Unknown b s      -> Just (s, b)
 
 ----------------------------------------------------------------
 -- The diagnose service
@@ -118,11 +118,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)
 
@@ -134,49 +134,35 @@       , (_, env) <- recognizeRule ex r sub1 sub2
       ]
     where
-      diff = if searchForBuggy then difference else differenceEqual
       (sub1, sub2) = fromMaybe (stateContext state, new) $ do
          newTerm <- fromContext new
-         (a, b)  <- diff ex (stateTerm state) newTerm
+         (a, b)  <- difference ex (stateTerm state) newTerm
          return (inContext ex a, inContext ex b)
 
 ----------------------------------------------------------------
 -- 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))))
@@ -187,13 +173,6 @@ difference ex a b = do
    v <- hasTermView ex
    Diff.differenceWith v a b
-
--- Used by the FP tutor
-differenceEqual :: Exercise a -> a -> a -> Maybe (a, a)
-differenceEqual ex a b = do
-   v <- hasTermView ex
-   let simpleEq = equivalence ex `on` inContext ex
-   Diff.differenceEqualWith v simpleEq a b
 
 ----------------------------------------------------------------
 -- Compare answer sets (and search for missing parts/incorrect parts)
src/Ideas/Service/DomainReasoner.hs view
@@ -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 2019, 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,25 +9,21 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: DomainReasoner.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.DomainReasoner
    ( DomainReasoner(..), tDomainReasoner, newDomainReasoner
    , exercisesSorted, servicesSorted
    , findExercise, findService
-   , defaultScript -- , readScript
+   , defaultScript
    ) where
 
 import Data.List
 import Data.Maybe
-import Data.Monoid
-import Data.Ord
+import Data.Semigroup as Sem
 import Ideas.Common.Library
-import Ideas.Common.Utils
-import Ideas.Common.Utils.TestSuite
 import Ideas.Service.FeedbackScript.Parser
 import Ideas.Service.Types
-import qualified Ideas.Main.Options as Options
+import Ideas.Utils.TestSuite
 
 -----------------------------------------------------------------------
 -- Domain Reasoner data type
@@ -45,9 +40,8 @@    , fullVersion :: String
    }
 
-instance Monoid DomainReasoner where
-   mempty = DR mempty mempty mempty mempty mempty mempty mempty mempty mempty
-   mappend c1 c2 = DR
+instance Sem.Semigroup DomainReasoner where
+   c1 <> c2 = DR
       { reasonerId  = reasonerId c1  <> reasonerId c2
       , exercises   = exercises c1   <> exercises c2
       , services    = services c1    <> services c2
@@ -59,6 +53,10 @@       , fullVersion = fullVersion c1 <> fullVersion c2
       }
 
+instance Monoid DomainReasoner where
+   mempty  = DR mempty mempty mempty mempty mempty mempty mempty mempty mempty
+   mappend = (<>)
+
 instance HasId DomainReasoner where
    getId = reasonerId
    changeId f dr = dr { reasonerId = f (reasonerId dr) }
@@ -77,23 +75,19 @@              )
 
 newDomainReasoner :: IsId a => a -> DomainReasoner
-newDomainReasoner a = mempty
-   { reasonerId  = newId a
-   , version     = Options.shortVersion
-   , fullVersion = Options.fullVersion
-   }
+newDomainReasoner a = mempty {reasonerId  = newId a}
 
 -----------------------------------------------------------------------
 -- Domain Reasoner functions
 
 exercisesSorted :: DomainReasoner -> [Some Exercise]
-exercisesSorted = sortBy (comparing f) . exercises
+exercisesSorted = sortOn f . exercises
  where
    f :: Some Exercise -> String
    f (Some ex) = showId ex
 
 servicesSorted :: DomainReasoner -> [Service]
-servicesSorted = sortBy (comparing showId) . services
+servicesSorted = sortOn showId . services
 
 findExercise :: Monad m => DomainReasoner -> Id -> m (Some Exercise)
 findExercise dr i =
src/Ideas/Service/FeedbackScript/Analysis.hs view
@@ -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 2019, 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,6 @@ -- Analysis of a feedbackscript
 --
 -----------------------------------------------------------------------------
---  $Id: Analysis.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.FeedbackScript.Analysis
    ( -- Analysis functions
@@ -23,12 +22,11 @@ import Data.Either
 import Data.List
 import Ideas.Common.Library
-import Ideas.Common.Utils (Some(..))
-import Ideas.Common.Utils.Uniplate
 import Ideas.Service.DomainReasoner
 import Ideas.Service.FeedbackScript.Parser
 import Ideas.Service.FeedbackScript.Run
 import Ideas.Service.FeedbackScript.Syntax
+import Ideas.Utils.Uniplate
 
 makeScriptFor :: IsId a => DomainReasoner -> a -> IO ()
 makeScriptFor dr exId = do
src/Ideas/Service/FeedbackScript/Parser.hs view
@@ -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 2019, 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,6 @@ -- Simple parser for feedback scripts
 --
 -----------------------------------------------------------------------------
---  $Id: Parser.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.FeedbackScript.Parser
    ( parseScript, parseScriptSafe, Script
@@ -21,11 +20,10 @@ import Control.Monad
 import Data.Char
 import Data.List
-import Data.Monoid
+import Data.Semigroup
 import Ideas.Common.Id
 import Ideas.Service.FeedbackScript.Syntax
-import Ideas.Text.Parsing
-import Prelude hiding (catch)
+import Ideas.Utils.Parsing
 import System.Directory
 import System.FilePath
src/Ideas/Service/FeedbackScript/Run.hs view
@@ -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 2019, 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,6 @@ -- Run a feedbackscript
 --
 -----------------------------------------------------------------------------
---  $Id: Run.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.FeedbackScript.Run
    ( Script
@@ -21,10 +20,8 @@    , eval
    ) where
 
-import Control.Monad
 import Data.List
 import Data.Maybe
-import Data.Monoid
 import Ideas.Common.Library hiding (ready, Environment)
 import Ideas.Service.BasicServices
 import Ideas.Service.Diagnose
@@ -55,8 +52,8 @@   , recognized = Nothing
   , diffPair   = Nothing
   , before     = f st
-  , after      = liftM snd next >>= f
-  , afterText  = liftM snd next >>= g
+  , after      = fmap snd next >>= f
+  , afterText  = fmap snd next >>= g
   }
  where
   f s  = fmap (`build` stateTerm s) (hasTermView (exercise s))
@@ -74,7 +71,7 @@ eval env script = either (return . findIdRef) evalText
  where
    evalText :: Text -> Maybe Text
-   evalText = liftM mconcat . mapM unref . textItems
+   evalText = fmap mconcat . mapM unref . textItems
     where
       unref (TextRef a)
          | a == expectedId   = fmap (findIdRef . getId) (expected env)
@@ -126,13 +123,14 @@ 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
+      NotEquivalent s  -> makeNotEq s "noteq"   env
       Expected _ _ r   -> makeOk    "ok"        env {recognized = Just r}
       WrongRule _ _ mr -> makeWrong "wrongrule" env {recognized = mr}
       Similar _ _      -> makeOk    "same"      env
       Detour _ _ _ r   -> makeOk    "detour"    env {recognized = Just r}
-      Correct _ _      -> makeOk    "unknown"   env
+      Correct _ _      -> makeOk    "correct"   env
       Unknown _ _      -> makeOk    "unknown"   env
  where
    makeOk    = makeDefault "Well done!"
@@ -162,7 +160,7 @@ 
 feedbackIds :: [Id]
 feedbackIds = map newId
-   ["same", "noteq", "unknown", "ok", "buggy", "detour", "wrongrule", "hint", "step", "label"]
+   ["same", "noteq", "correct", "unknown", "ok", "buggy", "detour", "wrongrule", "hint", "step", "label"]
 
 attributeIds :: [Id]
 attributeIds =
src/Ideas/Service/FeedbackScript/Syntax.hs view
@@ -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 2019, 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,6 @@ -- Abstract syntax for feedback scripts, and pretty-printer (Show instance)
 --
 -----------------------------------------------------------------------------
---  $Id: Syntax.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.FeedbackScript.Syntax
    ( Script, makeScript, scriptDecls, makeText, textItems
@@ -22,9 +21,9 @@ import Data.Char
 import Data.List
 import Data.Maybe
-import Data.Monoid
+import Data.Semigroup as Sem
 import Ideas.Common.Library
-import Ideas.Common.Utils.Uniplate
+import Ideas.Utils.Uniplate
 
 newtype Script = S { scriptDecls :: [Decl] }
 
@@ -104,13 +103,19 @@    showList xs ys =
       foldr (combine . show) ys (concatMap textItems xs)
 
+instance Sem.Semigroup Script where
+   s <> t = makeScript (scriptDecls s ++ scriptDecls t)
+
 instance Monoid Script where
-   mempty = makeScript []
-   mappend s t = makeScript (scriptDecls s ++ scriptDecls t)
+   mempty  = makeScript []
+   mappend = (<>)
 
+instance Sem.Semigroup Text where
+   (<>) = (:<>:)
+
 instance Monoid Text where
    mempty  = TextEmpty
-   mappend = (:<>:)
+   mappend = (<>)
 
 instance Uniplate Condition where
    uniplate (CondNot a) = plate CondNot |* a
src/Ideas/Service/FeedbackText.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: FeedbackText.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.FeedbackText
    ( Message, tMessage, accept, text
@@ -66,8 +65,8 @@ -- indicates whether the student is allowed to continue (True), or forced
 -- to go back to the previous state (False)
 submittext :: Script -> State a -> String -> (Message, State a)
-submittext script old input =
-   case parser ex input of
+submittext script old txt =
+   case parser ex txt of
       Left msg -> (M (Just False) (TextString msg), old)
       Right a  -> feedbacktext script old (inContext ex a) Nothing
  where
@@ -76,6 +75,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)
@@ -86,8 +86,8 @@       Unknown _ s     -> (msg False, s)
  where
    diagnosis = diagnose old new motivationId
-   output    = feedbackDiagnosis diagnosis env script
-   msg b     = M (Just b) output
+   out       = feedbackDiagnosis diagnosis env script
+   msg b     = M (Just b) out
    ex        = exercise old
    motivationRule = motivationId >>= getRule ex
    env = (newEnvironment old motivationRule)
src/Ideas/Service/ProblemDecomposition.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, 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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: ProblemDecomposition.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.ProblemDecomposition
    ( problemDecomposition, Reply(..), Answer, tAnswer, tReply
@@ -18,9 +17,10 @@ 
 import Data.Maybe
 import Ideas.Common.Library
-import Ideas.Common.Utils (fst3)
+import Ideas.Common.Strategy.Symbol
 import Ideas.Service.State
 import Ideas.Service.Types
+import Ideas.Utils.Prelude (fst3)
 
 problemDecomposition :: Maybe Id -> State a -> Maybe (Answer a) -> Either String (Reply a)
 problemDecomposition msloc state maybeAnswer
@@ -38,12 +38,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 +64,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 +87,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
− src/Ideas/Service/Request.hs 
@@ -1,87 +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)
---
------------------------------------------------------------------------------
---  $Id: Request.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Service.Request where
-
-import Data.Char
-import Data.List
-import Data.Maybe
-import Ideas.Common.Library hiding (exerciseId)
-import Ideas.Common.Utils
-
-data Request = Request
-   { serviceId      :: Maybe Id
-   , exerciseId     :: Maybe Id
-   , user           :: Maybe String
-   , source         :: Maybe String
-   , feedbackScript :: Maybe String
-   , cgiBinary      :: Maybe String
-   , dataformat     :: DataFormat
-   , encoding       :: [Encoding]
-   }
-
-emptyRequest :: Request
-emptyRequest = Request Nothing Nothing Nothing Nothing Nothing Nothing XML []
-
-data DataFormat = XML | JSON
-   deriving Show -- needed for LoggingDatabase
-
-data Encoding = EncHTML      -- html page as output
-              | EncOpenMath  -- encode terms in OpenMath
-              | EncString    -- encode terms as strings
-              | EncCompact   -- compact ouput
-              | EncPretty    -- pretty output
- deriving Eq
-
-instance Show Encoding where
-   showList xs rest = intercalate "+" (map show xs) ++ rest
-   show EncHTML     = "html"
-   show EncOpenMath = "openmath"
-   show EncString   = "string"
-   show EncCompact  = "compact"
-   show EncPretty   = "pretty"
-
-htmlOutput :: Request -> Bool
-htmlOutput = (EncHTML `elem`) . encoding
-
-compactOutput :: Request -> Bool
-compactOutput req =
-   case (EncCompact `elem` xs, EncPretty `elem` xs) of
-      (True, False) -> True
-      (False, True) -> False
-      _             -> isJust (cgiBinary req)
- where
-   xs = encoding req
-
-useOpenMath :: Request -> Bool
-useOpenMath r = all (`notElem` encoding r) [EncString, EncHTML]
-
-useLogging :: Request -> Bool
-useLogging = (EncHTML `notElem`) . encoding
-
-discoverDataFormat :: Monad m => String -> m DataFormat
-discoverDataFormat xs =
-   case dropWhile isSpace xs of
-      '<':_ -> return XML
-      '{':_ -> return JSON
-      _     -> fail "Unknown data format"
-
-readEncoding :: Monad m => String -> m [Encoding]
-readEncoding = mapM (f . map toLower) . splitsWithElem '+'
- where
-   f "html"     = return EncHTML
-   f "openmath" = return EncOpenMath
-   f "string"   = return EncString
-   f "compact"  = return EncCompact
-   f "pretty"   = return EncPretty
-   f s          = fail $ "Invalid encoding: " ++ s
src/Ideas/Service/ServiceList.hs view
@@ -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 2019, 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,19 +9,18 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: ServiceList.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.ServiceList (serviceList, metaServiceList) where
 
 import Ideas.Common.ExerciseTests
 import Ideas.Common.Library hiding (apply, applicable, suitable, ready)
-import Ideas.Common.Utils.TestSuite hiding (Message)
 import Ideas.Service.BasicServices
 import Ideas.Service.DomainReasoner
 import Ideas.Service.FeedbackText
 import Ideas.Service.ProblemDecomposition (problemDecomposition)
 import Ideas.Service.State
 import Ideas.Service.Types
+import Ideas.Utils.TestSuite hiding (Message)
 import qualified Ideas.Service.Diagnose as Diagnose
 import qualified Ideas.Service.ProblemDecomposition as ProblemDecomposition
 import qualified Ideas.Service.Submit as Submit
@@ -32,11 +31,11 @@ serviceList :: [Service]
 serviceList =
    -- basic services
-   [ solutionS, derivationS, allfirstsS, onefirstS
+   [ solutionS, derivationS, allfirstsS, onefirstS, onefinalS
    , 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 +46,7 @@ metaServiceList dr =
    [ indexS dr, servicelistS dr, serviceinfoS dr, exerciselistS dr
    , rulelistS, ruleinfoS, rulesinfoS, strategyinfoS, exerciseinfoS
-   , stateinfoS, examplederivationsS, testreportS
+   , constraintlistS, stateinfoS, examplederivationsS, testreportS, logS
    ]
 
 ------------------------------------------------------
@@ -83,6 +82,11 @@    onefirst ::: tState .-> tString :|: Tag "elem" (tPair tStepInfo tState)
    -- special tag for (legacy) xml encoding
 
+onefinalS :: Service
+onefinalS = makeService "basic.onefinal"
+   "Returns a final term, after taking zero or more steps, by applying the strategy." $
+   onefinal ::: tState .-> tError tContext
+
 equivalenceS :: Service
 equivalenceS = makeService "basic.equivalence"
    "Tests whether two terms are semantically equivalent." $
@@ -140,13 +144,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 ::: tQCGen .-> tExercise .-> tMaybe tDifficulty .-> tMaybe tUserId .-> tError 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 ::: tQCGen .-> tExercise .-> tString .-> tMaybe tUserId .-> tError tState
 
 examplesS :: Service
 examplesS = makeService "basic.examples"
@@ -162,12 +166,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 ::: tQCGen .-> tExercise .-> tInt .-> tMaybe tUserId .-> tError tState
  where
-   f ex nr =
-      case drop nr (examplesContext ex) of
-         []       -> Left "No such example"
-         (_,c ):_ -> Right (emptyStateContext ex c)
+   f rng ex nr userId =
+      case drop nr (examplesAsList ex) of
+         []  -> Left "No such example"
+         a:_ -> Right $ startState rng ex userId a
 
 findbuggyrulesS :: Service
 findbuggyrulesS = makeService "basic.findbuggyrules"
@@ -195,6 +199,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
 
@@ -289,6 +306,11 @@    "Exercise information" $
    id ::: tExercise .-> tExercise
 
+constraintlistS :: Service
+constraintlistS = makeService "meta.constraintlist"
+   "Returns list of constraints" $
+   constraints ::: tExercise .-> tList tConstraint
+
 stateinfoS :: Service
 stateinfoS = makeService "meta.stateinfo"
    "State information" $
@@ -298,7 +320,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 +330,11 @@ testreportS :: Service
 testreportS = makeService "meta.testreport"
    "Show test report for an exercise." $
-   (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: tStdGen .-> tExercise .-> tIO tTestSuiteResult+   (\qcgen -> runTestSuiteResult False . exerciseTestSuite qcgen) ::: tQCGen .-> 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)
src/Ideas/Service/State.hs view
@@ -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 2019, 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,43 @@ -- derivation.
 --
 -----------------------------------------------------------------------------
---  $Id: State.hs 7524 2015-04-08 07:31:15Z 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 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
+import Test.QuickCheck.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 +62,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 +82,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 +96,29 @@ emptyState :: Exercise a -> a -> State a
 emptyState ex = emptyStateContext ex . inContext ex
 
+startState :: QCGen -> Exercise a -> Maybe String -> a -> State a
+startState gen ex userId a = st
+   { stateUser      = userId
+   , stateSession   = Just sid
+   , stateStartTerm = Just (prettyPrinter ex a)
+   }
+ where
+   st  = emptyStateContext ex (inContext ex a)
+   sid = newSessionId gen
+
+-- 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,12 @@    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 :: QCGen -> String
+newSessionId = map hex . take 20 . randomRs (0 :: Int, 15)
+ where
+   hex :: Int -> Char
+   hex n | n < 10    = chr (n+48)
+         | otherwise = chr (n+87)
src/Ideas/Service/Submit.hs view
@@ -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 2019, 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,10 +12,9 @@ -- Diagnose a term submitted by a student. Deprecated (see diagnose service).
 --
 -----------------------------------------------------------------------------
---  $Id: Submit.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.Submit
-   ( submit, Result(..), tResult
+   ( submit, Result(..), tResult, getState
    ) where
 
 import Data.Maybe
@@ -32,9 +31,19 @@               | Detour [Rule (Context a)] (State a)  -- equivalent
               | Unknown                   (State a)  -- equivalent
 
+getState :: Result a -> Maybe (State a)
+getState r =
+   case r of
+      Buggy _         -> Nothing
+      NotEquivalent _ -> Nothing
+      Ok _ s          -> Just s
+      Detour _ s      -> Just s
+      Unknown s       -> Just s
+
 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
src/Ideas/Service/Types.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Types.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Service.Types
    ( -- * Services
@@ -20,24 +19,29 @@    , TypeRep(..), Const(..), Type, TypedValue(..)
    , Equal(..), ShowF(..), equalM
      -- * Constructing types
-   , tEnvironment, tLocation, tRule, tTuple3, tTuple4, tTuple5, tPair
-   , tStrategy, tTree, tState, tBool, tMaybe, tString, tList
-   , tId, tService, tSomeExercise, tText, tDifficulty, tContext
-   , tDerivation, tError, (.->), tIO, tExercise, tTestSuiteResult, tStdGen
-   , tScript, tExamples, tStrategyCfg, tInt
+   , tEnvironment, tLocation, tRule, tConstraint
+   , tUnit, tTuple3, tTuple4, tTuple5, tPair
+   , tTerm, tStrategy, tTree, tState, tBool, tMaybe, tString, tList
+   , tId, tService, tSomeExercise, tText, tDifficulty, tUserId ,tContext
+   , tDerivation, tError, (.->), tIO, tExercise, tTestSuiteResult, tQCGen
+   , tScript, tExamples, tStrategyCfg, tMathML, tInt, tXML
+     -- * Searching a typed value
+   , findValuesOfType
    ) where
 
 import Control.Monad
 import Data.Char
 import Data.List
 import Data.Maybe
-import Data.Tree
+import Data.Tree hiding (flatten)
+import Ideas.Common.Examples
 import Ideas.Common.Library
-import Ideas.Common.Utils
 import Ideas.Service.FeedbackScript.Syntax
 import Ideas.Service.State
-import System.Random
-import qualified Ideas.Common.Utils.TestSuite as TestSuite
+import Ideas.Text.MathML
+import Ideas.Text.XML (XML)
+import Test.QuickCheck.Random (QCGen)
+import qualified Ideas.Utils.TestSuite as TestSuite
 
 -----------------------------------------------------------------------------
 -- Services
@@ -85,21 +89,25 @@    equal Int         Int         = Just id
    equal Bool        Bool        = Just id
    equal String      String      = Just id
+   equal MathML      MathML      = Just id
    equal Service     Service     = Just id
    equal Exercise    Exercise    = Just id
    equal Strategy    Strategy    = Just id
    equal State       State       = Just id
-   equal Rule         Rule       = Just id
+   equal Rule        Rule        = Just id
+   equal Constraint  Constraint  = Just id
    equal Context     Context     = Just id
    equal Id          Id          = Just id
    equal Location    Location    = Just id
    equal Script      Script      = Just id
    equal StratCfg    StratCfg    = Just id
    equal Environment Environment = Just id
+   equal Term        Term        = Just id
    equal SomeExercise SomeExercise = Just id
    equal Text        Text        = Just id
-   equal StdGen      StdGen      = Just id
+   equal QCGen       QCGen       = Just id
    equal Result      Result      = Just id
+   equal XML         XML         = Just id
    equal _           _           = Nothing
 
 infixr 5 :|:
@@ -139,6 +147,7 @@    Strategy     :: Const a (Strategy (Context a))
    State        :: Const a (State a)
    Rule         :: Const a (Rule (Context a))
+   Constraint   :: Const a (Constraint (Context a))
    Context      :: Const a (Context a)
    -- other types
    Id           :: Const a Id
@@ -146,10 +155,13 @@    Script       :: Const a Script
    StratCfg     :: Const a StrategyCfg
    Environment  :: Const a Environment
+   Term         :: Const a Term
    Text         :: Const a Text
-   StdGen       :: Const a StdGen
+   QCGen        :: Const a QCGen
    Result       :: Const a TestSuite.Result
    SomeExercise :: Const a (Some Exercise)
+   MathML       :: Const a MathML
+   XML          :: Const a XML
    -- basic types
    Bool         :: Const a Bool
    Int          :: Const a Int
@@ -196,6 +208,7 @@          Exercise         -> showId val
          Strategy         -> show val
          Rule             -> showId val
+         Constraint       -> showId val
          Id               -> showId val
          SomeExercise     -> case val of Some ex -> showId ex
          State            -> show val
@@ -204,9 +217,12 @@          Script           -> show val
          StratCfg         -> show val
          Environment      -> show val
+         Term             -> show val
          Text             -> show val
-         StdGen           -> show val
+         QCGen            -> show val
          Result           -> show val
+         MathML           -> show val
+         XML              -> show val
          Bool             -> map toLower (show val)
          Int              -> show val
          String           -> val
@@ -220,16 +236,20 @@    showF Strategy     = "Strategy"
    showF State        = "State"
    showF Rule         = "Rule"
+   showF Constraint   = "Constraint"
    showF Context      = "Context"
    showF Id           = "Id"
    showF Location     = "Location"
    showF Script       = "Script"
    showF StratCfg     = "StrategyConfiguration"
    showF Environment  = "Environment"
+   showF Term         = "Term"
    showF Text         = "TextMessage"
-   showF StdGen       = "StdGen"
+   showF QCGen        = "QCGen"
    showF Result       = "TestSuiteResult"
    showF SomeExercise = "Exercise"
+   showF MathML       = "MathML"
+   showF XML          = "XML"
    showF Bool         = "Bool"
    showF Int          = "Int"
    showF String       = "String"
@@ -280,6 +300,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
 
@@ -292,6 +315,9 @@ tContext :: Type a (Context a)
 tContext = Const Context
 
+tMathML :: Type a MathML
+tMathML = Const MathML
+
 tBool :: Type a Bool
 tBool = Const Bool
 
@@ -301,6 +327,9 @@ tRule :: Type a (Rule (Context a))
 tRule = Const Rule
 
+tConstraint :: Type a (Constraint (Context a))
+tConstraint = Const Constraint
+
 tLocation :: Type a Location
 tLocation = Const Location
 
@@ -325,16 +354,25 @@ tEnvironment :: Type a Environment
 tEnvironment = Const Environment
 
+tTerm :: Type a Term
+tTerm = Const Term
+
 tDifficulty :: Type a Difficulty
 tDifficulty = Tag "Difficulty" (Iso (f <-> show) tString)
     where
       f = fromMaybe Medium . readDifficulty
 
-tStdGen :: Type a StdGen
-tStdGen = Const StdGen
+tUserId :: Type a String
+tUserId = Tag "UserId" tString
 
+tQCGen :: Type a QCGen
+tQCGen = Const QCGen
+
 tExamples :: Type a (Examples (Context a))
-tExamples = tList (tPair tDifficulty tContext)
+tExamples = Iso (f <-> g) (tList (tPair tDifficulty tContext))
+ where
+   f = examplesWithDifficulty
+   g = map (first (fromMaybe Medium)) . allExamples -- use default difficulty
 
 tId :: Type a Id
 tId = Const Id
@@ -358,4 +396,26 @@       g (Node a xs) = (a, xs)
 
 tTestSuiteResult :: Type a TestSuite.Result
-tTestSuiteResult = Const Result+tTestSuiteResult = Const Result
+
+tXML :: Type a XML
+tXML = Const XML
+
+-------------------------------------
+
+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
+         _          -> []
src/Ideas/Text/HTML.hs view
@@ -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 2019, 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,23 +12,22 @@ -- See http://www.w3.org/TR/html4/
 --
 -----------------------------------------------------------------------------
---  $Id: HTML.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.HTML
-   ( HTMLPage, HTMLBuilder
-   , addCSS, addScript, showHTML
+   ( ToHTML(..), HTMLPage, HTMLBuilder
+   , addCSS, addScript, addStyle, showHTML
    , string, text
    , htmlPage, link
    , h1, h2, h3, h4, h5, h6
    , preText, ul, table, keyValueTable
-   , image, space, spaces, highlightXML
+   , image, space, spaces, (<#>), spaced
+   , highlightXML
    , para, ttText, hr, br, pre, bullet
    , divClass, spanClass
      -- HTML generic attributes
    , idA, classA, styleA, titleA
      -- Font style elements
    , tt, italic, bold, big, small
-   , module Data.Monoid
    ) where
 
 import Data.Char
@@ -36,18 +35,59 @@ import Data.Monoid
 import Ideas.Text.XML
 import Prelude hiding (div)
+import qualified Data.Map as M
 import qualified Ideas.Text.XML as XML
 
 type HTMLBuilder = XMLBuilder
 
+class ToHTML a where
+   toHTML     :: a -> HTMLBuilder
+   listToHTML :: [a] -> HTMLBuilder
+   -- default definitions
+   listToHTML = ul . map toHTML
+
+instance ToHTML a => ToHTML [a] where
+   toHTML = listToHTML
+
+instance (ToHTML a, ToHTML b) => ToHTML (Either a b) where
+   toHTML = either toHTML toHTML
+
+instance (ToHTML a) => ToHTML (Maybe a) where
+   toHTML = maybe mempty toHTML
+
+instance ToHTML () where
+   toHTML _ = mempty
+
+instance (ToHTML a, ToHTML b) => ToHTML (a, b) where
+   toHTML (a, b) = toHTML a <#> toHTML b
+
+instance (ToHTML a, ToHTML b, ToHTML c) => ToHTML (a, b, c) where
+   toHTML (a, b, c) = toHTML a <#> toHTML b <#> toHTML c
+
+instance (ToHTML a, ToHTML b) => ToHTML (M.Map a b) where
+   toHTML = Ideas.Text.HTML.table False . map f . M.toList
+    where
+      f (a, b) = [toHTML a, toHTML b]
+
+instance ToHTML Int where
+   toHTML = text
+
+instance ToHTML Bool where
+   toHTML = text
+
+instance ToHTML Char where
+   toHTML     = string . return
+   listToHTML = string
+
 data HTMLPage = HTMLPage
    { title       :: String
    , styleSheets :: [FilePath]
    , scripts     :: [FilePath]
+   , styleTxts   :: [String]
    , htmlContent :: HTMLBuilder
    }
 
-instance InXML HTMLPage where
+instance ToXML HTMLPage where
    toXML page = makeXML "html" $
       element "head"
          [ tag "title" (string (title page))
@@ -60,12 +100,15 @@               | css <- styleSheets page
               ]
          , mconcat
-              [ tag "script" ("src" .=. js)
+              [ tag "style" (string txt)
+              | txt <- styleTxts page
+              ]
+         , mconcat
+              [ element "script" ["src" .=. js, "type" .=. "text/javascript", string " "]
               | js <- scripts page
               ]
          ]
       <> tag "body" (htmlContent page)
-   fromXML _ = fail "HTMLPage.fromXML"
 
 showHTML :: HTMLPage -> String
 showHTML = compactXML . toXML
@@ -76,9 +119,12 @@ addScript :: FilePath -> HTMLPage -> HTMLPage
 addScript js page = page { scripts = js : scripts page }
 
+addStyle :: String -> HTMLPage -> HTMLPage
+addStyle txt page = page { styleTxts = txt : styleTxts page }
+
 -- html helper functions
 htmlPage :: String -> HTMLBuilder -> HTMLPage
-htmlPage s = HTMLPage s [] []
+htmlPage s = HTMLPage s [] [] []
 
 link :: BuildXML a => String -> a -> a
 link url body = tag "a" $
@@ -111,17 +157,21 @@ ttText = tt . string
 
 ul :: BuildXML a => [a] -> a
-ul = element "ul" . map (tag "li")
+ul xs
+   | null xs   = mempty
+   | otherwise = element "ul" (map (tag "li") xs)
 
 -- | First argument indicates whether the table has a header or not
 table :: BuildXML a => Bool -> [[a]] -> a
-table b rows = element "table" $
-   ("border" .=. "1") :
-   [ element "tr" $
-        ("class" .=. getClass i) :
-        [ tag "td" c | c <- row ]
-   | (i, row) <- zip [0::Int ..] rows
-   ]
+table b rows
+   | null rows = mempty
+   | otherwise = element "table" $
+        ("border" .=. "1") :
+        [ element "tr" $
+             ("class" .=. getClass i) :
+             [ tag "td" c | c <- row ]
+        | (i, row) <- zip [0::Int ..] rows
+        ]
  where
    getClass i
       | i == 0 && b = "top-row"
@@ -137,9 +187,15 @@ spaces n = mconcat (replicate n space)
 
 space, bullet :: BuildXML a => a
-space  = XML.unescaped "&nbsp;"
-bullet = XML.unescaped "&#8226;"
+space  = XML.string [chr 160]  -- &nbsp;
+bullet = XML.string [chr 8226]
 
+(<#>) :: BuildXML a => a -> a -> a
+x <#> y = x <> space <> y
+
+spaced :: BuildXML a => [a] -> a
+spaced = mconcat . intersperse space
+
 image :: BuildXML a => String -> a
 image n = tag "img" ("src" .=. n)
 
@@ -152,14 +208,39 @@ -- A simple XML highlighter
 highlightXML :: Bool -> XML -> HTMLBuilder
 highlightXML nice
-   | nice      = builder . highlight . makeXML "pre" . string . show
-   | otherwise = builder . highlight . makeXML "tt"  . string . compactXML
+   | nice      = tag "pre" . f . prettyXML
+   | otherwise = tag "tt"  . f . compactXML
  where
-   highlight :: XML -> XML
-   highlight html = html {content = map (either (Left . f) Right) (content html)}
-
    -- find <
-   f :: String -> String
+   f :: String -> HTMLBuilder
+   f []           = mempty
+   f ('<':'/':xs) = g "</" [] xs
+   f ('<':xs)     = g "<"  [] xs
+   f (x:xs)       = string [x] <> f xs
+
+   -- find >
+   g start acc []           = string (start ++ reverse acc)
+   g start acc ('/':'>':xs) = pp (start, reverse acc, "/>") <> f xs
+   g start acc ('>':xs)     = pp (start, reverse acc, ">")  <> f xs
+   g start acc (x:xs)       = g start (x:acc) xs
+
+   pp (start, info, end) = blue (string (start ++ as)) <> rec bs <> blue (string end)
+    where
+      (as, bs) = span isAlphaNum info
+
+      rec []       = mempty
+      rec ('=':xs) = orange (string "=") <> rec xs
+      rec ('"':xs) = case break (== '"') xs of
+                        (xs1, _:xs2) -> green (string ('"' : xs1 ++ ['"'])) <> rec xs2
+                        _ -> string ('"':xs)
+      rec (x:xs)   = string [x] <> rec xs
+
+   blue a   = tag "font" ("color" .=. "blue" <> a)
+   orange a = tag "font" ("color" .=. "orange" <> a)
+   green a  = tag "font" ("color" .=. "green" <> a)
+
+      {-
+
    f [] = []
    f list@(x:xs)
       | "&lt;/" `isPrefixOf` list = -- close tag
@@ -177,7 +258,7 @@       | "&gt;" `isPrefixOf` list =
            "</font>&gt;</font>" ++ f (drop 4 list)
       | x=='=' = "<font color='orange'>=</font>" ++ g xs
-      | otherwise = x : g xs
+      | otherwise = x : g xs -}
 
 -----------------------------------------------------------
 -- * HTML generic attributes
+ src/Ideas/Text/HTML/Templates.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- W3CSS templates for html pages
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Text.HTML.Templates
+   ( webpage, WebPage(..), Button(..), Style
+   , fontAwesome
+   ) where
+
+import Data.Monoid
+import Ideas.Text.HTML
+import Ideas.Text.HTML.W3CSS hiding (tag, ul, top, table, content)
+import Ideas.Text.XML hiding (content)
+import qualified Ideas.Text.HTML.W3CSS as W3
+
+data WebPage = WebPage
+   { title          :: String
+   , menuButtons    :: [Button]
+   , menuStyle      :: Style
+   , iconBarsStyle  :: Style
+   , sideWidth      :: Int
+   , sideHeader     :: HTMLBuilder
+   , sideButtons    :: [Button]
+   , sideStyle      :: Style
+   , iconCloseStyle :: Style
+   , content        :: HTMLBuilder
+   , footer         :: HTMLBuilder
+   , footerStyle    :: Style
+   }
+
+type Style = HTMLBuilder -> HTMLBuilder
+
+data Button = Button
+   { buttonUrl   :: String
+   , buttonStyle :: HTMLBuilder -> HTMLBuilder
+   , buttonText  :: HTMLBuilder
+   }
+
+fromButtons :: [Button] -> HTMLBuilder
+fromButtons = mconcat . map fromButton
+
+fromButton :: Button -> HTMLBuilder
+fromButton b = button (buttonUrl b) $ barItem $ buttonStyle b $ buttonText b
+
+fontAwesome :: BuildXML a => String -> a
+fontAwesome s = italic $ ("class" .=. ("fa fa-" ++ s)) <> string " "
+
+-- https://www.w3schools.com/w3css/tryw3css_templates_webpage.htm
+webpage :: WebPage -> HTMLPage
+webpage wp = w3css $
+   addCSS "https://fonts.googleapis.com/css?family=Roboto" $
+   addCSS "https://cdnjs.cloudflare.com/ajax/libs/font-awesome/4.7.0/css/font-awesome.min.css" $
+   addStyle styleText $
+   htmlPage (title wp) $
+      navBar <> sideBar <> overlayEffect <> mainContent <> script
+ where
+   navBar = tag "div" $ W3.top $
+      tag "div" $ bar $ W3.top $ leftAlign $ menuStyle wp $ mconcat
+         [ if null (sideButtons wp) then mempty else
+           button "javascript:void(0)" $ barItem $ right $ hideLarge $ iconBarsStyle wp $
+              ("onclick" .=. "w3_open()") <> fontAwesome "bars"
+         , fromButtons (menuButtons wp)
+         ]
+
+   sideBar = if null (sideButtons wp) then mempty else
+      tag "nav" $ sidebar $ barBlock $ collapse $ sideStyle wp $ mconcat
+         [ "id" .=. "mySidebar"
+         , link "javascript:void(0)" $ right $ padding Large $ iconCloseStyle wp $ hideLarge $ mconcat
+              [ "onclick" .=. "w3_close()"
+              , "title"   .=. "Close Menu"
+              , fontAwesome "remove"
+              ]
+         , sideHeader wp
+         , fromButtons (sideButtons wp)
+         ]
+
+   overlayEffect = tag "div" $ overlay $ hideLarge $ mconcat
+      [ "onclick" .=. "w3_close()"
+      , "style"   .=. "cursor:pointer"
+      , "title"   .=. "close side menu"
+      , "id"      .=. "myOverlay"
+      , " "
+      ]
+
+   -- the javascript is not to be escaped
+   script = tag "script" (string scriptText)
+
+   width | null (sideButtons wp) = "0px"
+         | otherwise             = show (sideWidth wp) ++ "px"
+
+   mainContent = tag "div" $ mainPage $ mconcat
+      [ "style" .=. ("margin-left:" ++ width)
+      , container $ vpadding XXXL $ content wp
+      , tag "footer" $ mconcat
+           [ "id" .=. "myFooter"
+           , container $ footerStyle wp $ para $ footer wp
+           ]
+      ]
+
+   styleText =
+      "html,body,h1,h2,h3,h4,h5,h6 {font-family: Roboto, sans-serif;}\
+      \.w3-sidebar {\
+      \  z-index: 3;\
+      \  width: " ++ width ++ ";\
+      \  top: 43px;\
+      \  bottom: 0;\
+      \  height: inherit;\
+      \}"
+
+scriptText :: String
+scriptText =
+   "var mySidebar = document.getElementById(\"mySidebar\");\
+   \var overlayBg = document.getElementById(\"myOverlay\");\
+   \function w3_open() {\
+   \    if (mySidebar.style.display === 'block') {\
+   \        mySidebar.style.display = 'none';\
+   \        overlayBg.style.display = 'none';\
+   \    } else {\
+   \        mySidebar.style.display = 'block';\
+   \        overlayBg.style.display = 'block';\
+   \    }\
+   \}\
+   \function w3_close() {\
+   \    mySidebar.style.display = 'none';\
+   \    overlayBg.style.display = 'none';\
+   \}"
+ src/Ideas/Text/HTML/W3CSS.hs view
@@ -0,0 +1,634 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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 minimal interface for using W3.CSS, a modern CSS framework with built-in
+-- responsiveness.
+-- See https://www.w3schools.com/w3css/
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.HTML.W3CSS where
+
+import Data.Char
+import Data.Monoid
+import Ideas.Text.HTML
+import Ideas.Text.XML
+import qualified Ideas.Text.XML as XML
+
+w3css :: HTMLPage -> HTMLPage
+w3css = addCSS "https://www.w3schools.com/w3css/4/w3.css"
+
+w3class :: BuildXML a => String -> a -> a
+w3class s a = ("class" .=. s) <> a
+
+w3classIf :: BuildXML a => Bool -> String -> a -> a
+w3classIf b s = if b then w3class s else id
+
+data Color
+   = Red | Pink | Purple | DeepPurple | Indigo | Blue | LightBlue
+   | Cyan | Aqua | Teal | Green | LightGreen | Lime | Sand | Khaki
+   | Yellow | Amber | Orange | DeepOrange | BlueGray | Brown | LightGray
+   | Gray | DarkGray | Black | PaleRed | PaleYellow | PaleGreen | PaleBlue | White
+ deriving Show
+
+data Size = Tiny | Small | Medium | Large | XL | XXL | XXXL | Jumbo
+ deriving (Eq, Ord)
+
+data Position = TopLeft    | Top    | TopRight
+              | CenterLeft | Center | CenterRight
+              | BottomLeft | Bottom | BottomRight
+ deriving (Show, Eq)
+
+onTop, onLeft, onRight, onBottom :: Position -> Bool
+onTop    = (`elem` [TopLeft, Top, TopRight])
+onLeft   = (`elem` [TopLeft, CenterLeft, BottomLeft])
+onRight  = (`elem` [TopRight, CenterRight, BottomRight])
+onBottom = (`elem` [BottomLeft, Bottom, BottomRight])
+
+instance Show Size where
+   show Tiny   = "tiny"
+   show Small  = "small"
+   show Medium = "medium"
+   show Large  = "large"
+   show XL     = "xlarge"
+   show XXL    = "xxlarge"
+   show XXXL   = "xxxlarge"
+   show Jumbo  = "jumbo"
+
+uncamel :: String -> String
+uncamel = concatMap f
+ where
+   f c = if isUpper c then ['-', toLower c] else [c]
+
+--------------------------------------------------------------------------------
+-- * Container Classes
+
+-- | HTML container with 16px left and right padding
+container :: BuildXML a => a -> a
+container = XML.tag "div" . w3class "w3-container"
+
+-- | HTML container with 16px left and right padding and 16px top and bottom margin
+panel :: BuildXML a => a -> a
+panel = XML.tag "div" . w3class "w3-panel"
+
+-- | Circular badge
+badge :: BuildXML a => a -> a
+badge = XML.tag "span" . w3class "w3-badge"
+
+-- | Rectangular tag
+tag :: BuildXML a => a -> a
+tag = XML.tag "span" . w3class "w3-tag"
+
+-- | Unordered list
+ul :: BuildXML a => [a] -> a
+ul = ulWith id
+
+-- | Unordered list
+ulWith :: BuildXML a => (a -> a) -> [a] -> a
+ulWith f = XML.tag "ul" . w3class "w3-ul" . f . mconcat . map (XML.tag "li")
+
+-- | Code container
+code :: BuildXML a => a -> a
+code = XML.tag "div" . w3class "w3-code"
+
+-- | Inline code container (for code snippets)
+codespan :: BuildXML a => a -> a
+codespan = XML.tag "code" . w3class "w3-codespan"
+
+--------------------------------------------------------------------------------
+-- * Table Classes
+
+-- | Container for an HTML table
+table :: BuildXML a => a -> a
+table = XML.tag "table" .  w3class "w3-table"
+
+-- | All properties set
+tableAll :: BuildXML a => a -> a
+tableAll = XML.tag "table" . w3class "w3-table-all"
+
+-- | Striped table
+striped :: BuildXML a => a -> a
+striped = w3class "w3-striped"
+
+-- | Bordered lines
+bordered :: BuildXML a => a -> a
+bordered = w3class "w3-bordered"
+
+-- | Centered table
+centered :: BuildXML a => a -> a
+centered = w3class "w3-centered"
+
+-- | Hoverable table
+hoverable :: BuildXML a => a -> a
+hoverable = w3class "w3-hoverable"
+
+-- | Creates a responsive table
+responsive :: BuildXML a => a -> a
+responsive = w3class "w3-responsive"
+
+--------------------------------------------------------------------------------
+-- * Card Classes
+
+-- | Same as w3-card-2
+card :: BuildXML a => a -> a
+card = w3class "w3-card"
+
+-- | Container for any HTML content (2px bordered shadow)
+card2 :: BuildXML a => a -> a
+card2 = w3class "w3-card-2"
+
+-- | Container for any HTML content (4px bordered shadow)
+card4 :: BuildXML a => a -> a
+card4 = w3class "w3-card-4"
+
+--------------------------------------------------------------------------------
+-- * Responsive Classes
+
+-- | Container for one row of fluid responsive content
+row :: BuildXML a => a -> a
+row = w3class "w3-row"
+
+-- | Row where all columns have a default padding
+rowPadding :: BuildXML a => a -> a
+rowPadding = w3class "w3-row-padding"
+
+-- | Container for fixed size centered content
+content :: BuildXML a => a -> a
+content = w3class "w3-content"
+
+-- | Half (1/2) screen column container
+half :: BuildXML a => a -> a
+half = w3class "w3-half"
+
+-- | Third (1/3) screen column container
+third :: BuildXML a => a -> a
+third = w3class "w3-third"
+
+-- | Two third (2/3) screen column container
+twothird :: BuildXML a => a -> a
+twothird = w3class "w3-twothird"
+
+-- | Quarter (1/4) screen column container
+quarter :: BuildXML a => a -> a
+quarter = w3class "w3-quarter"
+
+-- | Three quarters (3/4) screen column container
+threequarter :: BuildXML a => a -> a
+threequarter = w3class "w3-threequarter"
+
+-- | Column container for any HTML content
+col :: BuildXML a => a -> a
+col = w3class "w3-col"
+
+-- | Occupies the rest of the column width
+rest :: BuildXML a => a -> a
+rest = w3class "w3-rest"
+
+-- | Hide content on small screens (less than 601px)
+hideSmall :: BuildXML a => a -> a
+hideSmall = w3class "w3-hide-small"
+
+-- | Hide content on medium screens
+hideMedium :: BuildXML a => a -> a
+hideMedium = w3class "w3-hide-medium"
+
+-- | Hide content on large screens (larger than 992px)
+hideLarge :: BuildXML a => a -> a
+hideLarge = w3class "w3-hide-large"
+
+-- | Responsive image
+image :: BuildXML a => a -> a
+image = w3class "w3-image"
+
+-- | Adds mobile-first responsiveness to any element. Displays elements as block elements on mobile devices.
+mobile :: BuildXML a => a -> a
+mobile = w3class "w3-mobile"
+
+-- l1 - l12 Responsive sizes for large screens
+-- m1 - m12 Responsive sizes for medium screens
+-- s1 - s12 Responsive sizes for small screens
+
+--------------------------------------------------------------------------------
+-- * Layout Classes
+
+-- | Container for layout columns (cells).
+cellRow :: BuildXML a => a -> a
+cellRow = w3class "w3-cell-row"
+
+-- | Layout column (cell).
+cell :: BuildXML a => a -> a
+cell = w3class "w3-cell"
+
+-- | Aligns content at the top of a column (cell).
+cellTop :: BuildXML a => a -> a
+cellTop = w3class "w3-cell-top"
+
+-- | Aligns content at the vertical middle of a column (cell).
+cellMiddle :: BuildXML a => a -> a
+cellMiddle = w3class "w3-cell-middle"
+
+-- | Aligns content at the bottom of a column (cell).
+cellBottom :: BuildXML a => a -> a
+cellBottom = w3class "w3-cell-bottom"
+
+--------------------------------------------------------------------------------
+-- * Bar Classes - Navigation
+
+-- | Horizontal bar
+bar :: BuildXML a => a -> a
+bar = w3class "w3-bar"
+
+-- | Vertical bar
+barBlock :: BuildXML a => a -> a
+barBlock = w3class "w3-bar-block"
+
+-- | Provides common style for bar items
+barItem :: BuildXML a => a -> a
+barItem = w3class "w3-bar-item"
+
+-- | Side bar
+sidebar :: BuildXML a => a -> a
+sidebar = w3class "w3-sidebar"
+
+-- | Used together with w3-sidebar to create a fully automatic responsive side navigation. For this class to work, the page content must be within a "w3-main" class
+collapse :: BuildXML a => a -> a
+collapse = w3class "w3-collapse"
+
+-- | Container for page content when using the w3-collapse class for responsive side navigations
+mainPage :: BuildXML a => a -> a
+mainPage = w3class "w3-main"
+
+--------------------------------------------------------------------------------
+-- * Dropdown Classes
+
+-- | Clickable dropdown element
+dropdownClick :: BuildXML a => a -> a
+dropdownClick = w3class "w3-dropdown-click"
+
+-- | Hoverable dropdown element
+dropdownHover :: BuildXML a => a -> a
+dropdownHover = w3class "w3-dropdown-hover"
+
+--------------------------------------------------------------------------------
+-- * Button Classes
+
+-- | Rectangular button with grey background color on hover
+button :: BuildXML a => String -> a -> a
+button url = link url . w3class "w3-button"
+
+-- | Rectangular button with shadows on hover
+btn :: BuildXML a => String -> a -> a
+btn url = link url . w3class "w3-btn"
+
+-- | Rectangular button with ripple effect
+ripple :: BuildXML a => String -> a -> a
+ripple url = link url . w3class "w3-ripple"
+
+--------------------------------------------------------------------------------
+-- * Input Classes
+
+-- | Input elements
+input :: BuildXML a => a -> a
+input = w3class "w3-input"
+
+-- | Checkbox input type
+check :: BuildXML a => a -> a
+check = w3class "w3-check"
+
+-- | Radio input type
+radio :: BuildXML a => a -> a
+radio = w3class "w3-radio"
+
+-- | Input select element
+select :: BuildXML a => a -> a
+select = w3class "w3-select"
+
+--------------------------------------------------------------------------------
+-- * Modal Classes
+
+-- | Modal container
+modal :: BuildXML a => a -> a
+modal = w3class "w3-modal"
+
+-- | Modal pop-up element
+modalContent :: BuildXML a => a -> a
+modalContent = w3class "w3-modal-content"
+
+-- | Tooltip element
+tooltip :: BuildXML a => a -> a
+tooltip = w3class "w3-tooltip"
+
+-- | Tooltip text
+tooltipText :: BuildXML a => a -> a
+tooltipText = w3class "w3-text"
+
+--------------------------------------------------------------------------------
+-- * Animation Classes
+
+-- | Animates an element from -300px to 0px
+animate :: BuildXML a => Position -> a -> a
+animate p = w3classIf (onTop p)    "w3-animate-top"
+          . w3classIf (onLeft p)   "w3-animate-left"
+          . w3classIf (onBottom p) "w3-animate-bottom"
+          . w3classIf (onRight p)  "w3-animate-right"
+
+-- | Animates an element's opacity from 0 to 1
+animateOpacity :: BuildXML a => a -> a
+animateOpacity = w3class "w3-animate-opacity"
+
+-- | Animates an element from 0 to 100% in size
+animateZoom :: BuildXML a => a -> a
+animateZoom = w3class "w3-animate-zoom"
+
+-- | Animates an element's opacity from 0 to 1 and 1 to 0 (fades in AND out)
+animateFading :: BuildXML a => a -> a
+animateFading = w3class "w3-animate-fading"
+
+-- | Spin an icon 360 degrees
+spin :: BuildXML a => a -> a
+spin = w3class "w3-spin"
+
+-- | Animates the width of an input field to 100%
+animateInput :: BuildXML a => a -> a
+animateInput = w3class "w3-animate-input"
+
+--------------------------------------------------------------------------------
+-- * Font and Text Classes
+
+-- | Specifies a font size: tiny 10px, small 12px, large 18px, xlarge 24px, xxlarge 32px, xxxlarge 48px, jumbo 64px
+fontSize :: BuildXML a => Size -> a -> a
+fontSize = w3class . ("w3-" ++) . show
+
+-- | Specifies a wider text
+wide :: BuildXML a => a -> a
+wide = w3class "w3-wide"
+
+-- | Changes the font to serif
+serif :: BuildXML a => a -> a
+serif = w3class "w3-serif"
+
+--------------------------------------------------------------------------------
+-- * Display Classes
+
+-- | Centered content
+center :: BuildXML a => a -> a
+center = w3class "w3-center"
+
+-- | Floats an element to the left (float: left)
+left :: BuildXML a => a -> a
+left = w3class "w3-left"
+
+-- | Floats an element to the right (float: right)
+right :: BuildXML a => a -> a
+right = w3class "w3-right"
+
+-- | Left aligned text
+leftAlign :: BuildXML a => a -> a
+leftAlign = w3class "w3-left-align"
+
+-- | Right aligned text
+rightAlign :: BuildXML a => a -> a
+rightAlign = w3class "w3-right-align"
+
+-- | Right and left aligned text
+justify :: BuildXML a => a -> a
+justify = w3class "w3-justify"
+
+-- | Circled content
+circle :: BuildXML a => a -> a
+circle = w3class "w3-circle"
+
+-- | Hidden content (display:none)
+hide :: BuildXML a => a -> a
+hide = w3class "w3-hide"
+
+-- | Alias of w3-show (display:block)
+showBlock :: BuildXML a => a -> a
+showBlock = w3class "w3-show-block"
+
+-- | Show content as inline-block (display:inline-block)
+showInlineBlock :: BuildXML a => a -> a
+showInlineBlock = w3class "w3-show-inline-block"
+
+-- | Fixed content at the top of a page
+top :: BuildXML a => a -> a
+top = w3class "w3-top"
+
+-- | Fixed content at the bottom of a page
+bottom :: BuildXML a => a -> a
+bottom = w3class "w3-bottom"
+
+-- | Container for w3-display-classes (position: relative)
+display :: BuildXML a => Position -> a -> a
+display p = w3class "w3-display-container" . w3class (f p)
+ where
+   f TopLeft     = "w3-display-topleft"
+   f Top         = "w3-display-topmiddle"
+   f TopRight    = "w3-display-topright"
+   f CenterLeft  = "w3-display-left"
+   f Center      = "w3-display-middle"
+   f CenterRight = "w3-display-right"
+   f BottomLeft  = "w3-display-bottomleft"
+   f Bottom      = "w3-display-bottommiddle"
+   f BottomRight = "w3-display-bottomright"
+
+-- | Displays content on hover inside the w3-display-container
+displayHover :: BuildXML a => a -> a
+displayHover = w3class "w3-display-hover"
+
+--------------------------------------------------------------------------------
+-- * Effect Classes
+
+-- | Adds opacity/transparency to an element (opacity: 0.6)
+opacity :: BuildXML a => a -> a
+opacity = w3class "w3-opacity"
+
+-- | Turns off opacity/transparency (opacity: 1)
+opacityOff :: BuildXML a => a -> a
+opacityOff = w3class "w3-opacity-off"
+
+-- | Adds opacity/transparency to an element (opacity: 0.75)
+opacityMin :: BuildXML a => a -> a
+opacityMin = w3class "w3-opacity-min"
+
+-- | Adds opacity/transparency to an element (opacity: 0.25)
+opacityMax :: BuildXML a => a -> a
+opacityMax = w3class "w3-opacity-max"
+
+-- | Adds a grayscale effect to an element (grayscale: 50%)
+grayscaleMin :: BuildXML a => a -> a
+grayscaleMin = w3class "w3-grayscale-min"
+
+-- | Adds a grayscale effect to an element (grayscale: 75%)
+grayscale :: BuildXML a => a -> a
+grayscale = w3class "w3-grayscale"
+
+-- | Adds a grayscale effect to an element (grayscale: 100%)
+grayscaleMax :: BuildXML a => a -> a
+grayscaleMax = w3class "w3-grayscale-max"
+
+-- | Adds a sepia effect to an element (sepia: 50%)
+sepiaMin :: BuildXML a => a -> a
+sepiaMin = w3class "w3-sepia-min"
+
+-- | Adds a sepia effect to an element (sepia: 75%)
+sepia :: BuildXML a => a -> a
+sepia = w3class "w3-sepia"
+
+-- | Adds a sepia effect to an element (sepia: 100%)
+sepiaMax :: BuildXML a => a -> a
+sepiaMax = w3class "w3-sepia-max"
+
+-- | Creates an overlay effect
+overlay :: BuildXML a => a -> a
+overlay = w3class "w3-overlay"
+
+--------------------------------------------------------------------------------
+-- * Background Color Classes
+
+-- | Background color
+background :: BuildXML a => Color -> a -> a
+background = w3class . ("w3" ++) .  uncamel . show
+
+-- | Transparent background-color
+transparent :: BuildXML a => a -> a
+transparent = w3class "w3-transparent"
+
+--------------------------------------------------------------------------------
+--  * Color Classes
+
+-- | Hover color
+hover :: BuildXML a => Color -> a -> a
+hover = w3class . ("w3-hover" ++) .  uncamel . show
+
+--------------------------------------------------------------------------------
+-- * Text Color Classes
+
+-- | Text color
+textColor :: BuildXML a => Color -> a -> a
+textColor = w3class . ("w3-text" ++) .  uncamel . show
+
+--------------------------------------------------------------------------------
+-- * Hover Classes
+
+-- | Hover text color
+hoverColor :: BuildXML a => Color -> a -> a
+hoverColor = w3class . ("w3-hover-text" ++) .  uncamel . show
+
+-- | Adds transparency to an element on hover (opacity: 0.6)
+hoverOpacity :: BuildXML a => a -> a
+hoverOpacity = w3class "w3-hover-opacity"
+
+-- | Removes transparency from an element on hover (100% opacity)
+hoverOpacityOff :: BuildXML a => a -> a
+hoverOpacityOff = w3class "w3-hover-opacity-off"
+
+-- | Adds shadow to an element on hover
+hoverShadow :: BuildXML a => a -> a
+hoverShadow = w3class "w3-hover-shadow"
+
+-- | Adds a black and white (100% grayscale) effect to an element
+hoverGrayscale :: BuildXML a => a -> a
+hoverGrayscale = w3class "w3-hover-grayscale"
+
+-- | Adds a sepia effect to an element on hover
+hoverSepia :: BuildXML a => a -> a
+hoverSepia = w3class "w3-hover-sepia"
+
+-- | Removes hover effects from an element
+hoverNone :: BuildXML a => a -> a
+hoverNone = w3class "w3-hover-none"
+
+--------------------------------------------------------------------------------
+-- * Round Classes
+
+-- | Element rounded (border-radius): small 2px, medium 4px, large 8px, xlarge 16px, xxlarge 32px
+rounded :: BuildXML a => Size -> a -> a
+rounded s = w3class "w3-round" . w3class ("w3-round-" ++ show s)
+
+--------------------------------------------------------------------------------
+-- * Padding Classes
+
+-- | Small: Padding 4px top and bottom, and 8px left and right, Medium: Padding 8px top and bottom, and 16px left and right, Large: Padding 12px top and bottom, and 24px left and right.
+padding :: BuildXML a => Size -> a -> a
+padding s
+   | s < Medium = w3class "w3-padding-small"
+   | s > Medium = w3class "w3-padding-large"
+   | otherwise  = w3class "w3-padding-small"
+
+-- | Padding top and bottom: medium 16px, large 24px, xlarge 32px, xxlarge 48px, xxxlarge 64px
+vpadding :: BuildXML a => Size -> a -> a
+vpadding s
+   | s <= Medium = w3class "w3-padding-16"
+   | s == Large  = w3class "w3-padding-24"
+   | s == XL     = w3class "w3-padding-32"
+   | s == XXL    = w3class "w3-padding-48"
+   | otherwise   = w3class "w3-padding-64"
+
+--------------------------------------------------------------------------------
+-- * Margin Classes
+
+-- | Adds an 16px margin to an element
+margin :: BuildXML a => a -> a
+margin = w3class "w3-margin"
+
+marginPos :: BuildXML a => Position -> a -> a
+marginPos p = w3classIf (onTop p)    "w3-margin-top"
+            . w3classIf (onLeft p)   "w3-margin-left"
+            . w3classIf (onBottom p) "w3-margin-bottom"
+            . w3classIf (onRight p)  "w3-margin-right"
+
+-- | Adds an 16px top and bottom margin to an element
+section :: BuildXML a => a -> a
+section = w3class "w3-section"
+
+--------------------------------------------------------------------------------
+-- * Border Classes
+
+-- | Borders (top, right, bottom, left)
+border :: BuildXML a => a -> a
+border = w3class "w3-border"
+
+borderPos :: BuildXML a => Position -> a -> a
+borderPos p = w3classIf (onTop p)    "w3-border-top"
+            . w3classIf (onLeft p)   "w3-border-left"
+            . w3classIf (onBottom p) "w3-border-bottom"
+            . w3classIf (onRight p)  "w3-border-right"
+
+-- | Removes all borders
+noBorder :: BuildXML a => a -> a
+noBorder = w3class "w3-border-0"
+
+-- | Border color
+borderColor :: BuildXML a => Color -> a -> a
+borderColor = w3class . ("w3-border" ++) .  uncamel . show
+
+-- | Adds a thick border (bar) to an element
+barPos :: BuildXML a => Position -> a -> a
+barPos p = w3classIf (onTop p)    "w3-topbar"
+         . w3classIf (onLeft p)   "w3-leftbar"
+         . w3classIf (onBottom p) "w3-bottombar"
+         . w3classIf (onRight p)  "w3-rightbar"
+
+--------------------------------------------------------------------------------
+-- * Color themes
+
+data ColorTheme
+   = L1 | L2 | L3 | L4 | L5 -- light
+   | D1 | D2 | D3 | D4 | D5 -- dark
+ deriving Show
+
+-- standard color theme
+theme_, textTheme, borderTheme :: BuildXML a => a -> a
+theme_      = w3class "w3-theme"
+textTheme   = w3class "w3-text-theme"
+borderTheme = w3class "w3-border-theme"
+
+theme :: BuildXML a => ColorTheme -> a -> a
+theme = w3class . ("w3-theme-" ++) . map toLower . show
src/Ideas/Text/JSON.hs view
@@ -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 2019, 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,23 +12,22 @@ -- JSON. JSON is a lightweight alternative for XML.
 --
 -----------------------------------------------------------------------------
---  $Id: JSON.hs 7524 2015-04-08 07:31:15Z 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
 import Control.Monad
 import Data.List (intersperse)
 import Data.Maybe
-import Ideas.Text.Parsing hiding (string, char)
-import Prelude hiding (catch)
-import System.IO.Error hiding (catch)
+import Ideas.Utils.Parsing hiding (string, char)
+import System.IO.Error
 import Test.QuickCheck
 import Text.PrettyPrint.Leijen hiding ((<$>))
 import qualified Ideas.Text.UTF8 as UTF8
@@ -89,9 +88,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]
@@ -108,7 +107,7 @@ 
 instance InJSON Int where
    toJSON   = toJSON . toInteger
-   fromJSON = liftM fromInteger . fromJSON
+   fromJSON = fmap fromInteger . fromJSON
 
 instance InJSON Integer where
    toJSON                  = Number . I
@@ -139,24 +138,19 @@ 
 instance (InJSON a, InJSON b) => InJSON (a, b) where
    toJSON (a, b)           = Array [toJSON a, toJSON b]
-   fromJSON (Array [a, b]) = liftM2 (,) (fromJSON a) (fromJSON b)
+   fromJSON (Array [a, b]) = (,) <$> fromJSON a <*> fromJSON b
    fromJSON _              = fail "expecting an array with 2 elements"
 
 instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where
    toJSON (a, b, c)           = Array [toJSON a, toJSON b, toJSON c]
-   fromJSON (Array [a, b, c]) = liftM3 (,,) (fromJSON a) (fromJSON b) (fromJSON c)
+   fromJSON (Array [a, b, c]) = (,,) <$> fromJSON a <*> fromJSON b <*> fromJSON c
    fromJSON _                 = fail "expecting an array with 3 elements"
 
 instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where
    toJSON (a, b, c, d)           = Array [toJSON a, toJSON b, toJSON c, toJSON d]
-   fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d)
+   fromJSON (Array [a, b, c, d]) = (,,,) <$> fromJSON a <*> fromJSON b <*> fromJSON c <*> fromJSON d
    fromJSON _                    = fail "expecting an array with 4 elements"
 
-instance InJSON IOException where
-   toJSON     = toJSON . ioeGetErrorString
-   fromJSON (String s) = return (userError s)
-   fromJSON _ = fail "excepting a string"
-
 --------------------------------------------------------
 -- Parser
 
@@ -169,7 +163,7 @@       , Boolean True  <$ P.reserved lexer "true"
       , Boolean False <$ P.reserved lexer "false"
       , Number . either I D <$> naturalOrFloat -- redefined in Ideas.Text.Parsing
-      , String . fromMaybe [] . UTF8.decodeM <$> P.stringLiteral lexer
+      , String <$> P.stringLiteral lexer
       , Array  <$> P.brackets lexer (sepBy json (P.comma lexer))
       , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer))
       ]
@@ -261,8 +255,10 @@          return (okResponse json (requestId req))
        `catch` handler req
  where
-   handler :: RPCRequest -> IOException -> IO RPCResponse
-   handler req e = return (errorResponse (toJSON e) (requestId req))
+   handler :: RPCRequest -> SomeException -> IO RPCResponse
+   handler req e =
+      let msg = maybe (show e) ioeGetErrorString (fromException e)
+      in return $ errorResponse (toJSON msg) (requestId req)
 
 --------------------------------------------------------
 -- Testing parser/pretty-printer
@@ -271,13 +267,13 @@    arbitrary = sized arbJSON
 
 instance Arbitrary Number where
-   arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary]
+   arbitrary = oneof [ I <$> arbitrary, D . fromInteger <$> arbitrary ]
 
 arbJSON :: Int -> Gen JSON
 arbJSON n
    | n == 0 = oneof
-        [ liftM Number arbitrary, liftM String myStringGen
-        , liftM Boolean arbitrary, return Null
+        [ Number <$> arbitrary, String <$> myStringGen
+        , Boolean <$> arbitrary, return Null
         ]
    | otherwise = oneof
         [ arbJSON 0
+ src/Ideas/Text/Latex.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Support for LaTeX.
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Text.Latex
+   ( Latex, ToLatex(..)
+   , array, commas, brackets, parens
+   , command
+   ) where
+
+import Data.List
+import Data.Semigroup as Sem
+import Data.String
+
+newtype Latex = L { showLatex :: String }
+
+instance Show Latex where
+   show = showLatex
+
+instance IsString Latex where
+   fromString = L
+
+instance Sem.Semigroup Latex where
+   L xs <> L ys = L (xs <> ys)
+
+instance Monoid Latex where
+   mempty  = L []
+   mappend = (<>)
+
+class ToLatex a where
+   toLatex     :: a -> Latex
+   toLatexPrec :: Int -> a -> Latex
+   toLatexList :: [a] -> Latex
+   -- default implementations
+   toLatex     = toLatexPrec 0
+   toLatexPrec = const toLatex
+   toLatexList = brackets . commas . map toLatex
+   {-# MINIMAL toLatex | toLatexPrec #-}
+
+instance ToLatex a => ToLatex [a] where
+   toLatex     = toLatexList
+   toLatexPrec = const toLatexList
+
+instance ToLatex a => ToLatex (Maybe a) where
+   toLatexPrec = maybe mempty . toLatexPrec
+
+instance ToLatex Char where
+   toLatex     = fromString . return
+   toLatexList = fromString
+
+instance ToLatex Int where
+   toLatex = fromString . show
+
+commas :: [Latex] -> Latex
+commas = mconcat . intersperse ",\\:"
+
+brackets, parens :: Latex -> Latex
+brackets s = "[" <> s <> "]"
+parens   s = "(" <> s <> ")"
+
+array :: String -> [[Latex]] -> Latex
+array s rows = "\\begin{array}{" <> fromString s <> "}"
+   <> mconcat (intersperse "\\\\" (map (mconcat . intersperse " & ") rows))
+   <> "\\end{array}"
+
+command :: String -> Latex
+command s = toLatex ("\\" ++ s ++ " ")
+ src/Ideas/Text/MathML.hs view
@@ -0,0 +1,151 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Text.MathML
+   ( MathML(..), xml2mathml, mathml2xml
+   ) where
+
+import Data.Maybe
+import Ideas.Text.XML
+import Ideas.Utils.Uniplate hiding (children)
+
+data MathML = MRow [MathML]
+            | MId String
+            | MNumber String
+            | MOperator String
+            | MString String
+            | MText String
+            | MSqrt MathML
+            | MRoot MathML MathML
+            | MSup MathML MathML -- base, superscript
+            | MSub MathML MathML -- base, subscript
+            | MSubSup MathML MathML MathML -- base, subscript, superscript
+            | MFrac MathML MathML -- numerator, denominator
+            | MFenced String String MathML -- left, right, content
+            | MSpace
+            | MStyle
+            | MPadded
+            | MPhantom
+            | MError
+            | MEnclose
+            | MUnder
+            | MOver
+            | MUnderOver
+            | MTable
+            | MTableRow
+            | MLabeledTableRow
+            | MTableData
+   deriving (Show, Eq)
+{-
+from: https://www.w3.org/TR/MathML2/chapter3.html#presm.mn @ 3.2.1
+Conversely, since mn is a presentation element, there are a few situations where it may desirable to include arbitrary text in the content of an mn that should merely render as a numeric literal
+-}
+
+instance ToXML MathML where
+   toXML = mathml2xml
+
+instance InXML MathML where
+   fromXML = either fail return . xml2mathml
+
+instance Uniplate MathML where
+   uniplate math =
+      case math of
+         MRow xs       -> plate MRow ||* xs
+         _             -> plate math
+
+----------------------------------------------------------
+-- conversion functions: XML <-> MathML
+
+xml2mathml :: XML -> Either String MathML
+xml2mathml = rec
+ where
+   rec xml = case name xml of
+       "mrow"       -> MRow <$> mapM rec (children xml)
+       "mi"         -> return (MId (getData xml))
+       "mn"         -> return (MNumber (getData xml))
+       "mo"         -> return (MOperator (getData xml))
+       "ms"         -> return (MString (getData xml))
+       "mtext"      -> return (MText (getData xml))
+       "mroot"      -> case children xml of
+                          [c, d] -> MRoot <$> rec c <*> rec d
+                          _ -> fail "invalid mroot"
+       "msup"       -> case children xml of
+                          [c, d] -> MSup <$> rec c <*> rec d
+                          _ -> fail "invalid msup"
+       "msub"       -> case children xml of
+                          [c, d] -> MSub <$> rec c <*> rec d
+                          _ -> fail "invalid msub"
+       "msubsup"    -> case children xml of
+                          [c, d, e] -> MSubSup <$> rec c <*> rec d <*> rec e
+                          _ -> fail "invalid msubsup"
+       "mfrac"      -> case children xml of
+                          [c, d] -> MFrac <$> rec c <*> rec d
+                          _ -> fail "invalid mfrac"
+       "mfenced"    -> case children xml of
+                          [c] -> MFenced (fromMaybe "(" (findAttribute "open" xml)) (fromMaybe ")" (findAttribute "close" xml)) <$> rec c
+                          _ -> fail "invalid mfenced"
+       "mspace"     -> return MSpace
+       "mtable"     -> return MTable
+       "mtr"        -> return MTableRow
+       "mlabeledtr" -> return MLabeledTableRow
+       "munder"     -> return MUnder
+       "mover"      -> return MOver
+       "munderover" -> return MUnderOver
+       -- below are cases that have 1* arguments, when none-one an mrow is implied.
+       "math"       -> impliedMRow xml
+       "msqrt"      -> MSqrt <$> impliedMRow xml
+       "mphantom"   -> return MPhantom
+       "mpadded"    -> return MPadded
+       "mstyle"     -> return MStyle
+       "merror"     -> return MError
+       "mtd"        -> return MTableData
+       "menclose"   -> return MEnclose
+       _ -> fail ("unsupported MathML: " ++ show xml)
+
+   impliedMRow :: XML -> Either String MathML
+   impliedMRow xml =
+      case children xml of
+         [x] -> rec x
+         xs  -> MRow <$> mapM rec xs
+
+mathml2xml :: MathML -> XML
+mathml2xml = makeXML "math" . rec
+ where
+   rec :: MathML -> XMLBuilder
+   rec math =
+      case math of
+         MRow ms           -> element "mrow" (map rec ms)
+         MId s             -> element "mi" [string s]
+         MNumber s         -> element "mn" [string s]
+         MOperator s       -> element "mo" [string s]
+         MString s         -> element "ms" [string s]
+         MText s           -> element "mtext" [string s]
+         MSqrt m           -> element "msqrt" [rec m]
+         MRoot m1 m2       -> element "mroot" [rec m1, rec m2]
+         MSup m1 m2        -> element "msup" [rec m1, rec m2]
+         MSub m1 m2        -> element "msub" [rec m1, rec m2]
+         MSubSup m1 m2 m3  -> element "msubsup" [rec m1, rec m2, rec m3]
+         MFrac m1 m2       -> element "mfrac" [rec m1, rec m2]
+         MFenced s1 s2 m   -> element "mfenced" ["open" .=. s1, "close" .=. s2, rec m]
+         MSpace            -> element "mspace" []
+         MStyle            -> element "mstyle" []
+         MPadded           -> element "mpadded" []
+         MPhantom          -> element "mphantom" []
+         MError            -> element "merror" []
+         MEnclose          -> element "menclose" []
+         MUnder            -> element "munder" []
+         MOver             -> element "mover" []
+         MUnderOver        -> element "munderover" []
+         MTable            -> element "mtable" []
+         MTableRow         -> element "mtr" []
+         MLabeledTableRow  -> element "mlabeledtr" []
+         MTableData        -> element "mtd" []
src/Ideas/Text/OpenMath/FMP.hs view
@@ -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 2019, 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,6 @@ -- Formal mathematical properties (FMP)
 --
 -----------------------------------------------------------------------------
---  $Id: FMP.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.OpenMath.FMP where
src/Ideas/Text/OpenMath/Object.hs view
@@ -1,8 +1,7 @@-{-# 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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Object.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.OpenMath.Object
    ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
@@ -20,7 +18,6 @@ import Data.Generics.Uniplate.Direct hiding (children)
 import Data.List (nub)
 import Data.Maybe
-import Data.Typeable
 import Ideas.Text.OpenMath.Symbol
 import Ideas.Text.XML
 
@@ -31,10 +28,12 @@            | OMS Symbol
            | OMA [OMOBJ]
            | OMBIND OMOBJ [String] OMOBJ
-   deriving (Show, Eq, Typeable)
+   deriving (Show, Eq)
 
+instance ToXML OMOBJ where
+   toXML = omobj2xml
+
 instance InXML OMOBJ where
-   toXML   = omobj2xml
    fromXML = either fail return . xml2omobj
 
 instance Uniplate OMOBJ where
@@ -51,45 +50,50 @@ -- conversion functions: XML <-> OMOBJ
 
 xml2omobj :: XML -> Either String OMOBJ
-xml2omobj xmlTop =
-   case xmlTop of
-      Element "OMOBJ" _ [Right e] -> rec e
-      _ -> fail $ "expected an OMOBJ tag" ++ show xmlTop
+xml2omobj xmlTop
+   | name xmlTop == "OMOBJ" =
+        case children xmlTop of
+           [x] -> rec x
+           _   -> fail "invalid omobj"
+   | otherwise = fail "expected an OMOBJ tag"
  where
    rec xml =
-      case content xml of
-
-         _ | name xml == "OMA" -> do
+      case name xml of
+         "OMA" -> do
             ys <- mapM rec (children xml)
             return (OMA ys)
 
-         [] | name xml == "OMS" -> do
-            let mcd = findAttribute "cd" xml
+         "OMS" | emptyContent xml -> do
+            let mcd = case findAttribute "cd" xml of
+                         Just "unknown" -> Nothing
+                         this -> this
             n <- findAttribute "name" xml
             return (OMS (mcd, n))
 
-         [Left s] | name xml == "OMI" ->
-            case readInt s of
+         "OMI" | name xml == "OMI" ->
+            case readInt (getData xml) of
                Just i -> return (OMI (toInteger i))
                _      -> fail "invalid integer in OMI"
 
-         [] | name xml == "OMF" -> do
+         "OMF" | emptyContent xml -> do
             s <- findAttribute "dec" xml
             case readDouble s of
                Just nr -> return (OMF nr)
                _       -> fail "invalid floating-point in OMF"
 
-         [] | name xml == "OMV" -> do
+         "OMV" | emptyContent xml -> do
             s <- findAttribute "name" xml
             return (OMV s)
 
-         [Right x1, Right x2, Right x3] | name xml == "OMBIND" -> do
-            y1 <- rec x1
-            y2 <- recOMBVAR x2
-            y3 <- rec x3
-            return (OMBIND y1 y2 y3)
-
-         _ -> fail ("invalid tag " ++ show (name xml))
+         "OMBIND" ->
+            case children xml of
+               [x1, x2, x3] -> do
+                  y1 <- rec x1
+                  y2 <- recOMBVAR x2
+                  y3 <- rec x3
+                  return (OMBIND y1 y2 y3)
+               _ -> fail "invalid ombind"
+         _ -> fail ("invalid tag " ++ name xml)
 
    recOMBVAR xml
       | name xml == "OMBVAR" =
src/Ideas/Text/OpenMath/Symbol.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Symbol.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.OpenMath.Symbol where
src/Ideas/Text/OpenMath/Tests.hs view
@@ -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 2019, 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,6 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
---  $Id: Tests.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.OpenMath.Tests (propEncoding) where
 
@@ -35,15 +34,15 @@       relation1List ++ transc1List
 
    rec 0 = frequency
-      [ (1, liftM OMI arbitrary)
-      , (1, liftM (\n -> OMF (fromInteger n / 1000)) arbitrary)
-      , (1, liftM OMV arbitrary)
+      [ (1, OMI <$> arbitrary)
+      , (1, (\n -> OMF (fromInteger n / 1000)) <$> arbitrary)
+      , (1, OMV <$> arbitrary)
       , (5, elements $ map OMS symbols)
       ]
    rec n = frequency
       [ (1, rec 0)
-      , (3, choose (1,4) >>= liftM OMA . (`replicateM` f))
-      , (1, liftM3 OMBIND f arbitrary f)
+      , (3, choose (1,4) >>= fmap OMA . (`replicateM` f))
+      , (1, OMBIND <$> f <*> arbitrary <*> f)
       ]
     where
       f = rec (n `div` 2)
− src/Ideas/Text/Parsing.hs 
@@ -1,121 +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)
---
--- Utility functions for parsing with Parsec library
---
------------------------------------------------------------------------------
---  $Id: Parsing.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Text.Parsing
-   ( module Export
-   , (<*>), (*>), (<*), (<$>), (<$), (<**>)
-   , parseSimple, complete, skip, (<..>), ranges, stopOn
-   , naturalOrFloat, float
-   , UnbalancedError(..), balanced
-   ) where
-
-import Control.Applicative hiding ((<|>))
-import Control.Arrow
-import Control.Monad
-import Data.Char
-import Data.List
-import Text.ParserCombinators.Parsec as Export
-import Text.ParserCombinators.Parsec.Expr as Export
-import Text.ParserCombinators.Parsec.Language as Export
-import Text.ParserCombinators.Parsec.Pos
-
-parseSimple :: Parser a -> String -> Either String a
-parseSimple p = left show . runParser (complete p) () ""
-
-complete :: Parser a -> Parser a
-complete p = spaces *> (p <* eof)
-
-skip :: Parser a -> Parser ()
-skip = void
-
--- Like the combinator from parser, except that for doubles
--- the read instance is used. This is a more precies representation
--- of the double (e.g., 1.413 is not 1.413000000001).
-naturalOrFloat :: Parser (Either Integer Double)
-naturalOrFloat = do
-   a <- num
-   b <- option "" ((:) <$> char '.' <*> nat)
-   c <- option "" ((:) <$> oneOf "eE" <*> num)
-   spaces
-   case reads (a++b++c) of
-      _ | null b && null c ->
-         case a of
-            '-':xs -> return (Left (negate (readInt xs)))
-            xs     -> return (Left (readInt xs))
-      [(d, [])] -> return (Right d)
-      _         -> fail "not a float"
- where
-   nat = many1 digit
-   num = maybe id (:) <$> optionMaybe (char '-') <*> nat
-   readInt = foldl' op 0 -- '
-   op a b  = a*10+fromIntegral (ord b)-48
-
-float :: Parser Double
-float = do
-   a <- nat
-   b <- option "" ((:) <$> char '.' <*> nat)
-   c <- option "" ((:) <$> oneOf "eE" <*> num)
-   case reads (a++b++c) of
-      [(d, [])] -> return d
-      _         -> fail "not a float"
- where
-   nat = many1 digit
-   num = (:) <$> char '-' <*> nat
-
-infix  6 <..>
-
-(<..>) :: Char -> Char -> Parser Char
-x <..> y = satisfy (\c -> c >= x && c <= y)
-
-ranges :: [(Char, Char)] -> Parser Char
-ranges xs = choice [ a <..> b | (a, b) <- xs ]
-
--- return in local function f needed for backwards compatibility
-stopOn :: [String] -> Parser String
-stopOn ys = rec
- where
-   stop = choice (map f ys)
-   f x  = try (string x >> return ' ')
-   rec  =  (:) <$ notFollowedBy stop <*> anyChar <*> rec
-       <|> return []
-
--- simple function for finding unbalanced pairs (e.g. parentheses)
-balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError
-balanced table = run (initialPos "") []
- where
-   run _ [] [] = Nothing
-   run _ ((pos, c):_) [] = return (NotClosed pos c)
-   run pos stack (x:xs)
-      | x `elem` opens  =
-           run next ((pos, x):stack) xs
-      | x `elem` closes =
-           case stack of
-              (_, y):rest | Just x == lookup y table -> run next rest xs
-              _ -> return (NotOpened pos x)
-      | otherwise =
-           run next stack xs
-    where
-      next = updatePosChar pos x
-
-   (opens, closes) = unzip table
-
-data UnbalancedError = NotClosed SourcePos Char
-                     | NotOpened SourcePos Char
-
-instance Show UnbalancedError where
-   show (NotClosed pos c) =
-      show pos ++ ": Opening symbol " ++ [c] ++ " is not closed"
-   show (NotOpened pos c) =
-      show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol"
src/Ideas/Text/UTF8.hs view
@@ -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 2019, 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,6 @@ -- Support for the UTF8 encoding
 --
 -----------------------------------------------------------------------------
---  $Id: UTF8.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.UTF8
    ( encode, encodeM, decode, decodeM
@@ -36,11 +35,11 @@ 
 -- | Encode a string to UTF8 format (monadic)
 encodeM :: Monad m => String -> m String
-encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord)
+encodeM = fmap (map chr . concat) . mapM (toUTF8 . ord)
 
 -- | Decode an UTF8 format string to unicode points (monadic)
 decodeM :: Monad m => String -> m String
-decodeM = liftM (map chr) . fromUTF8 . map ord
+decodeM = fmap (map chr) . fromUTF8 . map ord
 
 -- | Test whether the argument is a proper UTF8 string
 isUTF8 :: String -> Bool
@@ -111,7 +110,7 @@ propEncoding = forAll (sized gen) valid
  where
    gen n = replicateM n someChar
-   someChar = liftM chr $ oneof
+   someChar = chr <$> oneof
       -- To get a nice distribution over the number of bytes used
       -- in the encoding
       [ choose (0, 127), choose (128, 2047)
src/Ideas/Text/XML.hs view
@@ -1,144 +1,388 @@ -----------------------------------------------------------------------------
--- 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 2019, 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 datatype, parser, and pretty printer for XML documents. Re-exports
--- functions defined elsewhere.
+-- Collection of common operation on XML documents
 --
 -----------------------------------------------------------------------------
---  $Id: XML.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.XML
-   ( XML, Attr, AttrList, Element(..), InXML(..)
-   , XMLBuilder, makeXML
-   , parseXML, parseXMLFile, compactXML, findAttribute
-   , children, Attribute(..), fromBuilder, findChild, findChildren, getData
-   , BuildXML(..)
-   , module Data.Monoid, munless, mwhen
+   ( -- * XML types
+     XML, Name, Attributes, Attribute(..)
+     -- * Parsing XML
+   , parseXML, parseXMLFile
+     -- * Building/constructing XML
+   , BuildXML(..), XMLBuilder, makeXML
+     -- * Pretty-printing XML
+   , prettyXML, compactXML
+     -- * Simple decoding queries
+   , name, attributes, findAttribute, children, findChildren, findChild
+   , getData, expecting
+     -- * Decoding XML
+   , decodeData, decodeAttribute, decodeChild, decodeFirstChild
+     -- * Type classes for converting to/from XML
+   , ToXML(..), builderXML, InXML(..)
+     -- * Processing XML
+   , foldXML, trimXML
+     -- * Deprecated functions
+   , content, emptyContent, fromBuilder
    ) where
 
-import Control.Monad
-import Data.Char
+import Control.Monad.State
+import Data.Char (chr, ord, isSpace)
 import Data.Foldable (toList)
-import Data.Monoid
-import Ideas.Text.XML.Interface hiding (parseXML)
+import Data.List
+import Data.Maybe
+import Data.Semigroup as Sem
+import Data.String
+import Ideas.Text.XML.Document (escape, Name, prettyElement)
+import Ideas.Text.XML.Parser (document)
+import Ideas.Text.XML.Unicode
+import Ideas.Utils.Decoding
+import Ideas.Utils.Parsing (parseSimple)
 import System.IO
+import qualified Data.Map as M
 import qualified Data.Sequence as Seq
-import qualified Ideas.Text.XML.Interface as I
+import qualified Ideas.Text.XML.Document as D
 
-----------------------------------------------------------------
--- Datatype definitions
+-------------------------------------------------------------------------------
+-- XML types
 
--- two helper types for attributes
-type XML      = Element
-type Attr     = Attribute  -- (String, String)
-type AttrList = Attributes -- [Attr]
+-- invariants content: no two adjacent Lefts, no Left with empty string,
+-- valid tag/attribute names
+data XML = Tag
+   { name       :: Name
+   , attributes :: Attributes
+   , content    :: [Either String XML]
+   }
+ deriving Eq
 
-class InXML a where
-   toXML       :: a -> XML
-   listToXML   :: [a] -> XML
-   fromXML     :: Monad m => XML -> m a
-   listFromXML :: Monad m => XML -> m [a]
-   -- default definitions
-   listToXML = Element "list" [] . map (Right . toXML)
-   listFromXML xml
-      | name xml == "list" && null (attributes xml) =
-           mapM fromXML (children xml)
-      | otherwise = fail "expecting a list tag"
+instance Show XML where
+   show = compactXML
 
-----------------------------------------------------------------
--- XML parser (a scanner and a XML tree constructor)
+type Attributes = [Attribute]
 
+data Attribute = Name := String
+ deriving Eq
+
+-------------------------------------------------------------------------------
+-- Parsing XML
+
+parseXML :: String -> Either String XML
+parseXML input = do
+   doc   <- parseSimple document input
+   return (fromXMLDoc doc)
+
 parseXMLFile :: FilePath -> IO XML
 parseXMLFile file =
    withBinaryFile file ReadMode $
       hGetContents >=> either fail return . parseXML
 
-parseXML :: String -> Either String XML
-parseXML input = do
-   xml <- I.parseXML input
-   return (ignoreLayout xml)
+fromXMLDoc :: D.XMLDoc -> XML
+fromXMLDoc doc = fromElement (D.root doc)
+ where
+   fromElement (D.Element n as c) =
+      makeXML n (fromAttributes as <> fromContent c)
 
-ignoreLayout :: XML -> XML
-ignoreLayout (Element n as xs) =
-   let f = either (Left . trim) (Right . ignoreLayout)
-   in Element n as (map f xs)
+   fromAttributes = mconcat . map fromAttribute
 
-----------------------------------------------------------------
--- XML builders
+   fromAttribute (n D.:= v) =
+      n .=. concatMap (either return refToString) v
 
-infix 3 .=.
+   fromContent :: D.Content -> XMLBuilder
+   fromContent = mconcat . map f
+    where
+      f :: D.XML -> XMLBuilder
+      f (D.Tagged e)    = builder (fromElement e)
+      f (D.CharData s)  = string s
+      f (D.CDATA s)     = string s
+      f (D.Reference r) = fromReference r
 
-class Monoid a => BuildXML a where
-   (.=.)     :: String -> String -> a   -- attribute
-   unescaped :: String -> a             -- parsed character data (unescaped!)
-   builder   :: Element -> a            -- (named) xml element
-   tag       :: String -> a -> a        -- tag (with content)
+   refToString :: D.Reference -> String
+   refToString (D.CharRef i)   = [chr i]
+   refToString (D.EntityRef s) = maybe "" return (lookup s general)
+
+   fromReference :: D.Reference -> XMLBuilder
+   fromReference (D.CharRef i)   = char (chr i)
+   fromReference (D.EntityRef s) = fromMaybe mempty (lookup s entities)
+
+   entities :: [(String, XMLBuilder)]
+   entities =
+      [ (n, fromContent (snd ext)) | (n, ext) <- D.externals doc ] ++
+      -- predefined entities
+      [ (n, char c) | (n, c) <- general ]
+
+   general :: [(String, Char)]
+   general = [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')]
+
+-------------------------------------------------------------------------------
+-- Building/constructing XML
+
+infix 7 .=.
+
+class (Sem.Semigroup a, Monoid a) => BuildXML a where
+   (.=.)    :: String -> String -> a   -- attribute
+   string   :: String -> a             -- (escaped) text
+   builder  :: XML -> a                -- (named) xml element
+   tag      :: String -> a -> a        -- tag (with content)
    -- functions with a default
-   string   :: String -> a -- escaped text
+   char     :: Char -> a
    text     :: Show s => s -> a -- escaped text with Show class
    element  :: String -> [a] -> a
    emptyTag :: String -> a
    -- implementations
-   string     = unescaped . escape
+   char c     = string [c]
    text       = string . show
    element s  = tag s . mconcat
    emptyTag s = tag s mempty
 
-data XMLBuilder = BS (Seq.Seq Attr) (Seq.Seq (Either String Element))
+instance BuildXML a => BuildXML (Decoder env s a) where
+   n .=. s = pure (n .=. s)
+   string  = pure . string
+   builder = pure . builder
+   tag     = fmap . tag
 
--- local helper
-fromBS :: XMLBuilder -> (AttrList, Content)
-fromBS (BS as elts) = (toList as, toList elts)
+data XMLBuilder = BS (Seq.Seq Attribute) (Seq.Seq (Either String XML))
 
+instance Sem.Semigroup XMLBuilder where
+  BS as1 elts1 <> BS as2 elts2 = BS (as1 <> as2) (elts1 <> elts2)
+
 instance Monoid XMLBuilder where
-   mempty = BS mempty mempty
-   mappend (BS as1 elts1) (BS as2 elts2) =
-      BS (as1 <> as2) (elts1 <> elts2)
+   mempty  = BS mempty mempty
+   mappend = (<>)
 
 instance BuildXML XMLBuilder where
-   n .=. s   = BS (Seq.singleton (n := escapeAttr s)) mempty
-   unescaped = BS mempty . Seq.singleton . Left
-   builder   = BS mempty . Seq.singleton . Right
-   tag s     = builder . uncurry (Element s) . fromBS
+   n .=. s  = nameCheck n $ BS (Seq.singleton (n := s)) mempty
+   string s = BS mempty (if null s then mempty else Seq.singleton (Left s))
+   builder  = BS mempty . Seq.singleton . Right
+   tag n    = builder . uncurry (Tag n) . fromBS . nameCheck n
 
+instance IsString XMLBuilder where
+   fromString = string
+
 makeXML :: String -> XMLBuilder -> XML
-makeXML s = uncurry (Element s) . fromBS
+makeXML s = uncurry (Tag s) . fromBS . nameCheck s
 
-mwhen :: Monoid a => Bool -> a -> a
-mwhen True  a = a
-mwhen False _ = mempty
+nameCheck :: String -> a -> a
+nameCheck s = if isName s then id else fail $ "Invalid name " ++ s
 
-munless :: Monoid a => Bool -> a -> a
-munless = mwhen . not
+isName :: String -> Bool
+isName []     = False
+isName (x:xs) = (isLetter x || x `elem` "_:") && all isNameChar xs
 
-escapeAttr :: String -> String
-escapeAttr = concatMap f
+isNameChar :: Char -> Bool
+isNameChar c = any ($ c) [isLetter, isDigit, isCombiningChar, isExtender, (`elem` ".-_:")]
+
+-- local helper: merge attributes, but preserve order
+fromBS :: XMLBuilder -> (Attributes, [Either String XML])
+fromBS (BS as elts) = (attrList, merge (toList elts))
  where
-   f '<' = "&lt;"
-   f '&' = "&amp;"
-   f '"' = "&quot;"
-   f c   = [c]
+   attrMap = foldr add M.empty as
+   add (k := v) = M.insertWith (\x y -> x ++ " " ++ y) k v
+   attrList = nubBy eqKey (map make (toList as))
+   make (k := _) = k := M.findWithDefault "" k attrMap
+   eqKey (k1 := _) (k2 := _) = k1 == k2
 
-fromBuilder :: XMLBuilder -> Maybe Element
+   merge [] = []
+   merge (Left x:Left y:rest)  = merge (Left (x++y):rest)
+   merge (Left x:rest)  = Left x : merge rest
+   merge (Right y:rest) = Right y : merge rest
+
+-------------------------------------------------------------------------------
+-- Pretty-printing XML
+
+prettyXML :: XML -> String
+prettyXML = show . prettyElement False . toElement
+
+compactXML :: XML -> String
+compactXML = show . prettyElement True . toElement
+
+toElement :: XML -> D.Element
+toElement = foldXML make mkAttribute mkString
+ where
+   make n as = D.Element n as . concatMap (either id (return . D.Tagged))
+
+   mkAttribute :: Attribute -> D.Attribute
+   mkAttribute (m := s) = (D.:=) m (map Left s)
+
+   mkString :: String -> [D.XML]
+   mkString [] = []
+   mkString xs@(hd:tl)
+      | null xs1  = D.Reference (D.CharRef (ord hd)) : mkString tl
+      | otherwise = D.CharData xs1 : mkString xs2
+    where
+      (xs1, xs2) = break ((> 127) . ord) xs
+
+-------------------------------------------------------------------------------
+-- Simple decoding queries
+
+findAttribute :: Monad m => String -> XML -> m String
+findAttribute s (Tag _ as _) =
+   case [ t | n := t <- as, s==n ] of
+      [hd] -> return hd
+      _    -> fail $ "Invalid attribute: " ++ show s
+
+children :: XML -> [XML]
+children e = [ c | Right c <- content e ]
+
+findChildren :: String -> XML -> [XML]
+findChildren s = filter ((==s) . name) . children
+
+findChild :: Monad m => String -> XML -> m XML
+findChild s e =
+   case findChildren s e of
+      []  -> fail $ "Child not found: " ++ show s
+      [a] -> return a
+      _   -> fail $ "Multiple children found: " ++ show s
+
+getData :: XML -> String
+getData e = concat [ s | Left s <- content e ]
+
+expecting :: Monad m => String -> XML -> m ()
+expecting s xml =
+   unless (name xml == s) $ fail $ "Expecting element " ++ s ++ ", but found " ++ name xml
+
+-------------------------------------------------------------------------------
+-- Decoding XML
+
+decodeData :: Decoder env XML String
+decodeData = get >>= \xml ->
+   case content xml of
+      Left s:rest -> put xml {content = rest} >> return s
+      _           -> fail "Could not find data"
+
+decodeAttribute :: String -> Decoder env XML String
+decodeAttribute s = get >>= \xml ->
+   case break hasName (attributes xml) of
+      (xs, (_ := val):ys) -> put xml {attributes = xs ++ ys } >> return val
+      _ -> fail $ "Could not find attribute " ++ s
+ where
+   hasName (n := _) = n == s
+
+decodeChild :: Name -> Decoder env XML a -> Decoder env XML a
+decodeChild s p = get >>= \xml ->
+   case break hasName (content xml) of
+      (xs, Right y:ys) -> do
+         put y
+         a <- p
+         put xml { content = xs ++ ys }
+         return a
+      _ -> fail $ "Could not find child " ++ s
+ where
+   hasName = either (const False) ((==s) . name)
+
+decodeFirstChild :: Name -> Decoder env XML a -> Decoder env XML a
+decodeFirstChild s p = get >>= \xml ->
+   case content xml of
+      Right y:ys | name y == s -> do
+         put y
+         a <- p
+         put xml { content = ys }
+         return a
+      _ -> fail $ "Could not find first child " ++ s
+
+-------------------------------------------------------------------------------
+-- Type classes for converting to/from XML
+
+class ToXML a where
+   toXML     :: a -> XML
+   listToXML :: [a] -> XML
+   -- default definitions
+   listToXML = makeXML "list" . mconcat . map builderXML
+
+instance ToXML () where
+   toXML _ = makeXML "Unit" mempty
+
+instance ToXML a => ToXML (Maybe a) where
+  toXML = maybe (makeXML "Nothing" mempty) toXML
+
+builderXML :: (ToXML a, BuildXML b) => a -> b
+builderXML = builder . toXML
+
+class ToXML a => InXML a where
+   fromXML     :: Monad m => XML -> m a
+   listFromXML :: Monad m => XML -> m [a]
+   listFromXML xml
+      | name xml == "list" && null (attributes xml) =
+           mapM fromXML (children xml)
+      | otherwise = fail "expecting a list tag"
+
+-------------------------------------------------------------------------------
+-- Processing XML
+
+foldXML :: (Name -> [a] -> [Either s e] -> e) -> (Attribute -> a) -> (String -> s) -> XML -> e
+foldXML fe fa fs = rec
+ where
+   rec (Tag n as cs) = fe n (map fa as) (map (either (Left . fs) (Right . rec)) cs)
+
+trimXML :: XML -> XML
+trimXML = foldXML make fa (string . trim)
+ where
+   fa (n := s) = n .=. trim s
+
+   make :: String -> [XMLBuilder] -> [Either XMLBuilder XML] -> XML
+   make s as = makeXML s . mconcat . (as ++) . map (either id builder)
+
+trim, trimLeft, trimRight :: String -> String
+trim      = trimLeft . trimRight
+trimLeft  = dropWhile isSpace
+trimRight = reverse . trimLeft . reverse
+
+-------------------------------------------------------------------------------
+-- Deprecated functions
+
+emptyContent :: XML -> Bool
+emptyContent = null . content
+
+fromBuilder :: XMLBuilder -> Maybe XML
 fromBuilder m =
    case fromBS m of
       ([], [Right a]) -> Just a
       _               -> Nothing
 
-escape :: String -> String
-escape = concatMap f
+-------------------------------------------------------------------------------
+-- Tests
+
+_runTests :: IO ()
+_runTests = do
+   forM_ [testDataP, testAttrP, testDataB, testAttrB] $ \f ->
+      pp $ map f tests
+   forM_ [mkPD, mkPA, mkBD, mkBA] $ \f ->
+      pp $ map (testXML . f) tests
  where
-   f '<' = "&lt;"
-   f '>' = "&gt;"
-   f '&' = "&amp;"
-   f c   = [c]
+   pp = putStrLn . map (\b -> if b then '.' else 'X')
 
-trim :: String -> String
-trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse+   tests :: [String]
+   tests =
+      [ "input"
+      , "&lt;&gt;&amp;&quot;&apos;"
+      , "<>&'\""
+      , "p & q' => p"
+      , ""
+      , "   "
+      , "eerste \n\n derde regel"
+      ]
+
+   testDataP, testAttrP, testDataB, testAttrB :: String -> Bool
+   testDataP s = let xml = mkPD s in getData xml == s
+   testAttrP s = let xml = mkPA s in findAttribute "a" xml == Just s
+   testDataB s = let xml = mkBD s in getData xml == s
+   testAttrB s = let xml = mkBA s in findAttribute "a" xml == Just s
+
+   testXML :: XML -> Bool
+   testXML xml =
+      case parseXML (compactXML xml) of
+         Left msg -> error msg
+         Right a  -> a == xml
+
+   mkPD, mkPA, mkBD, mkBA :: String -> XML
+   mkPD s = either error id $ parseXML $ "<a>" ++ escape s ++ "</a>"
+   mkPA s = either error id $ parseXML $ "<t a='" ++ escape s ++ "'/>"
+   mkBD s = makeXML "a" (string s)
+   mkBA s = makeXML "t" ("a".=. s)
src/Ideas/Text/XML/Document.hs view
@@ -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 2019, 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,6 @@ -- Datatype for representing XML documents
 --
 -----------------------------------------------------------------------------
---  $Id: Document.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.XML.Document
    ( Name, Attributes, Attribute(..), Reference(..), Parameter(..)
@@ -19,9 +18,11 @@    , ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef
    , EntityDef, AttValue, EntityValue, ExternalID(..), PublicID
    , Conditional(..), TextDecl, External
-   , prettyXML, prettyElement
+   , prettyXML, prettyElement, escape
    ) where
 
+import Prelude hiding ((<$>))
+
 import Text.PrettyPrint.Leijen
 
 type Name = String
@@ -31,7 +32,7 @@ 
 data Reference = CharRef Int | EntityRef String
 
-data Parameter = Parameter String
+newtype Parameter = Parameter String
 
 data XMLDoc = XMLDoc
    { versionInfo :: Maybe String
@@ -123,11 +124,14 @@ prettyXML compact xml =
    case xml of
       Tagged e    -> prettyElement compact e
-      CharData s  -> text s
+      CharData s  -> text (escape s)
       CDATA s     -> text "<![CDATA[" <> text s <> text "]]>"
       Reference r -> pretty r
 
 prettyElement :: Bool -> Element -> Doc
+prettyElement _ (Element n@"script" as [CharData s]) =
+   -- quick fix for not escaping javascript code in html
+   openTag n as <> text s <> closeTag n
 prettyElement compact (Element n as c)
    | null c    = openCloseTag n as
    | compact   = make (<>)
@@ -137,95 +141,6 @@                  ibody = (if compact then id else indent 2) body
              in openTag n as `op` ibody `op` closeTag n
 
-{-
-instance Show XMLDoc where
-   show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc)
-
-instance Show DTD where
-   show (DTD n mid ds) = "<!DOCTYPE " ++ unwords list ++ ">"
-    where
-      list = n : catMaybes [fmap show mid, showDecls ds]
-      showDecls xs
-         | null xs   = Nothing
-         | otherwise = Just $ "[" ++ concatMap show xs ++ "]"
-
-instance Show ExternalID where
-   show extID =
-      case extID of
-         System s   -> "SYSTEM " ++ doubleQuote s
-         Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s]
-
-instance Show DocTypeDecl where
-   show decl =
-      case decl of
-         ElementDecl n c  -> "<!ELEMENT " ++ n ++ " " ++ show c ++ ">"
-         AttListDecl n as -> "<!ATTLIST " ++ unwords (n:map showAttDef as) ++ ">"
-         EntityDecl b n e ->
-            let xs = ["%" | not b] ++ [n, showEntityDef e]
-            in "<!ENTITY " ++ unwords xs ++ ">"
-         NotationDecl n e ->
-            let f s = "PUBLIC " ++ doubleQuote s
-            in "<!NOTATION " ++ n ++ " " ++ either show f e ++ ">"
-         DTDParameter r   -> show r
-         DTDConditional c -> show c
-
-instance Show ContentSpec where
-   show cspec =
-      case cspec of
-         Empty -> "EMPTY"
-         Any   -> "ANY"
-         Mixed b ns ->
-            let txt = intercalate "|" ("#PCDATA":ns)
-            in parenthesize txt ++ (if b then "*" else "")
-         Children cp -> show cp
-
-instance Show CP where
-   show cp =
-      case cp of
-         Choice xs      -> parenthesize (intercalate "|" (map show xs))
-         Sequence xs    -> parenthesize (intercalate "," (map show xs))
-         QuestionMark c -> show c ++ "?"
-         Star c         -> show c ++ "*"
-         Plus c         -> show c ++ "+"
-         CPName n       -> n
-
-instance Show AttType where
-   show attType =
-      case attType of
-         IdType       -> "ID"
-         IdRefType    -> "IDREF"
-         IdRefsType   -> "IDREFS"
-         EntityType   -> "ENTITY"
-         EntitiesType -> "ENTITIES"
-         NmTokenType  -> "NMTOKEN"
-         NmTokensType -> "NMTOKENS"
-         StringType   -> "CDATA"
-         EnumerationType xs -> parenthesize (intercalate "|" xs)
-         NotationType xs    -> "NOTATION " ++ parenthesize (intercalate "|" xs)
-
-instance Show DefaultDecl where
-   show defaultDecl =
-      case defaultDecl of
-         Required -> "#REQUIRED"
-         Implied  -> "#IMPLIED"
-         Value v  -> showAttValue v
-         Fixed v  -> "#FIXED " ++ showAttValue v
-
-instance Show Conditional where
-   show conditional =
-      case conditional of
-         Include xs -> "<![INCLUDE[" ++ concatMap show xs ++ "]]>"
-         Ignore _ -> "" -- ToDO undefined -- [String]
-
-showXMLDecl :: XMLDoc -> String
-showXMLDecl doc
-   | isJust (versionInfo doc) = "<?xml " ++ unwords (catMaybes [s1,s2,s3]) ++ "?>"
-   | otherwise = ""
- where
-   s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc)
-   s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc)
-   s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc)
--}
 openTag :: Name -> Attributes -> Doc
 openTag = prettyTag (char '<') (char '>')
 
@@ -238,26 +153,18 @@ prettyTag :: Doc -> Doc -> Name -> Attributes -> Doc
 prettyTag open close n as = open <> hsep (text n:map pretty as) <> close
 
-prettyAttValue :: AttValue -> Doc -- TODO: no double quotes allowed (should be escaped)
-prettyAttValue = dquotes . hcat . map (either f pretty)
- where
-   f '"' = empty
-   f c   = char c
-{-
-showEntityValue :: EntityValue -> String
-showEntityValue = doubleQuote . concatMap (either f (either show show))
- where
-   f '"' = []
-   f c   = [c]
-
-showAttDef :: AttDef -> String
-showAttDef (s, tp, dd) = unwords [s, show tp, show dd]
+prettyAttValue :: AttValue -> Doc
+prettyAttValue = dquotes . hcat . map (either (text . escapeChar) pretty)
 
-showEntityDef :: EntityDef -> String
-showEntityDef entityDef =
-   case entityDef of
-      Left ev -> showEntityValue ev
-      Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms
+escape :: String -> String
+escape = concatMap escapeChar
 
-parenthesize :: String -> String
-parenthesize s = "(" ++ s ++ ")" -}+escapeChar :: Char -> String
+escapeChar c =
+   case c of
+      '<'  -> "&lt;"
+      '>'  -> "&gt;"
+      '&'  -> "&amp;"
+      '"'  -> "&quot;"
+      '\'' -> "&apos;"
+      _    -> [c]
− src/Ideas/Text/XML/Interface.hs 
@@ -1,138 +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)
---
--- Collection of common operation on XML documents
---
------------------------------------------------------------------------------
---  $Id: Interface.hs 7524 2015-04-08 07:31:15Z bastiaan $
-
-module Ideas.Text.XML.Interface
-   ( Element(..), Content, Attribute(..), Attributes
-   , normalize, parseXML, compactXML
-   , children, findAttribute, findChildren, findChild, getData
-   ) where
-
-import Control.Arrow
-import Data.Char (chr, ord)
-import Data.Maybe
-import Ideas.Text.Parsing (parseSimple)
-import Ideas.Text.XML.Document (Name, prettyElement)
-import Ideas.Text.XML.Parser (document)
-import Ideas.Text.XML.Unicode (decoding)
-import qualified Ideas.Text.XML.Document as D
-
-data Element = Element
-   { name       :: Name
-   , attributes :: Attributes
-   , content    :: Content
-   }
-
-instance Show Element where
-   show = show . extend
-
-compactXML :: Element -> String
-compactXML = show . prettyElement True . extend
-
-type Content = [Either String Element]
-
-type Attributes = [Attribute]
-data Attribute = Name := String
-
-normalize :: D.XMLDoc -> Element
-normalize doc = toElement (D.root doc)
- where
-   toElement :: D.Element -> Element
-   toElement (D.Element n as c) =
-      Element n (map toAttribute as) (toContent c)
-
-   toAttribute :: D.Attribute -> Attribute
-   toAttribute (n D.:= v) =
-      n := concatMap (either return refToString) v
-
-   toContent :: D.Content -> Content
-   toContent = merge . concatMap f
-    where
-      f :: D.XML -> Content
-      f (D.Tagged e)    = [Right (toElement e)]
-      f (D.CharData s)  = [Left s]
-      f (D.CDATA s)     = [Left s]
-      f (D.Reference r) = refToContent r
-
-   refToString :: D.Reference -> String
-   refToString (D.CharRef i)   = [chr i]
-   refToString (D.EntityRef s) = maybe "" return (lookup s general)
-
-   refToContent :: D.Reference -> Content
-   refToContent (D.CharRef i)   = [Left [chr i]]
-   refToContent (D.EntityRef s) = fromMaybe [] (lookup s entities)
-
-   entities :: [(String, Content)]
-   entities =
-      [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] ++
-      -- predefined entities
-      map (second (return . Left . return)) general
-
-   general :: [(String, Char)]
-   general = [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')]
-
-   merge :: Content -> Content
-   merge (Left s:Left t:rest) = merge (Left (s++t) : rest)
-   merge (x:xs) = x:merge xs
-   merge []     = []
-
-extend :: Element -> D.Element
-extend (Element n as c) =
-   D.Element n (map toAttribute as) (concatMap toXML c)
- where
-   toAttribute :: Attribute -> D.Attribute
-   toAttribute (m := s) = (D.:=) m (map Left s)
-
-   toXML :: Either String Element -> [D.XML]
-   toXML = either fromString (return . D.Tagged . extend)
-
-   fromString :: String -> [D.XML]
-   fromString [] = []
-   fromString xs@(hd:tl)
-      | null xs1  = D.Reference (D.CharRef (ord hd)) : fromString tl
-      | otherwise = D.CharData xs1 : fromString xs2
-    where
-      (xs1, xs2) = break ((> 127) . ord) xs
-
------------------------------------------------------
-
-parseXML :: String -> Either String Element
-parseXML xs = do
-   input <- decoding xs
-   doc   <- parseSimple document input
-   return (normalize doc)
-
------------------------------------------------------
-
-findAttribute :: Monad m => String -> Element -> m String
-findAttribute s (Element _ as _) =
-   case [ t | n := t <- as, s==n ] of
-      [hd] -> return hd
-      _    -> fail $ "Invalid attribute: " ++ show s
-
-findChildren :: String -> Element -> [Element]
-findChildren s = filter ((==s) . name) . children
-
-findChild :: Monad m => String -> Element -> m Element
-findChild s e =
-   case findChildren s e of
-      []  -> fail $ "Child not found: " ++ show s
-      [a] -> return a
-      _   -> fail $ "Multiple children found: " ++ show s
-
-children :: Element -> [Element]
-children e = [ c | Right c <- content e ]
-
-getData :: Element -> String
-getData e = concat [ s | Left s <- content e ]
src/Ideas/Text/XML/Parser.hs view
@@ -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 2019, 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,17 +13,16 @@ --    http://www.w3.org/TR/2006/REC-xml-20060816
 --
 -----------------------------------------------------------------------------
---  $Id: Parser.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.XML.Parser (document, extParsedEnt, extSubset) where
 
 import Control.Monad
-import Data.Char (toUpper, ord, isSpace)
-import Data.List (foldl') -- '
+import Data.Char (toUpper, ord)
+import Data.List (foldl')
 import Data.Maybe (catMaybes)
-import Ideas.Text.Parsing hiding (digit, letter, space)
 import Ideas.Text.XML.Document hiding (versionInfo, name, content)
 import Ideas.Text.XML.Unicode
+import Ideas.Utils.Parsing hiding (digit, letter, space)
 import Prelude hiding (seq)
 import qualified Ideas.Text.XML.Document as D
 
@@ -132,7 +131,9 @@ -- [11]   	SystemLiteral	   ::=   	('"' [^"]* '"') | ("'" [^']* "'")
 systemLiteral :: Parser String
 systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'")
- where p s = many (noneOf s)
+ where
+   p :: String -> Parser String
+   p s = many (noneOf s)
 
 -- [12]   	PubidLiteral	   ::=   	'"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
 pubidLiteral :: Parser String
@@ -349,7 +350,7 @@ content = chainr1 (fmap g charData) (fmap f ps)
  where
    f ma l r = l ++ maybe [] return ma ++ r
-   g s = [ CharData s | any (not . isSpace) s ]  -- quick fix, ignores layout
+   g s = [ CharData s | not (null s) ]
    ps  = try (fmap Just (choice (map try [fmap Tagged element, fmap Reference reference, cdSect]))
       <|> ((try pInstr <|> comment) >> return Nothing))
src/Ideas/Text/XML/Unicode.hs view
@@ -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 2019, 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,6 @@ -- Support for Unicode
 --
 -----------------------------------------------------------------------------
---  $Id: Unicode.hs 7524 2015-04-08 07:31:15Z bastiaan $
 
 module Ideas.Text.XML.Unicode
    ( isExtender, isLetter, isDigit, isCombiningChar
+ src/Ideas/Utils/BlackBoxTests.hs view
@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.BlackBoxTests (blackBoxTests, TestRunner) where
+
+import Control.Monad
+import Data.Char
+import Data.List
+import Ideas.Utils.TestSuite
+import System.Directory
+import System.IO
+import qualified Data.Algorithm.Diff as Diff
+
+type TestRunner = String -> IO String
+
+-- Returns the number of tests performed
+blackBoxTests :: TestRunner -> [String] -> String -> IO TestSuite
+blackBoxTests runner exts = rec
+ where
+    rec path = do
+      -- analyse content
+      xs0 <- getDirectoryContents path
+      let (files, xs1) = partition (`elemExts` exts) xs0
+          xs2          = map (path </>) (filter ((/= ".") . take 1) xs1)
+      -- recursively visit subdirectories
+      subs <- filterM doesDirectoryExist xs2
+      rest <- mapM rec subs
+      return $ suite ("Directory " ++ simplerDirectory path) $
+         [ doBlackBoxTest runner (path </> x)
+         | x <- files
+         ] ++ rest
+
+doBlackBoxTest :: TestRunner -> FilePath -> TestSuite
+doBlackBoxTest runner path =
+   assertMessageIO (stripDirectoryPart path) $
+      -- Comparing output with expected output
+      withFile path ReadMode $ \h1 -> do
+         hSetBinaryMode h1 True
+         txt <- hGetContents h1
+         out <- runner txt
+         withFile expPath ReadMode $ \h2 -> do
+            hSetBinaryMode h2 True
+            expt <- hGetContents h2
+            -- Force evaluation of the result, to make sure that
+            -- all file handles are closed afterwards.
+            let list1 = prepare expt
+                list2 = prepare out
+                msg   = unlines (path : diffs list1 list2)
+            if list1 == list2 then return mempty else do
+               force msg -- force evaluation of message before closing files
+               return (message msg)
+ where
+   expPath = baseOf path ++ ".exp"
+   baseOf  = reverse . drop 1 . dropWhile (/= '.') . reverse
+
+elemExts :: FilePath -> [String] -> Bool
+elemExts s = any (\xs -> ('.':xs)  `isSuffixOf` s)
+
+force :: String -> IO ()
+force s | sum (map ord s) >= 0 = return ()
+        | otherwise = error "force"
+
+prepare :: String -> [String]
+prepare = filter (not . null) . lines . filter (/= '\r') . noVersion
+ where
+   noVersion s | "version\": \"" `isPrefixOf` s =
+      "version\": \"X" ++ dropWhile (/='"') (drop 11 s)
+   noVersion s | "version=\"" `isPrefixOf` s =
+      "version=\"X" ++ dropWhile (/='"') (drop 9 s)
+   noVersion (x:xs) = x:noVersion xs
+   noVersion [] = []
+
+diffs :: [String] -> [String] -> [String]
+diffs xs ys = concatMap f $ Diff.getDiff xs ys
+ where
+   f (Diff.First a)  = ["- " ++ a]
+   f (Diff.Second a) = ["+ " ++ a]
+   f _ = []
+
+simplerDirectory :: String -> String
+simplerDirectory s
+   | "../"   `isPrefixOf` s = simplerDirectory (drop 3 s)
+   | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s)
+   | otherwise = s
+
+stripDirectoryPart :: String -> String
+stripDirectoryPart = reverse . takeWhile (/= '/') . reverse
+
+(</>) :: FilePath -> FilePath -> FilePath
+x </> y = x ++ "/" ++ y
+
+{-
+logicConfluence :: IO ()
+logicConfluence = reportTest "logic rules" (isConfluent f rs)
+ where
+   f    = normalizeWith ops . normalFormWith ops rs
+   ops  = map makeCommutative Logic.logicOperators
+   rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd]
+   rs   = [ r | RewriteRule r <- concatMap transformations rwrs ]
+   -- eqs  = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ]
+-}
+ src/Ideas/Utils/Decoding.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Extensions to the QuickCheck library
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.Decoding
+   ( Decoder, runDecoder, symbol
+   , Encoder, runEncoder
+   , Error, runError, runErrorM
+   ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Semigroup as Sem
+
+-------------------------------------------------------------------
+
+newtype Decoder env s a = Dec { runDec :: StateT s (ReaderT env Error) a }
+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadReader env, MonadState s)
+
+instance Sem.Semigroup a => Sem.Semigroup (Decoder env s a) where
+   (<>) = liftA2 (<>)
+
+instance Monoid a => Monoid (Decoder env s a) where
+   mempty  = pure mempty
+   mappend = liftA2 mappend
+
+symbol :: Decoder env [s] s
+symbol = get >>= \list ->
+   case list of
+      []   -> fail "Empty input"
+      x:xs ->
+         put xs >> return x
+
+runDecoder :: Monad m => Decoder env s a -> env -> s -> m a
+runDecoder p env s = runErrorM (runReaderT (evalStateT (runDec p) s) env)
+
+-------------------------------------------------------------------
+
+type Encoder env = Decoder env ()
+
+runEncoder :: Monad m => Encoder env a -> env -> m a
+runEncoder p env = runDecoder p env ()
+
+-------------------------------------------------------------------
+-- Error monad (helper)
+
+newtype Error a = Error { runError :: Either String a }
+
+instance Functor Error where
+   fmap f = Error . fmap f . runError
+
+instance Applicative Error where
+   pure    = Error . Right
+   p <*> q = Error $
+      case (runError p, runError q) of
+         (Left s, _)  -> Left s
+         (_, Left s)  -> Left s
+         (Right f, Right x) -> Right (f x)
+
+instance Alternative Error where
+   empty   = Error (Left "empty")
+   p <|> q = Error $
+      case (runError p, runError q) of
+         (Right a, _) -> Right a
+         (_, Right a) -> Right a
+         (Left s, _)  -> Left s
+
+instance Monad Error where
+   fail    = Error . Left
+   return  = pure
+   m >>= f = Error $ either Left (runError . f) (runError m)
+
+instance MonadPlus Error where
+   mzero = fail "mzero"
+   mplus = (<|>)
+
+runErrorM :: Monad m => Error a -> m a
+runErrorM = either fail return . runError
+ src/Ideas/Utils/Parsing.hs view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Utility functions for parsing with Parsec library
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.Parsing
+   ( module Export
+   , (<*>), (*>), (<*), (<$>), (<$), (<**>)
+   , parseSimple, complete, skip, (<..>), ranges, stopOn
+   , naturalOrFloat, float
+   , UnbalancedError(..), balanced
+   ) where
+
+import Control.Applicative hiding ((<|>))
+import Control.Arrow
+import Control.Monad
+import Data.Char
+import Data.List
+import Text.ParserCombinators.Parsec as Export
+import Text.ParserCombinators.Parsec.Expr as Export
+import Text.ParserCombinators.Parsec.Language as Export
+import Text.ParserCombinators.Parsec.Pos
+
+parseSimple :: Parser a -> String -> Either String a
+parseSimple p = left show . runParser (complete p) () ""
+
+complete :: Parser a -> Parser a
+complete p = spaces *> (p <* eof)
+
+skip :: Parser a -> Parser ()
+skip = void
+
+-- Like the combinator from parser, except that for doubles
+-- the read instance is used. This is a more precies representation
+-- of the double (e.g., 1.413 is not 1.413000000001).
+naturalOrFloat :: Parser (Either Integer Double)
+naturalOrFloat = do
+   a <- num
+   b <- option "" ((:) <$> char '.' <*> nat)
+   c <- option "" ((:) <$> oneOf "eE" <*> num)
+   spaces
+   case reads (a++b++c) of
+      _ | null b && null c ->
+         case a of
+            '-':xs -> return (Left (negate (readInt xs)))
+            xs     -> return (Left (readInt xs))
+      [(d, [])] -> return (Right d)
+      _         -> fail "not a float"
+ where
+   nat = many1 digit
+   num = maybe id (:) <$> optionMaybe (char '-') <*> nat
+   readInt = foldl' op 0 -- '
+   op a b  = a*10+fromIntegral (ord b)-48
+
+float :: Parser Double
+float = do
+   a <- nat
+   b <- option "" ((:) <$> char '.' <*> nat)
+   c <- option "" ((:) <$> oneOf "eE" <*> num)
+   case reads (a++b++c) of
+      [(d, [])] -> return d
+      _         -> fail "not a float"
+ where
+   nat = many1 digit
+   num = (:) <$> char '-' <*> nat
+
+infix  6 <..>
+
+(<..>) :: Char -> Char -> Parser Char
+x <..> y = satisfy (\c -> c >= x && c <= y)
+
+ranges :: [(Char, Char)] -> Parser Char
+ranges xs = choice [ a <..> b | (a, b) <- xs ]
+
+-- return in local function f needed for backwards compatibility
+stopOn :: [String] -> Parser String
+stopOn ys = rec
+ where
+   stop = choice (map f ys)
+   f x  = try (string x >> return ' ')
+   rec  =  (:) <$ notFollowedBy stop <*> anyChar <*> rec
+       <|> return []
+
+-- simple function for finding unbalanced pairs (e.g. parentheses)
+balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError
+balanced table = run (initialPos "") []
+ where
+   run _ [] [] = Nothing
+   run _ ((pos, c):_) [] = return (NotClosed pos c)
+   run pos stack (x:xs)
+      | x `elem` opens  =
+           run next ((pos, x):stack) xs
+      | x `elem` closes =
+           case stack of
+              (_, y):rest | Just x == lookup y table -> run next rest xs
+              _ -> return (NotOpened pos x)
+      | otherwise =
+           run next stack xs
+    where
+      next = updatePosChar pos x
+
+   (opens, closes) = unzip table
+
+data UnbalancedError = NotClosed SourcePos Char
+                     | NotOpened SourcePos Char
+
+instance Show UnbalancedError where
+   show (NotClosed pos c) =
+      show pos ++ ": Opening symbol " ++ [c] ++ " is not closed"
+   show (NotOpened pos c) =
+      show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol"
+ src/Ideas/Utils/Prelude.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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 collection of general utility functions
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.Prelude
+   ( Some(..), ShowString(..), readInt, readM
+   , subsets, isSubsetOf
+   , cartesian, distinct, allsame
+   , fixpoint
+   , splitAtElem, splitsWithElem
+   , timedSeconds, getDiffTime
+   , fst3, snd3, thd3
+   , headM, findIndexM
+   , elementAt, changeAt, replaceAt
+   , list
+   , mwhen, munless
+   ) where
+
+import Data.Char
+import Data.List
+import Data.Time
+import System.Timeout
+
+data Some f = forall a . Some (f a)
+
+newtype ShowString = ShowString { fromShowString :: String }
+   deriving (Eq, Ord)
+
+instance Show ShowString where
+   show = fromShowString
+
+instance Read ShowString where
+   readsPrec n s = [ (ShowString x, y) | (x, y) <- readsPrec n s ]
+
+readInt :: String -> Maybe Int
+readInt xs
+   | null xs                = Nothing
+   | any (not . isDigit) xs = Nothing
+   | otherwise              = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- '
+
+readM :: (Monad m, Read a) => String -> m a
+readM s = case reads s of
+             [(a, xs)] | all isSpace xs -> return a
+             _ -> fail ("no read: " ++ s)
+
+subsets :: [a] -> [[a]]
+subsets = foldr op [[]]
+ where op a xs = xs ++ map (a:) xs
+
+isSubsetOf :: Eq a => [a] -> [a] -> Bool
+isSubsetOf xs ys = all (`elem` ys) xs
+
+cartesian :: [a] -> [b] -> [(a, b)]
+cartesian as bs = [ (a, b) | a <- as, b <- bs ]
+
+distinct :: Eq a => [a] -> Bool
+distinct []     = True
+distinct (x:xs) = notElem x xs && distinct xs
+
+allsame :: Eq a => [a] -> Bool
+allsame []     = True
+allsame (x:xs) = all (==x) xs
+
+fixpoint :: Eq a => (a -> a) -> a -> a
+fixpoint f = rec . iterate f
+ where
+   rec [] = error "Ideas.Common.Utils: empty list"
+   rec (x:xs)
+      | x == head xs = x
+      | otherwise    = rec xs
+
+splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a])
+splitAtElem c s =
+   case break (==c) s of
+      (xs, _:ys) -> Just (xs, ys)
+      _          -> Nothing
+
+splitsWithElem :: Eq a => a -> [a] -> [[a]]
+splitsWithElem c s =
+   case splitAtElem c s of
+      Just (xs, ys) -> xs : splitsWithElem c ys
+      Nothing       -> [s]
+
+timedSeconds :: Int -> IO a -> IO a
+timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>=
+   maybe (fail ("Timeout after " ++ show n ++ " seconds")) return
+
+getDiffTime :: IO a -> IO (a, NominalDiffTime)
+getDiffTime action = do
+   t0 <- getCurrentTime
+   a  <- action
+   t1 <- getCurrentTime
+   return (a, diffUTCTime t1 t0)
+
+fst3 :: (a, b, c) -> a
+fst3 (x, _, _) = x
+
+snd3 :: (a, b, c) -> b
+snd3 (_, x, _) = x
+
+thd3 :: (a, b, c) -> c
+thd3 (_, _, x) = x
+
+-- generalized list functions (results in monad)
+headM :: Monad m => [a] -> m a
+headM (a:_) = return a
+headM _     = fail "headM"
+
+findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int
+findIndexM p = maybe (fail "findIndexM") return . findIndex p
+
+elementAt :: Monad m => Int -> [a] -> m a
+elementAt i = headM . drop i
+
+changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a]
+changeAt i f as =
+   case splitAt i as of
+      (xs, y:ys) -> return (xs ++ f y : ys)
+      _          -> fail "changeAt"
+
+replaceAt :: Monad m => Int -> a -> [a] -> m [a]
+replaceAt i = changeAt i . const
+
+list :: b -> ([a] -> b) -> [a] -> b
+list b f xs = if null xs then b else f xs
+
+-- Monoids
+
+mwhen :: Monoid a => Bool -> a -> a
+mwhen True  a = a
+mwhen False _ = mempty
+
+munless :: Monoid a => Bool -> a -> a
+munless = mwhen . not
+ src/Ideas/Utils/QuickCheck.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Extensions to the QuickCheck library
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.QuickCheck
+   ( module Test.QuickCheck
+     -- * Data type
+   , ArbGen, generator, generators
+     -- * Constructors
+   , arbGen, constGen, constGens, unaryGen, unaryGens
+   , unaryArbGen, binaryGen, binaryGens, toArbGen
+     -- * Frequency combinators
+   , common, uncommon, rare, changeFrequency
+   ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Ratio
+import Data.Semigroup as Sem
+import Test.QuickCheck
+
+---------------------------------------------------------
+-- @ArbGen@ datatype
+
+newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))]
+
+instance Sem.Semigroup (ArbGen a) where
+   AG xs <> AG ys = AG (xs <> ys)
+
+instance Monoid (ArbGen a) where
+   mempty  = AG mempty
+   mappend = (<>)
+
+generator :: ArbGen a -> Gen a
+generator (AG pairs) = sized rec
+ where
+   factor = foldr (lcm . denominator . fst) 1 pairs
+   rec n  = frequency (map make (select pairs))
+    where
+      select
+         | n == 0    = filter ((==0) . fst . snd)
+         | otherwise = id
+      make (r, (a, gf)) =
+         let m  = round (fromInteger factor*r)
+             xs = replicateM a $ rec $ n `div` 2
+         in (m, gf <*> xs)
+
+generators :: [ArbGen a] -> Gen a
+generators = generator . mconcat
+
+---------------------------------------------------------
+-- Constructors
+
+arbGen :: Arbitrary b => (b -> a) -> ArbGen a
+arbGen f = newGen 0 (const . f <$> arbitrary)
+
+constGen :: a -> ArbGen a
+constGen = pureGen 0 . const
+
+constGens :: [a] -> ArbGen a
+constGens = mconcat . map constGen
+
+unaryGen :: (a -> a) -> ArbGen a
+unaryGen f = pureGen 1 (f . head)
+
+unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a
+unaryArbGen f = newGen 1 $ (\a -> f a . head) <$> arbitrary
+
+unaryGens :: [a -> a] -> ArbGen a
+unaryGens = mconcat . map unaryGen
+
+binaryGen :: (a -> a -> a) -> ArbGen a
+binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1))
+
+binaryGens :: [a -> a -> a] -> ArbGen a
+binaryGens = mconcat . map binaryGen
+
+pureGen :: Int -> ([a] -> a) -> ArbGen a
+pureGen n = newGen n . return
+
+toArbGen :: Gen a -> ArbGen a
+toArbGen = newGen 0 . fmap const
+
+newGen :: Int -> Gen ([a] -> a) -> ArbGen a
+newGen n f = AG [(1, (n, f))]
+
+---------------------------------------------------------
+-- Frequency combinators
+
+common, uncommon, rare :: ArbGen a -> ArbGen a
+common   = changeFrequency 2
+uncommon = changeFrequency (1/2)
+rare     = changeFrequency (1/5)
+
+changeFrequency :: Rational -> ArbGen a -> ArbGen a
+changeFrequency r (AG xs) = AG (map (first (*r)) xs)
+ src/Ideas/Utils/StringRef.hs view
@@ -0,0 +1,134 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- References to Strings, proving a fast comparison implementation (Eq and
+-- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy
+-- Virutal Machine (LVM) identifiers.
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.StringRef
+   ( StringRef, stringRef, toString, tableStatus
+   ) where
+
+import Data.Bits
+import Data.IORef
+import Data.List
+import System.IO.Unsafe
+import qualified Data.IntMap as IM
+
+----------------------------------------------------------------
+-- StringRef datatype and instance declarations
+
+data StringRef = S !Int
+   deriving (Eq, Ord)
+
+----------------------------------------------------------------
+-- Hash table
+
+type HashTable = IM.IntMap [String]
+
+{-# NOINLINE tableRef #-}
+tableRef :: IORef HashTable
+tableRef = unsafePerformIO (newIORef IM.empty)
+
+----------------------------------------------------------------
+-- Conversion to and from strings
+
+stringRef :: String -> StringRef
+stringRef s = unsafePerformIO $ do
+   let hash = hashString s
+   m <- readIORef tableRef
+   case IM.insertLookupWithKey (const combine) hash [s] m of
+      (Nothing, new) -> do
+         writeIORef tableRef new
+         return (S (encodeIndexZero hash))
+      (Just old, new) ->
+         case elemIndex s old of
+            Just index ->
+               return (S (encode hash index))
+            Nothing -> do
+               let index = length old
+               writeIORef tableRef new
+               return (S (encode hash index))
+
+toString :: StringRef -> String
+toString (S i) = unsafePerformIO $ do
+   m <- readIORef tableRef
+   case IM.lookup (extractHash i) m of
+      Just xs -> return (atIndex (extractIndex i) xs)
+      Nothing -> intErr "id not found"
+
+----------------------------------------------------------------
+-- Bit encoding
+
+encode :: Int -> Int -> Int
+encode hash index = hash + index `shiftL` 12
+
+encodeIndexZero :: Int -> Int
+encodeIndexZero hash = hash
+
+extractHash :: Int -> Int
+extractHash i = i `mod` 4096
+
+extractIndex :: Int -> Int
+extractIndex i = i `shiftR` 12
+
+----------------------------------------------------------------
+-- Hash function
+
+-- simple hash function that performs quite good in practice
+hashString :: String -> Int
+hashString s = (f s `mod` prime) `mod` maxHash
+ where
+   f        = foldl' next 0   -- ' strict fold
+   next n c = n*65599 + fromEnum c
+   prime    = 32537 --65599   -- require: prime < maxHash
+
+maxHash :: Int
+maxHash = 0xFFF -- 12 bits
+
+----------------------------------------------------------------
+-- Utility functions
+
+atIndex :: Int -> [a] -> a
+atIndex 0 (x:_)  = x
+atIndex i (_:xs) = atIndex (i-1) xs
+atIndex _ _      = intErr "corrupt symbol table"
+
+combine :: Eq a => [a] -> [a] -> [a]
+combine [a] = rec
+ where
+   rec [] = [a]
+   rec this@(x:xs)
+      | a == x    = this
+      | otherwise = x:rec xs
+combine _ = intErr "combine"
+
+intErr :: String -> a
+intErr s = error ("Internal error in Ideas.Common.StringRef: " ++ s)
+
+----------------------------------------------------------------
+-- Testing and debugging
+
+tableStatus :: IO String
+tableStatus = readIORef tableRef >>= \m ->
+   let xs = map f (IM.assocs m)
+       f (i, ys) = '#' : show i ++ ": " ++ intercalate ", " (map g (frequency ys)) ++
+                   "  [total = " ++ show (length ys) ++ "]"
+       g (a, n)  | n == 1    = show a
+                 | otherwise = show a ++ " (" ++ show n ++ ")"
+   in return $ unlines xs
+
+frequency :: Eq a => [a] -> [(a, Int)]
+frequency [] = []
+frequency (x:xs) =
+   let (ys, zs) = partition (==x) xs
+   in (x, 1+length ys) : frequency zs
+ src/Ideas/Utils/TestSuite.hs view
@@ -0,0 +1,429 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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 lightweight wrapper for organizing tests (including QuickCheck tests). It
+-- introduces the notion of a test suite, and it stores the test results for
+-- later inspection (e.g., for the generation of a test report). A TestSuite
+-- is a monoid.
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.TestSuite
+   ( -- * TestSuite
+     TestSuite
+   , suite, useProperty, usePropertyWith
+   , assertTrue, assertNull, assertEquals, assertIO
+   , assertMessage, assertMessageIO
+   , onlyWarnings, rateOnError
+     -- * Running a test suite
+   , runTestSuite, runTestSuiteResult
+     -- * Test Suite Result
+   , Result, subResults, findSubResult
+   , justOneSuite, allMessages, topMessages
+   , nrOfTests, nrOfErrors, nrOfWarnings
+   , timeInterval, makeSummary, printSummary
+     -- * Message
+   , Message, message, warning, messageLines
+     -- * Status
+   , Status, HasStatus(..)
+   , isError, isWarning, isOk
+     -- * Rating
+   , Rating, HasRating(..)
+   ) where
+
+import Control.Exception
+import Control.Monad
+import Data.Foldable (toList)
+import Data.IORef
+import Data.List
+import Data.Maybe
+import Data.Semigroup as Sem
+import Data.Time
+import Ideas.Utils.Prelude (getDiffTime)
+import System.IO
+import Test.QuickCheck hiding (Result)
+import qualified Data.Sequence as S
+
+----------------------------------------------------------------
+-- Test Suite
+
+newtype TestSuite = TS (S.Seq Test)
+
+data Test = Case  String (IO Message)
+          | Suite String TestSuite
+
+instance Sem.Semigroup TestSuite where
+   TS xs <> TS ys = TS (xs S.>< ys)
+
+instance Monoid TestSuite where
+   mempty  = TS mempty
+   mappend = (<>)
+
+tests :: TestSuite -> [Test]
+tests (TS xs) = toList xs
+
+makeTestSuite :: Test -> TestSuite
+makeTestSuite = TS . S.singleton
+
+----------------------------------------------------------------
+-- Test suite constructors
+
+-- | Construct a (named) test suite containing test cases and other suites
+suite :: String -> [TestSuite] -> TestSuite
+suite s = makeTestSuite . Suite s . mconcat
+
+-- | Turn a QuickCheck property into the test suite. The first argument is
+-- a label for the property
+useProperty :: Testable prop => String -> prop -> TestSuite
+useProperty = flip usePropertyWith stdArgs
+
+-- | Turn a QuickCheck property into the test suite, also providing a test
+-- configuration (Args)
+usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
+usePropertyWith s args =
+   makeTestSuite . Case s . fmap make . quickCheckWithResult args {chatty=False}
+ where
+   make qc =
+      case qc of
+         Success {} ->
+            mempty
+         Failure {reason = msg} ->
+            message msg
+         NoExpectedFailure {} ->
+            message "no expected failure"
+         GaveUp {numTests = i} ->
+            warning ("passed only " ++ show i ++ " tests")
+         InsufficientCoverage {numTests = i} ->
+            warning ("only performed " ++ show i ++ " tests")
+
+assertTrue :: String -> Bool -> TestSuite
+assertTrue s = assertIO s . return
+
+assertNull :: Show a => String -> [a] -> TestSuite
+assertNull s xs = assertMessages s (null xs) (map show xs)
+
+assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
+assertEquals s x y = assertMessage s (x==y) $
+   "not equal " ++ show x ++ " and " ++ show y
+
+assertMessage :: String -> Bool -> String -> TestSuite
+assertMessage s b = assertMessages s b . return
+
+assertMessages :: String -> Bool -> [String] -> TestSuite
+assertMessages s b xs = makeTestSuite . Case s $ return $
+   if b then mempty else mconcat (map message xs)
+
+assertIO :: String -> IO Bool -> TestSuite
+assertIO s = makeTestSuite . Case s . fmap f
+ where
+   f b = if b then mempty else message "assertion failed"
+
+assertMessageIO :: String -> IO Message -> TestSuite
+assertMessageIO s = makeTestSuite . Case s
+
+-- | All errors are turned into warnings
+onlyWarnings :: TestSuite -> TestSuite
+onlyWarnings = changeMessages $ \m ->
+   m { messageStatus = messageStatus m  `min` Warning
+     , messageRating = mempty
+     }
+
+rateOnError :: Int -> TestSuite -> TestSuite
+rateOnError n = changeMessages $ \m ->
+   if isError m then m { messageRating = Rating n } else m
+
+changeMessages :: (Message -> Message) -> TestSuite -> TestSuite
+changeMessages f = changeTS
+ where
+   changeTS   (TS xs)     = TS (fmap changeTest xs)
+   changeTest (Case s io) = Case s (f <$> io)
+   changeTest (Suite s t) = Suite s (changeTS t)
+
+----------------------------------------------------------------
+-- Running a test suite
+
+runTestSuite :: Bool -> TestSuite -> IO ()
+runTestSuite chattyIO = void . runTestSuiteResult chattyIO
+
+runTestSuiteResult :: Bool -> TestSuite -> IO Result
+runTestSuiteResult chattyIO ts = do
+   hSetBuffering stdout NoBuffering
+   ref <- newIORef 0
+   result <- runner ref chattyIO ts
+   newline ref
+   return result
+
+runner :: IORef Int -> Bool -> TestSuite -> IO Result
+runner ref chattyIO = runTS
+ where
+   runTS :: TestSuite -> IO Result
+   runTS ts = do
+      (res, dt) <- getDiffTime (foldM addTest mempty (tests ts))
+      returnStrict res { diffTime = dt }
+
+   runTest :: Test -> IO Result
+   runTest t =
+      case t of
+         Suite s xs -> runSuite s xs
+         Case s io  -> runTestCase s io
+
+   runSuite ::String -> TestSuite -> IO Result
+   runSuite s ts = do
+      when chattyIO $ do
+         newline ref
+         putStrLn s
+         reset ref
+      result <- runTS ts
+      returnStrict (suiteResult s result)
+
+   runTestCase :: String -> IO Message -> IO Result
+   runTestCase s io = do
+      msg <- io `catch` handler
+      case messageStatus msg of
+         _ | not chattyIO -> return ()
+         Ok -> dot ref
+         _  -> do
+            newlineIndent ref
+            print msg
+            reset ref
+      returnStrict (caseResult (s, msg))
+    where
+      handler :: SomeException -> IO Message
+      handler = return . message . show
+
+   addTest :: Result -> Test -> IO Result
+   addTest res t = (res <>) <$> runTest t
+
+-- formatting helpers
+type WriteIO a = IORef Int -> IO a
+
+newline :: WriteIO ()
+newline ref = do
+   i <- readIORef ref
+   when (i>0) (putChar '\n')
+   reset ref
+
+newlineIndent :: WriteIO ()
+newlineIndent ref = do
+   newline ref
+   putStr "   "
+   writeIORef ref 3
+
+dot :: WriteIO ()
+dot ref = do
+   i <- readIORef ref
+   unless (i>0 && i<60) (newlineIndent ref)
+   putChar '.'
+   modifyIORef ref (+1)
+
+reset :: WriteIO ()
+reset = (`writeIORef` 0)
+
+----------------------------------------------------------------
+-- Test Suite Result
+
+data Result = Result
+   { suites       :: S.Seq (String, Result)
+   , cases        :: S.Seq (String, Message)
+   , diffTime     :: !NominalDiffTime
+   , nrOfTests    :: !Int
+   , nrOfWarnings :: !Int
+   , nrOfErrors   :: !Int
+   , resultRating :: !Rating
+   }
+
+-- one-line summary
+instance Show Result where
+   show result =
+      "(tests: "     ++ show (nrOfTests result)    ++
+      ", errors: "   ++ show (nrOfErrors result)   ++
+      ", warnings: " ++ show (nrOfWarnings result) ++
+      ", "           ++ show (diffTime result)     ++ ")"
+
+instance Sem.Semigroup Result where
+   x <> y = Result
+      { suites       = suites x S.>< suites y
+      , cases        = cases x  S.>< cases y
+      , diffTime     = diffTime x     + diffTime y
+      , nrOfTests    = nrOfTests x    + nrOfTests y
+      , nrOfWarnings = nrOfWarnings x + nrOfWarnings y
+      , nrOfErrors   = nrOfErrors x   + nrOfErrors y
+      , resultRating = resultRating x <> resultRating y
+      }
+
+instance Monoid Result where
+   mempty  = Result mempty mempty 0 0 0 0 mempty
+   mappend = (<>)
+
+instance HasStatus Result where
+   getStatus r | nrOfErrors r   > 0 = Error
+               | nrOfWarnings r > 0 = Warning
+               | otherwise          = Ok
+
+instance HasRating Result where
+   rating   = rating . resultRating
+   rate n a = a {resultRating = Rating n}
+
+suiteResult :: String -> Result -> Result
+suiteResult s res = mempty
+   { suites       = S.singleton (s, res)
+   , nrOfTests    = nrOfTests res
+   , nrOfWarnings = nrOfWarnings res
+   , nrOfErrors   = nrOfErrors res
+   , resultRating = resultRating res
+   }
+
+caseResult :: (String, Message) -> Result
+caseResult x@(_, msg) =
+   case getStatus msg of
+      Ok      -> new
+      Warning -> new { nrOfWarnings = 1 }
+      Error   -> new { nrOfErrors   = 1 }
+ where
+   new = mempty
+      { cases        = S.singleton x
+      , nrOfTests    = 1
+      , resultRating = messageRating msg
+      }
+
+subResults :: Result -> [(String, Result)]
+subResults = toList . suites
+
+topMessages :: Result -> [(String, Message)]
+topMessages = toList . cases
+
+allMessages :: Result -> [(String, Message)]
+allMessages res =
+   topMessages res ++ concatMap (allMessages . snd) (subResults res)
+
+findSubResult :: String -> Result -> Maybe Result
+findSubResult name = listToMaybe . recs
+ where
+   recs = concatMap rec . subResults
+   rec (n, t)
+      | n == name = [t]
+      | otherwise = recs t
+
+justOneSuite :: Result -> Maybe (String, Result)
+justOneSuite res =
+   case subResults res of
+      [x] | S.null (cases res) -> Just x
+      _ -> Nothing
+
+timeInterval :: Result -> Double
+timeInterval = fromRational . toRational . diffTime
+
+printSummary :: Result -> IO ()
+printSummary = putStrLn . makeSummary
+
+makeSummary :: Result -> String
+makeSummary result = unlines $
+   [ line
+   , "Tests    : " ++ show (nrOfTests result)
+   , "Errors   : " ++ show (nrOfErrors result)
+   , "Warnings : " ++ show (nrOfWarnings result)
+   , ""
+   , "Time     : " ++ show (diffTime result)
+   , ""
+   , "Suites: "
+   ] ++ map f (subResults result)
+     ++ [line]
+ where
+   line = replicate 75 '-'
+   f (name, r) = "   " ++ name ++ "   " ++ show r
+
+-----------------------------------------------------
+-- Message
+
+data Message = M
+   { messageStatus :: !Status
+   , messageRating :: !Rating
+   , messageLines  :: [String]
+   }
+ deriving Eq
+
+instance Show Message where
+   show a = st ++ sep ++ msg
+    where
+      msg = intercalate ", " (messageLines a)
+      sep = if null st || null msg then "" else ": "
+      st | isError a             = "error"
+         | isWarning a           = "warning"
+         | null (messageLines a) = "ok"
+         | otherwise             = ""
+
+instance Sem.Semigroup Message where
+   M s r xs <> M t q ys = M (s <> t) (r <> q) (xs <> ys)
+
+instance Monoid Message where
+   mempty  = M mempty mempty mempty
+   mappend = (<>)
+
+instance HasStatus Message where
+   getStatus = messageStatus
+
+instance HasRating Message where
+   rating   = rating . messageRating
+   rate n a = a {messageRating = Rating n}
+
+message :: String -> Message
+message = M Error (Rating 0) . return
+
+warning :: String -> Message
+warning = M Warning mempty . return
+
+-----------------------------------------------------
+-- Status
+
+data Status = Ok | Warning | Error
+   deriving (Eq, Ord)
+
+instance Sem.Semigroup Status where
+   (<>) = max
+
+instance Monoid Status where
+   mempty  = Ok
+   mappend = (<>)
+
+class HasStatus a where
+   getStatus :: a -> Status
+
+isOk, isWarning, isError :: HasStatus a => a -> Bool
+isOk      = (== Ok)      . getStatus
+isWarning = (== Warning) . getStatus
+isError   = (== Error)   . getStatus
+
+-----------------------------------------------------
+-- Rating
+
+data Rating = Rating !Int | MaxRating
+   deriving (Eq, Ord)
+
+instance Sem.Semigroup Rating where
+   (<>) = min
+
+instance Monoid Rating where
+   mempty  = MaxRating
+   mappend = (<>)
+
+class HasRating a where
+   rating :: a -> Maybe Int
+   rate   :: Int -> a -> a
+
+instance HasRating Rating where
+   rating (Rating n) = Just n
+   rating MaxRating  = Nothing
+   rate = const . Rating
+
+-----------------------------------------------------
+-- Utility function
+
+returnStrict :: Monad m => a -> m a
+returnStrict a = a `seq` return a
+ src/Ideas/Utils/Typeable.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Typeable type class, with the IsTypeable data type for witnessing instances
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.Typeable
+   ( IsTypeable, typeable
+   , HasTypeable(..)
+   , castFrom, castTo, castBetween
+   , gcastFrom, gcastTo, gcastBetween
+   , module Data.Typeable
+   ) where
+
+import Control.Monad
+import Data.Typeable
+import Unsafe.Coerce
+
+newtype IsTypeable a = IT TypeRep
+
+class HasTypeable f where
+   getTypeable :: f a -> Maybe (IsTypeable a)
+
+instance HasTypeable IsTypeable where
+   getTypeable = Just
+
+typeable :: forall a . Typeable a => IsTypeable a
+typeable = IT (typeRep (Proxy :: Proxy a))
+
+castFrom :: (HasTypeable f, Typeable b) => f a -> a -> Maybe b
+castFrom = flip castBetween typeable
+
+castTo :: (HasTypeable f, Typeable a) => f b -> a -> Maybe b
+castTo = castBetween typeable
+
+castBetween :: (HasTypeable f, HasTypeable g) => f a -> g b -> a -> Maybe b
+castBetween x y a = do
+   guardEq x y
+   return $ unsafeCoerce a
+
+gcastFrom :: (HasTypeable f, Typeable b) => f a -> c a -> Maybe (c b)
+gcastFrom = flip gcastBetween typeable
+
+gcastTo :: (HasTypeable f, Typeable a) => f b -> c a -> Maybe (c b)
+gcastTo = gcastBetween typeable
+
+gcastBetween :: (HasTypeable f, HasTypeable g) => f a -> g b -> c a -> Maybe (c b)
+gcastBetween ta tb x = fmap (\Refl -> x) (eqIT ta tb)
+
+eqIT :: (HasTypeable f, HasTypeable g) => f a -> g b -> Maybe (a :~: b)
+eqIT x y = do
+   guardEq x y
+   return $ unsafeCoerce Refl
+
+guardEq :: (HasTypeable f, HasTypeable g) => f a -> g b -> Maybe ()
+guardEq x y = do
+   IT ta <- getTypeable x
+   IT tb <- getTypeable y
+   guard (ta == tb)
+ src/Ideas/Utils/Uniplate.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, 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)
+--
+-- Exports a subset of Data.Generics.Uniplate.Direct (the @Uniplate@ type
+-- class and its utility plus constructor functions)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Utils.Uniplate
+   ( -- * Uniplate type class and utility functions
+     Uniplate
+   , children, contexts, descend, descendM, holes, para
+   , rewrite, rewriteM, transform, transformM, uniplate, universe
+     -- * Instance constructors
+   , (|-), (|*), (||*), plate
+   ) where
+
+import Data.Generics.Uniplate.Direct
− src/Network/CGI.hs 
@@ -1,634 +0,0 @@-{-# LANGUAGE OverlappingInstances #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Network.CGI
--- Copyright   :  (c) The University of Glasgow 2001
---                (c) Bjorn Bringert 2004-2006
---                (c) Ian Lynagh 2005
---                (c) Jeremy Shaw 2005
--- License     :  BSD-style
---
--- Maintainer  :  John Chee <cheecheeo@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable (uses Control.Monad.State)
---
--- Simple Library for writing CGI programs.
--- See <http://hoohoo.ncsa.uiuc.edu/cgi/interface.html> for the
--- CGI specification.
---
--- This version of the library is for systems with version 2.0 or greater
--- of the network package. This includes GHC 6.6 and later. For older
--- systems, see <http://www.cs.chalmers.se/~bringert/darcs/cgi-compat/doc/>
---
--- Based on the original Haskell binding for CGI:
---
--- Original Version by Erik Meijer <mailto:erik@cs.ruu.nl>.
--- Further hacked on by Sven Panne <mailto:sven.panne@aedion.de>.
--- Further hacking by Andy Gill <mailto:andy@galconn.com>.
--- A new, hopefully more flexible, interface
--- and support for file uploads by Bjorn Bringert <mailto:bjorn@bringert.net>.
---
--- Here is a simple example, including error handling (not that there is
--- much that can go wrong with Hello World):
---
--- > import Network.CGI
--- >
--- > cgiMain :: CGI CGIResult
--- > cgiMain = output "Hello World!"
--- >
--- > main :: IO ()
--- > main = runCGI (handleErrors cgiMain)
---
---
------------------------------------------------------------------------------
-
-module Network.CGI (
-  -- * CGI monad
-    MonadCGI, CGIT, CGIResult, CGI
-  , MonadIO, liftIO
-  , runCGI
-  -- * Error handling
-  , throwCGI, catchCGI, tryCGI, handleExceptionCGI
-  , handleErrors
-  -- * Logging
-  , logCGI
-  -- * Output
-  , output, outputFPS, outputNothing, redirect
-  , setHeader, setStatus
-  -- * Error pages
-  , outputError, outputException
-  , outputNotFound, outputMethodNotAllowed, outputInternalServerError
-  -- * Input
-  , getInput, getInputFPS, readInput
-  , getBody, getBodyFPS
-  , getInputs, getInputsFPS, getInputNames
-  , getMultiInput, getMultiInputFPS
-  , getInputFilename, getInputContentType
-  -- * Environment
-  , getVar, getVarWithDefault, getVars
-  -- * Request information
-  , serverName, serverPort
-  , requestMethod, pathInfo
-  , pathTranslated, scriptName
-  , queryString
-  , remoteHost, remoteAddr
-  , authType, remoteUser
-  , requestContentType, requestContentLength
-  , requestHeader
-  -- * Program and request URI
-  , progURI, queryURI, requestURI
-  -- * Content negotiation
-  , Acceptable, Accept
-  , Charset(..), ContentEncoding(..), Language(..)
-  , requestAccept, requestAcceptCharset, requestAcceptEncoding, requestAcceptLanguage
-  , negotiate
-  -- * Content type
-  , ContentType(..), showContentType, parseContentType
-  -- * Cookies
-  , Cookie(..), newCookie
-  , getCookie, readCookie
-  , setCookie, deleteCookie
-  -- * URL encoding
-  , formEncode, urlEncode, formDecode, urlDecode
-  -- * Compatibility with the old API
-  , module Network.CGI.Compat
-  ) where
-
-import Control.Exception (Exception(..), SomeException, ErrorCall(..))
-import Control.Monad (liftM)
-import Control.Monad.Catch (MonadCatch)
-import Control.Monad.Trans (MonadIO, liftIO)
-import Data.Char (toUpper)
-import Data.List (intersperse, sort, group)
-import Data.Maybe (fromMaybe)
-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 Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as BS
-
-import Network.CGI.Accept
-import Network.CGI.Compat
-import Network.CGI.Cookie (Cookie(..), showCookie, newCookie, findCookie)
-import Network.CGI.Monad
-import Network.CGI.Protocol
-import qualified Network.CGI.Cookie as Cookie (deleteCookie)
-
-import Text.XHtml (renderHtml, header, (<<), thetitle, (+++),
-                   body, h1, paragraph, hr, address)
-
--- | Run a CGI action. Typically called by the main function.
---   Reads input from stdin and writes to stdout. Gets
---   CGI environment variables from the program environment.
-runCGI :: MonadIO m => CGIT m CGIResult -> m ()
-runCGI f = do env <- getCGIVars
-              hRunCGI env stdin stdout (runCGIT f)
-
---
--- * Output \/ redirect
---
-
--- | Output a 'String'. The output is assumed to be text\/html, encoded using
---   ISO-8859-1. To change this, set the Content-type header using
---   'setHeader'.
-output :: MonadCGI m =>
-          String        -- ^ The string to output.
-       -> m CGIResult
-output = return . CGIOutput . BS.pack
-
--- | Output a 'ByteString'. The output is assumed to be text\/html,
---   encoded using ISO-8859-1. To change this, set the
---   Content-type header using 'setHeader'.
-outputFPS :: MonadCGI m =>
-             ByteString        -- ^ The string to output.
-          -> m CGIResult
-outputFPS = return . CGIOutput
-
--- | Do not output anything (except headers).
-outputNothing :: MonadCGI m => m CGIResult
-outputNothing = return CGINothing
-
--- | Redirect to some location.
-redirect :: MonadCGI m =>
-            String        -- ^ A URL to redirect to.
-         -> m CGIResult
-redirect url = do setHeader "Location" url
-                  outputNothing
-
---
--- * Error handling
---
-
--- | Catches any exception thrown by the given CGI action,
---   returns an error page with a 500 Internal Server Error,
---   showing the exception information, and logs the error.
---
---   Typical usage:
---
--- > cgiMain :: CGI CGIResult
--- > cgiMain = ...
--- >
--- > main :: IO ()
--- > main = runCGI (handleErrors cgiMain)
-handleErrors :: (MonadCGI m, MonadCatch m, MonadIO m) => m CGIResult -> m CGIResult
-handleErrors = flip catchCGI outputException
-
---
--- * Error output
---
-
--- | Output a 500 Internal Server Error with information from
---   an 'Exception'.
-outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult
-outputException e = outputInternalServerError es
-    where es = case fromException e of
-                 Just (ErrorCall msg) -> [msg]
-                 _ -> [show e]
-
--- | Output an error page to the user, with the given
---   HTTP status code in the response. Also logs the error information
---   using 'logCGI'.
-outputError :: (MonadCGI m, MonadIO m) =>
-               Int      -- ^ HTTP Status code
-            -> String   -- ^ Status message
-            -> [String] -- ^ Error information
-            -> m CGIResult
-outputError c m es =
-      do logCGI $ show (c,m,es)
-         setStatus c m
-         let textType = ContentType "text" "plain" [("charset","ISO-8859-1")]
-             htmlType = ContentType "text" "html"  [("charset","ISO-8859-1")]
-         cts <- liftM (negotiate [htmlType,textType]) requestAccept
-         case cts of
-           ct:_ | ct == textType ->
-                do setHeader "Content-type" (showContentType textType)
-                   text <- errorText c m es
-                   output text
-           _ -> do setHeader "Content-type" (showContentType htmlType)
-                   page <- errorPage c m es
-                   output $ renderHtml page
-
--- | Create an HTML error page.
-errorPage :: MonadCGI m =>
-             Int      -- ^ Status code
-          -> String   -- ^ Status message
-          -> [String] -- ^ Error information
-          -> m Html
-errorPage c m es =
-    do server <- getVar "SERVER_SOFTWARE"
-       host   <- getVar "SERVER_NAME"
-       port   <- getVar "SERVER_PORT"
-       let tit = show c ++ " " ++ m
-           sig = "Haskell CGI"
-                 ++ " on " ++ fromMaybe "" server
-                 ++ " at " ++ fromMaybe "" host ++ maybe "" (", port "++) port
-       return $ header << thetitle << tit
-                  +++ body << (h1 << tit +++ map (paragraph <<) es
-                               +++ hr +++ address << sig)
-
-errorText :: MonadCGI m =>
-             Int      -- ^ Status code
-          -> String   -- ^ Status message
-          -> [String] -- ^ Error information
-          -> m String
-errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es
-
---
--- * Specific HTTP errors
---
-
--- | Use 'outputError' to output and log a 404 Not Found error.
-outputNotFound :: (MonadIO m, MonadCGI m) =>
-                 String -- ^ The name of the requested resource.
-              -> m CGIResult
-outputNotFound r =
-    outputError 404 "Not Found" ["The requested resource was not found: " ++ r]
-
--- | Use 'outputError' to output and log a 405 Method Not Allowed error.
-outputMethodNotAllowed :: (MonadIO m, MonadCGI m) =>
-                          [String] -- ^ The allowed methods.
-                       -> m CGIResult
-outputMethodNotAllowed ms =
-    do let allow = concat $ intersperse ", " ms
-       setHeader "Allow" allow
-       outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow]
-
--- | Use 'outputError' to output and log a 500 Internal Server Error.
-outputInternalServerError :: (MonadIO m, MonadCGI m) =>
-                             [String] -- ^ Error information.
-                          -> m CGIResult
-outputInternalServerError es = outputError 500 "Internal Server Error" es
-
---
--- * Environment variables
---
-
--- | Get the value of a CGI environment variable. Example:
---
--- > remoteAddr <- getVar "REMOTE_ADDR"
-getVar :: MonadCGI m =>
-          String             -- ^ The name of the variable.
-       -> m (Maybe String)
-getVar name = liftM (Map.lookup name) $ cgiGet cgiVars
-
-getVarWithDefault :: MonadCGI m =>
-                     String -- ^ The name of the variable.
-                  -> String -- ^ Default value
-                  -> m String
-getVarWithDefault name def = liftM (fromMaybe def) $ getVar name
-
--- | Get all CGI environment variables and their values.
-getVars :: MonadCGI m =>
-           m [(String,String)]
-getVars = liftM Map.toList $ cgiGet cgiVars
-
---
--- * Request information
---
-
--- | The server\'s hostname, DNS alias, or IP address as it would
---   appear in self-referencing URLs.
-serverName :: MonadCGI m => m String
-serverName = getVarWithDefault "SERVER_NAME" ""
-
--- | The port number to which the request was sent.
-serverPort :: MonadCGI m => m Int
-serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT")
-
--- |  The method with which the request was made.
---    For HTTP, this is \"GET\", \"HEAD\", \"POST\", etc.
-requestMethod :: MonadCGI m => m String
-requestMethod = getVarWithDefault "REQUEST_METHOD" "GET"
-
--- | The extra path information, as given by the client.
---   This is any part of the request path that follows the
---   CGI program path.
---   If the string returned by this function is not empty,
---   it is guaranteed to start with a @\'\/\'@.
---
--- Note that this function returns an unencoded string.
--- Make sure to percent-encode any characters
--- that are not allowed in URI paths before using the result of
--- this function to construct a URI.
--- See 'progURI', 'queryURI' and 'requestURI' for a higher-level
--- interface.
-pathInfo :: MonadCGI m => m String
-pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" ""
-  where slash s = if not (null s) && head s /= '/' then '/':s else s
-
--- | The path returned by 'pathInfo', but with virtual-to-physical
---   mapping applied to it.
-pathTranslated :: MonadCGI m => m String
-pathTranslated = getVarWithDefault "PATH_TRANSLATED" ""
-
--- | A virtual path to the script being executed,
--- used for self-referencing URIs.
---
--- Note that this function returns an unencoded string.
--- Make sure to percent-encode any characters
--- that are not allowed in URI paths before using the result of
--- this function to construct a URI.
--- See 'progURI', 'queryURI' and 'requestURI' for a higher-level
--- interface.
-scriptName :: MonadCGI m => m String
-scriptName = getVarWithDefault "SCRIPT_NAME" ""
-
--- | The information which follows the ? in the URL which referenced
---   this program. This is the percent-encoded query information.
---   For most normal uses, 'getInput' and friends are probably
---   more convenient.
-queryString :: MonadCGI m => m String
-queryString = getVarWithDefault "QUERY_STRING" ""
-
--- | The hostname making the request. If the server does not have
---   this information, Nothing is returned. See also 'remoteAddr'.
-remoteHost :: MonadCGI m => m (Maybe String)
-remoteHost = getVar "REMOTE_HOST"
-
--- | The IP address of the remote host making the request.
-remoteAddr :: MonadCGI m => m String
-remoteAddr = getVarWithDefault "REMOTE_ADDR" ""
-
--- | If the server supports user authentication, and the script is
--- protected, this is the protocol-specific authentication method
--- used to validate the user.
-authType :: MonadCGI m => m (Maybe String)
-authType = getVar "AUTH_TYPE"
-
--- | If the server supports user authentication, and the script is
---   protected, this is the username they have authenticated as.
-remoteUser :: MonadCGI m => m (Maybe String)
-remoteUser = getVar "REMOTE_USER"
-
--- | For queries which have attached information, such as
---   HTTP POST and PUT, this is the content type of the data.
---   You can use 'parseContentType' to get a structured
---   representation of the the content-type value.
-requestContentType :: MonadCGI m => m (Maybe String)
-requestContentType = getVar "CONTENT_TYPE"
-
--- | For queries which have attached information, such as
---   HTTP POST and PUT, this is the length of the content
---   given by the client.
-requestContentLength :: MonadCGI m => m (Maybe Int)
-requestContentLength = liftM (>>= maybeRead) $ getVar "CONTENT_LENGTH"
-
--- | Gets the value of the request header with the given name.
---   The header name is case-insensitive.
---   Example:
---
--- > requestHeader "User-Agent"
-requestHeader :: MonadCGI m => String -> m (Maybe String)
-requestHeader name = getVar var
-  where var = "HTTP_" ++ map toUpper (replace '-' '_' name)
-
---
--- * Content negotiation
---
-
-requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a)
-requestHeaderValue h = liftM (>>= parseM parseHeaderValue h) $ requestHeader h
-
-requestAccept :: MonadCGI m => m (Maybe (Accept ContentType))
-requestAccept = requestHeaderValue "Accept"
-
-requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset))
-requestAcceptCharset = requestHeaderValue "Accept-Charset"
-
-requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding))
-requestAcceptEncoding = requestHeaderValue "Accept-Encoding"
-
-requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language))
-requestAcceptLanguage = requestHeaderValue "Accept-Language"
-
---
--- * Program and request URI
---
-
--- | Attempts to reconstruct the absolute URI of this program.
---   This does not include
---   any extra path information or query parameters. See
---   'queryURI' for that.
---   If the server is rewriting request URIs, this URI can
---   be different from the one requested by the client.
---   See also 'requestURI'.
---
--- Characters in the components of the returned URI are escaped
--- when needed, as required by "Network.URI".
-progURI :: MonadCGI m => m URI
-progURI =
-    do -- Use HTTP_HOST if available, otherwise SERVER_NAME
-       h <- requestHeader "Host" >>= maybe serverName return
-       p <- serverPort
-       name <- scriptName
-       https <- liftM (maybe False (const True)) (getVar "HTTPS")
-       -- SERVER_PORT might not be the port that the client used
-       -- if the server listens on multiple ports, so we give priority
-       -- to the port in HTTP_HOST.
-       -- HTTP_HOST should include the port according to RFC2616 sec 14.23
-       -- Some servers (e.g. lighttpd) also seem to include the port in
-       -- SERVER_NAME.
-       -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if
-       -- it is a non-standard port.
-       let (host,port) = case break (==':') h of
-                           (_,"")  -> (h, if (not https && p == 80)
-                                            || (https && p == 443)
-                                           then "" else ':':show p)
-                           (h',p') -> (h',p')
-       let auth = URIAuth { uriUserInfo = "",
-                            uriRegName = host,
-                            uriPort = port }
-       return $ nullURI { uriScheme = if https then "https:" else "http:",
-                          uriAuthority = Just auth,
-                          uriPath = escapePath name }
-
--- | Like 'progURI', but the returned 'URI' also includes
---   any extra path information, and any query parameters.
---   If the server is rewriting request URIs, this URI can
---   be different from the one requested by the client.
---   See also 'requestURI'.
---
--- Characters in the components of the returned URI are escaped
--- when needed, as required by "Network.URI".
-queryURI :: MonadCGI m => m URI
-queryURI =
-    do uri  <- progURI
-       path <- pathInfo
-       qs   <- liftM (\q -> if null q then q else '?':q) $ queryString
-       return $ uri { uriPath = uriPath uri ++ escapePath path,
-                      uriQuery = qs }
-
--- | Does percent-encoding as needed for URI path components.
-escapePath :: String -> String
-escapePath = escapeURIString isUnescapedInURIPath
-  where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"
-
--- | Attempts to reconstruct the absolute URI requested by the client,
---   including extra path information and query parameters.
---   If no request URI rewriting is done, or if the web server does not
---   provide the information needed to reconstruct the request URI,
---   this function returns the same value as 'queryURI'.
---
--- Characters in the components of the returned URI are escaped
--- when needed, as required by "Network.URI".
-requestURI :: MonadCGI m => m URI
-requestURI =
-    do uri <- queryURI
-       -- Apache sets REQUEST_URI to the original request URI,
-       -- with percent-encoding intact.
-       mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI"
-       return $ case mreq of
-                 Nothing  -> uri
-                 Just req -> uri {
-                                  uriPath  = uriPath req,
-                                  uriQuery = uriQuery req
-                                 }
-
---
--- * Inputs
---
-
--- | Get the value of an input variable, for example from a form.
---   If the variable has multiple values, the first one is returned.
---   Example:
---
--- > query <- getInput "query"
-getInput :: MonadCGI m =>
-            String           -- ^ The name of the variable.
-         -> m (Maybe String) -- ^ The value of the variable,
-                             --   or Nothing, if it was not set.
-getInput = liftM (fmap BS.unpack) . getInputFPS
-
--- | Like 'getInput', but returns a 'ByteString'.
-getInputFPS :: MonadCGI m =>
-            String           -- ^ The name of the variable.
-         -> m (Maybe ByteString) -- ^ The value of the variable,
-                             --   or Nothing, if it was not set.
-getInputFPS = liftM (fmap inputValue) . getInput_
-
--- | Get all the values of an input variable, for example from a form.
--- This can be used to get all the values from form controls
--- which allow multiple values to be selected.
--- Example:
---
--- > vals <- getMultiInput "my_checkboxes"
-getMultiInput :: MonadCGI m =>
-                 String -- ^ The name of the variable.
-              -> m [String] -- ^ The values of the variable,
-                            -- or the empty list if the variable was not set.
-getMultiInput = liftM (map BS.unpack) . getMultiInputFPS
-
--- | Same as 'getMultiInput' but using 'ByteString's.
-getMultiInputFPS :: MonadCGI m =>
-                    String -- ^ The name of the variable.
-                 -> m [ByteString] -- ^ The values of the variable,
-                            -- or the empty list if the variable was not set.
-getMultiInputFPS n = do is <- cgiGet cgiInputs
-                        return [inputValue v | (p,v) <- is, p == n]
-
--- | Get the file name of an input.
-getInputFilename :: MonadCGI m =>
-                    String           -- ^ The name of the variable.
-                 -> m (Maybe String) -- ^ The file name corresponding to the
-                                     -- input, if there is one.
-getInputFilename = liftM (>>= inputFilename) . getInput_
-
--- | Get the content-type of an input, if the input exists, e.g. "image\/jpeg".
---   For non-file inputs, this function returns "text\/plain".
---   You can use 'parseContentType' to get a structured
---   representation of the the content-type value.
-getInputContentType :: MonadCGI m =>
-                       String   -- ^ The name of the variable.
-                    -> m (Maybe String) -- ^ The content type, formatted as a string.
-getInputContentType =
-    liftM (fmap (showContentType . inputContentType)) . getInput_
-
--- | Same as 'getInput', but tries to read the value to the desired type.
-readInput :: (Read a, MonadCGI m) =>
-             String        -- ^ The name of the variable.
-          -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist
-                           --   or if the value could not be interpreted
-                           --   at the desired type.
-readInput = liftM (>>= maybeRead) . getInput
-
--- | Get the names and values of all inputs.
---   Note: the same name may occur more than once in the output,
---   if there are several values for the name.
-getInputs :: MonadCGI m => m [(String,String)]
-getInputs = do is <- cgiGet cgiInputs
-               return [ (n, BS.unpack (inputValue i)) | (n,i) <- is ]
-
--- | Get the names and values of all inputs.
---   Note: the same name may occur more than once in the output,
---   if there are several values for the name.
-getInputsFPS :: MonadCGI m => m [(String,ByteString)]
-getInputsFPS = do is <- cgiGet cgiInputs
-                  return [ (n, inputValue i) | (n,i) <- is ]
-
--- | Get the names of all input variables.
-getInputNames :: MonadCGI m => m [String]
-getInputNames = (sortNub . map fst) `liftM` cgiGet cgiInputs
-    where sortNub = map head . group . sort
-
--- Internal stuff
-
-getInput_ ::  MonadCGI m => String -> m (Maybe Input)
-getInput_ n = lookup n `liftM` cgiGet cgiInputs
-
--- | Get the uninterpreted request body as a String
-getBody :: MonadCGI m => m String
-getBody = BS.unpack `liftM` cgiGet cgiRequestBody
-
--- | Get the uninterpreted request body as lazy ByteString
-getBodyFPS :: MonadCGI m => m ByteString
-getBodyFPS = cgiGet cgiRequestBody
-
---
--- * Cookies
---
-
--- | Get the value of a cookie.
-getCookie :: MonadCGI m =>
-             String           -- ^ The name of the cookie.
-          -> m (Maybe String) -- ^ 'Nothing' if the cookie does not exist.
-getCookie name = liftM (>>= findCookie name) (getVar "HTTP_COOKIE")
-
--- | Same as 'getCookie', but tries to read the value to the desired type.
-readCookie :: (Read a, MonadCGI m) =>
-              String       -- ^ The name of the cookie.
-            -> m (Maybe a) -- ^ 'Nothing' if the cookie does not exist
-                           --   or if the value could not be interpreted
-                           --   at the desired type.
-readCookie = liftM (>>= maybeRead) . getCookie
-
--- | Set a cookie.
-setCookie :: MonadCGI m => Cookie -> m ()
-setCookie = setHeader "Set-cookie" . showCookie
-
--- | Delete a cookie from the client
-deleteCookie :: MonadCGI m => Cookie -> m ()
-deleteCookie = setCookie . Cookie.deleteCookie
-
---
--- * Headers
---
-
--- | Add a response header.
---   Example:
---
--- > setHeader "Content-type" "text/plain"
-setHeader :: MonadCGI m =>
-             String -- ^ Header name.
-          -> String -- ^ Header value.
-          -> m ()
-setHeader n v = cgiAddHeader (HeaderName n) v
-
--- | Set the HTTP response status.
-setStatus :: MonadCGI m =>
-             Int -- ^  HTTP status code, e.g. @404@
-          -> String -- ^ HTTP status message, e.g. @"Not Found"@
-          -> m ()
-setStatus c m = setHeader "Status" (show c ++ " " ++ m)
− src/Network/CGI/Accept.hs 
@@ -1,173 +0,0 @@-module Network.CGI.Accept (
-  -- * Accept-X headers
-    Acceptable
-  , Accept
-  , Charset(..), ContentEncoding(..), Language(..)
-  -- * Content negotiation
-  , negotiate
-                          ) where
-
-import Data.Function
-import Data.List
-import Data.Maybe
-import Numeric
-
-import Text.ParserCombinators.Parsec
-
-import Network.Multipart
-import Network.Multipart.Header
-
---
--- * Accept-X headers
---
-
-newtype Accept a = Accept [(a, Quality)]
-    deriving (Show)
-
-type Quality = Double
-
--- A bounded join-semilattice
-class Eq a => Acceptable a where
-    includes :: a -> a -> Bool
-    top :: a
-
-instance HeaderValue a => HeaderValue (Accept a) where
-    parseHeaderValue = fmap Accept $ sepBy p (lexeme (char ','))
-        where p = do a <- parseHeaderValue
-                     q <- option 1 $ do _ <- lexeme $ char ';'
-                                        _ <- lexeme $ char 'q'
-                                        _ <- lexeme $ char '='
-                                        lexeme pQuality
-                     return (a,q)
-              pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0")))
-                         <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1)
-    prettyHeaderValue (Accept xs) = concat $ intersperse ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs]
-        where showQuality q = showFFloat (Just 3) q ""
-
-starOrEqualTo :: String -> String -> Bool
-starOrEqualTo x y = x == "*" || x == y
-
-negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a]
-negotiate ys Nothing = ys
-negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0]
-
---testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a]
---testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "<source>") ts] (parseM parseHeaderValue "<source>" a)
-
-quality :: Acceptable a => Accept a -> a -> Quality
-quality (Accept xs) y = fromMaybe 0 $ listToMaybe $ sort $ map snd $ sortBy (compareSpecificity `on` fst) $ filter ((`includes` y) . fst) xs
-
-compareSpecificity :: Acceptable a => a -> a -> Ordering
-compareSpecificity x y
-    | x `includes` y && y `includes` x = EQ
-    | x `includes` y = GT
-    | y `includes` x = LT
-    | otherwise = error "Non-comparable Acceptables"
-
---
--- ** Accept
---
-
-instance Acceptable ContentType where
-    includes x y = ctType x `starOrEqualTo` ctType y
-                   && ctSubtype x `starOrEqualTo` ctSubtype y
-                   && all (hasParameter y) (ctParameters x)
-    top = ContentType "*" "*" []
-
-hasParameter :: ContentType -> (String, String) -> Bool
-hasParameter t (k,v) = maybe False (==v) $ lookup k (ctParameters t)
-
---
--- ** Accept-Charset
---
-
-{-
-RFC 2616 14.2:
-
-The special value "*", if present in the Accept-Charset field, matches
-every character set (including ISO-8859-1) which is not mentioned
-elsewhere in the Accept-Charset field. If no "*" is present in an
-Accept-Charset field, then all character sets not explicitly mentioned
-get a quality value of 0, except for ISO-8859-1, which gets a quality
-value of 1 if not explicitly mentioned.
-
-If no Accept-Charset header is present, the default is that any
-character set is acceptable. If an Accept-Charset header is present,
-and if the server cannot send a response which is acceptable according
-to the Accept-Charset header, then the server SHOULD send an error
-response with the 406 (not acceptable) status code, though the sending
-of an unacceptable response is also allowed.
--}
-
-newtype Charset = Charset String
-    deriving (Show)
-
-instance Eq Charset where
-    Charset x == Charset y = caseInsensitiveEq x y
-
-instance Ord Charset where
-    Charset x `compare` Charset y = caseInsensitiveCompare x y
-
-instance HeaderValue Charset where
-    parseHeaderValue = fmap Charset $ many ws1 >> lexeme p_token
-    prettyHeaderValue (Charset s) = s
-
-instance Acceptable Charset where
-    Charset x `includes` Charset y = starOrEqualTo x y
-    top = Charset "*"
-
---
--- ** Accept-Encoding
---
-
-{-
-RFC 2616, section 14.3
--}
-
-newtype ContentEncoding = ContentEncoding String
-    deriving (Show)
-
-instance Eq ContentEncoding where
-    ContentEncoding x == ContentEncoding y = caseInsensitiveEq x y
-
-instance Ord ContentEncoding where
-    ContentEncoding x `compare` ContentEncoding y = caseInsensitiveCompare x y
-
-instance HeaderValue ContentEncoding where
-    parseHeaderValue = fmap ContentEncoding $ many ws1 >> lexeme p_token
-    prettyHeaderValue (ContentEncoding s) = s
-
-instance Acceptable ContentEncoding where
-    ContentEncoding x `includes` ContentEncoding y = starOrEqualTo x y
-    top = ContentEncoding "*"
-
---
--- ** Accept-Language
---
-
-newtype Language = Language String
-    deriving (Show)
-
-instance Eq Language where
-    Language x == Language y = caseInsensitiveEq x y
-
-instance Ord Language where
-    Language x `compare` Language y = caseInsensitiveCompare x y
-
-instance HeaderValue Language where
-    parseHeaderValue = fmap Language $ many ws1 >> lexeme p_token
-    prettyHeaderValue (Language s) = s
-
-{-
-RFC 2616 14.4
-
-A language-range matches a language-tag if it exactly equals the tag,
-or if it exactly equals a prefix of the tag such that the first tag
-character following the prefix is "-". The special range "*", if
-present in the Accept-Language field, matches every tag not matched by
-any other range present in the Accept-Language field.
--}
-instance Acceptable Language where
-    Language x `includes` Language y =
-        x == "*" || x == y || (x `isPrefixOf` y && "-" `isPrefixOf` drop (length x) y)
-    top = Language "*"
− src/Network/CGI/Compat.hs 
@@ -1,112 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Network.CGI.Compat
--- Copyright   :  (c) The University of Glasgow 2001
---                (c) Bjorn Bringert 2004-2006
---                (c) Ian Lynagh 2005
---                (c) Jeremy Shaw 2005
--- License     :  BSD-style
---
--- Maintainer  :  John Chee <cheecheeo@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable (uses Control.Monad.State)
---
--- Compatibility functions for the old Network.CGI API.
---
------------------------------------------------------------------------------
-
-module Network.CGI.Compat (
-    Html, wrapper, pwrapper, connectToCGIScript
-  ) where
-
-import Control.Concurrent (forkIO)
-import Control.Exception as Exception (SomeException, throw, catch, finally)
-import Control.Monad (unless)
-import Control.Monad.Trans (MonadIO, liftIO)
-import Network (PortID, Socket, listenOn, connectTo)
-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)
-import qualified Data.ByteString.Lazy.Char8 as BS
-
-import Text.XHtml (Html, renderHtml)
-
-import Network.CGI.Protocol
-
-{-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-}
-
--- | Compatibility wrapper for the old CGI interface.
---   Output the output from a function from CGI environment and
---   input variables to an HTML document.
-wrapper :: ([(String,String)] -> IO Html) -> IO ()
-wrapper = run stdin stdout
-
--- | Compatibility wrapper for the old CGI interface.
---   Runs a simple CGI server.
---   Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main.
-pwrapper :: PortID  -- ^ The port to run the server on.
-         -> ([(String,String)] -> IO Html)
-         -> IO ()
-pwrapper pid f = do sock <- listenOn pid
-                    acceptConnections fn sock
- where fn h = run h h f
-
-acceptConnections :: (Handle -> IO ()) -> Socket -> IO ()
-acceptConnections fn sock = do
-  (h, SockAddrInet _ _) <- accept' sock
-  _ <- forkIO (fn h `finally` (hClose h))
-  acceptConnections fn sock
-
-accept' :: Socket                 -- Listening Socket
-       -> IO (Handle,SockAddr)        -- StdIO Handle for read/write
-accept' sock = do
- (sock', addr) <- Socket.accept sock
- handle        <- socketToHandle sock' ReadWriteMode
- return (handle,addr)
-
-run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m ()
-run inh outh f =
-    do env <- getCGIVars
-       hRunCGI env inh outh f'
-  where f' req = do let vs = Map.toList (cgiVars req)
-                        is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ]
-                    html <- liftIO (f (vs++is))
-                    return ([], CGIOutput $ BS.pack $ renderHtml html)
-
--- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main.
-connectToCGIScript :: String -> PortID -> IO ()
-connectToCGIScript host portId
-     = do env <- getCGIVars
-          input <- BS.hGetContents stdin
-          let str = getRequestInput env input
-          h <- connectTo host portId
-                 `Exception.catch`
-                   (\ e -> abort "Cannot connect to CGI daemon." e)
-          BS.hPut h str >> hPutStrLn h ""
-          (sendBack h `finally` hClose h)
-               `Exception.catch` (\e -> unless (isEOFError e) (ioError e))
-
--- | Returns the query string, or the request body if it is
---   a POST request, or the empty string if there is an error.
-getRequestInput :: [(String,String)] -- ^ CGI environment variables.
-                -> ByteString            -- ^ Request body.
-                -> ByteString            -- ^ Query string.
-getRequestInput env req =
-   case lookup "REQUEST_METHOD" env of
-      Just "POST" -> takeInput env req
-      _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env)
-
-abort :: String -> SomeException -> IO a
-abort msg e =
-    do putStrLn ("Content-type: text/html\n\n" ++
-                   "<html><body>" ++ msg ++ "</body></html>")
-       throw e
-
-sendBack :: Handle -> IO ()
-sendBack h = do s <- hGetLine h
-                putStrLn s
-                sendBack h
− src/Network/CGI/Cookie.hs 
@@ -1,154 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Network.CGI.Cookie
--- Copyright   :  (c) Bjorn Bringert 2004-2005
---                (c) Ian Lynagh 2005
--- License     :  BSD-style
---
--- Maintainer  :  John Chee <cheecheeo@gmail.com>
--- Stability   :  experimental
--- Portability :  portable
---
---  General server side HTTP cookie library.
---  Based on <http://wp.netscape.com/newsref/std/cookie_spec.html>
---
--- TODO
---
--- * Add client side stuff (basically parsing Set-Cookie: value)
---
--- * Update for RFC2109 <http://www.ietf.org/rfc/rfc2109.txt>
---
------------------------------------------------------------------------------
-module Network.CGI.Cookie (
-                            Cookie(..)
-                            , newCookie
-                            , findCookie, deleteCookie
-                            , showCookie, readCookies
-                           ) where
-
-import Data.Char (isSpace)
-import Data.List (intersperse)
-import Data.Maybe (catMaybes)
-import System.Locale (defaultTimeLocale, rfc822DateFormat)
-import System.Time (CalendarTime(..), Month(..), Day(..),
-                    formatCalendarTime)
-
---
--- * Types
---
-
--- | Contains all information about a cookie set by the server.
-data Cookie = Cookie {
-                      -- | Name of the cookie.
-                      cookieName :: String,
-                      -- | Value of the cookie.
-                      cookieValue :: String,
-                      -- | Expiry date of the cookie. If 'Nothing', the
-                      --   cookie expires when the browser sessions ends.
-                      --   If the date is in the past, the client should
-                      --   delete the cookie immediately.
-                      cookieExpires :: Maybe CalendarTime,
-                      -- | The domain suffix to which this cookie will be sent.
-                      cookieDomain :: Maybe String,
-                      -- | The path to which this cookie will be sent.
-                      cookiePath :: Maybe String,
-                      -- | 'True' if this cookie should only be sent using
-                      --   secure means.
-                      cookieSecure :: Bool
-                     }
-            deriving (Show, Read, Eq, Ord)
-
---
--- * Constructing cookies
---
-
--- | Construct a cookie with only name and value set.
---   This client will expire when the browser sessions ends,
---   will only be sent to the server and path which set it
---   and may be sent using any means.
-newCookie :: String -- ^ Name
-          -> String -- ^ Value
-          -> Cookie -- ^ Cookie
-newCookie name value = Cookie { cookieName = name,
-                                cookieValue = value,
-                                cookieExpires = Nothing,
-                                cookieDomain = Nothing,
-                                cookiePath = Nothing,
-                                cookieSecure = False
-                              }
-
---
--- * Getting and setting cookies
---
-
--- | Get the value of a cookie from a string on the form
---   @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.
---   This is the format of the @Cookie@ HTTP header.
-findCookie :: String -- ^ Cookie name
-           -> String -- ^ Semicolon separated list of name-value pairs
-           -> Maybe String  -- ^ Cookie value, if found
-findCookie name s = maybeLast [ cv | (cn,cv) <- readCookies s, cn == name ]
-
--- | Delete a cookie from the client by setting the cookie expiry date
---   to a date in the past.
-deleteCookie :: Cookie  -- ^ Cookie to delete. The only fields that matter
-                        --   are 'cookieName', 'cookieDomain' and 'cookiePath'
-             -> Cookie
-deleteCookie c = c { cookieExpires = Just epoch }
-    where
-    epoch = CalendarTime {
-                          ctYear = 1970,
-                          ctMonth = January,
-                          ctDay = 1,
-                          ctHour = 0,
-                          ctMin = 0,
-                          ctSec = 0,
-                          ctPicosec = 0,
-                          ctWDay = Thursday,
-                          ctYDay = 1,
-                          ctTZName = "GMT",
-                          ctTZ = 0,
-                          ctIsDST = False
-                         }
-
---
--- * Reading and showing cookies
---
-
--- | Show a cookie on the format used as the value of the Set-Cookie header.
-showCookie :: Cookie -> String
-showCookie c = concat $ intersperse "; " $
-                showPair (cookieName c) (cookieValue c)
-                 : catMaybes [expires, path, domain, secure]
-    where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c)
-          domain = fmap (showPair "domain") (cookieDomain c)
-          path = fmap (showPair "path") (cookiePath c)
-          secure = if cookieSecure c then Just "secure" else Nothing
-          dateFmt = formatCalendarTime defaultTimeLocale rfc822DateFormat
-
--- | Show a name-value pair. FIXME: if the name or value
---   contains semicolons, this breaks. The problem
---   is that the original cookie spec does not mention
---   how to do escaping or quoting.
-showPair :: String -- ^ name
-         -> String -- ^ value
-         -> String
-showPair name value = name ++ "=" ++ value
-
--- | Gets all the cookies from a Cookie: header value
-readCookies :: String             -- ^ String to parse
-            -> [(String,String)]  -- ^ Cookie name - cookie value pairs
-readCookies s =
-    let (xs,ys) = break (=='=') (dropWhile isSpace s)
-        (zs,ws) = break (==';') (dropWhile isSpace (drop 1 ys))
-     in if null xs then [] else (xs,zs):readCookies (drop 1 ws)
-
---
--- Utilities
---
-
--- | Return 'Nothing' is the list is empty, otherwise return
---   the last element of the list.
-maybeLast :: [a] -> Maybe a
-maybeLast [] = Nothing
-maybeLast xs = Just (last xs)
− src/Network/CGI/Monad.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Network.CGI.Monad
--- Copyright   :  (c) Bjorn Bringert 2006
--- License     :  BSD-style
---
--- Maintainer  :  John Chee <cheecheeo@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Internal stuff that most people shouldn't have to use.
--- This module mostly deals with the
--- internals of the CGIT monad transformer.
---
------------------------------------------------------------------------------
-
-module Network.CGI.Monad (
-  -- * CGI monad class
-  MonadCGI(..),
-  -- * CGI monad transformer
-  CGIT(..), CGI,
-  runCGIT,
-  -- * Request info
-  CGIRequest(..),
-  -- * Error handling
-  throwCGI, catchCGI, tryCGI, handleExceptionCGI,
- ) where
-
-import Control.Applicative (Applicative(..))
-import Control.Exception as Exception (SomeException)
-import Control.Monad (liftM)
-import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, throwM, catch, try, mask, uninterruptibleMask)
-import Control.Monad.Error (MonadError(..))
-import Control.Monad.Reader (ReaderT(..), asks)
-import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift)
-import Control.Monad.Writer (WriterT(..), tell)
-import Prelude hiding (catch)
--- #if MIN_VERSION_base(4,7,0)
--- import Data.Typeable
--- #else
--- import Data.Typeable (Typeable(..), Typeable1(..),
---                       mkTyConApp, mkTyCon)
--- #endif
-
-import Network.CGI.Protocol
-
---
--- * CGIT monad transformer
---
-
--- | A simple CGI monad with just IO.
-type CGI a = CGIT IO a
-
--- | The CGIT monad transformer.
-newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a }
--- #if MIN_VERSION_base(4,7,0)
--- 			deriving (Typeable)
---
--- #else
--- instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where
---     typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT")
---                 [typeOf1 (undefined :: m a), typeOf (undefined :: a)]
--- #endif
-
-instance (Functor m, Monad m) => Functor (CGIT m) where
-    fmap f c = CGIT (fmap f (unCGIT c))
-
-instance (Applicative m, Monad m) => Applicative (CGIT m) where
-    pure = CGIT . pure
-    f <*> x = CGIT (unCGIT f <*> unCGIT x)
-
-instance Monad m => Monad (CGIT m) where
-    c >>= f = CGIT (unCGIT c >>= unCGIT . f)
-    return = CGIT . return
-    -- FIXME: should we have an error monad instead?
-    fail = CGIT . fail
-
-instance MonadIO m => MonadIO (CGIT m) where
-    liftIO = lift . liftIO
-
-instance MonadThrow m => MonadThrow (CGIT m) where
-    throwM e = CGIT . throwM $ e
-
-instance MonadCatch m => MonadCatch (CGIT m) where
-    CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h)
-
-instance MonadMask m => MonadMask (CGIT m) where
-    mask a = CGIT $ mask $ \u -> unCGIT $ a $ CGIT . u . unCGIT
-    uninterruptibleMask a = CGIT $ uninterruptibleMask $ \u -> unCGIT $ a $ CGIT . u . unCGIT
-
--- | The class of CGI monads. Most CGI actions can be run in
---   any monad which is an instance of this class, which means that
---   you can use your own monad transformers to add extra functionality.
-class Monad m => MonadCGI m where
-    -- | Add a response header.
-    cgiAddHeader :: HeaderName -> String -> m ()
-    -- | Get something from the CGI request.
-    cgiGet :: (CGIRequest -> a) -> m a
-
-instance Monad m => MonadCGI (CGIT m) where
-    cgiAddHeader n v = CGIT $ lift $ tell [(n,v)]
-    cgiGet = CGIT . asks
-
-instance MonadTrans CGIT where
-    lift = CGIT . lift . lift
-
--- | Run a CGI action.
-runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a)
-runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c
-
---
--- * Error handling
---
-
-instance MonadCatch m => MonadError SomeException (CGIT m) where
-    throwError = throwM
-    catchError = catch
-
--- | Throw an exception in a CGI monad. The monad is required to be
---   a 'MonadThrow', so that we can use 'throwM' to guarantee ordering.
-throwCGI :: (MonadCGI m, MonadThrow m) => SomeException -> m a
-throwCGI = throwM
-
--- | Catches any expection thrown by a CGI action, and uses the given
---   exception handler if an exception is thrown.
-catchCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a
-catchCGI = catch
-
--- | Catches any exception thrown by an CGI action, and returns either
---   the exception, or if no exception was raised, the result of the action.
-tryCGI :: (Functor m, MonadCGI m, MonadCatch m) => m a -> m (Either SomeException a)
-tryCGI = try
-
-{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-}
--- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead.
-handleExceptionCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a
-handleExceptionCGI = catchCGI
− src/Network/CGI/Protocol.hs 
@@ -1,317 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Network.CGI.Protocol
--- Copyright   :  (c) Bjorn Bringert 2006
--- License     :  BSD-style
---
--- Maintainer  :  John Chee <cheecheeo@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- An implementation of the program side of the CGI protocol.
---
------------------------------------------------------------------------------
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
-module Network.CGI.Protocol (
-  -- * CGI request
-  CGIRequest(..), Input(..),
-  -- * CGI response
-  CGIResult(..),
-  Headers, HeaderName(..),
-  -- * Running CGI actions
-  hRunCGI, runCGIEnvFPS,
-  -- * Inputs
-  decodeInput, takeInput,
-  -- * Environment variables
-  getCGIVars,
-  -- * Logging
-  logCGI,
-  -- * URL encoding
-  formEncode, urlEncode, formDecode, urlDecode,
-  -- * Utilities
-  maybeRead, replace
- ) where
-
-import Control.Monad.Trans (MonadIO(..))
-import Data.List (intersperse)
-import Data.Map (Map)
-import Data.Maybe (fromMaybe, listToMaybe, isJust)
-import Network.URI (unEscapeString,escapeURIString,isUnescapedInURI)
-import System.Environment (getEnvironment)
-import System.IO (Handle, hPutStrLn, stderr, hFlush, hSetBinaryMode)
-import qualified Data.Map as Map
-
-import Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as BS
-
--- #if MIN_VERSION_base(4,7,0)
--- import Data.Typeable
--- #else
--- import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon)
--- #endif
-
-import Network.Multipart
-
---
--- * CGI request
---
-
--- | The input to a CGI action.
-data CGIRequest =
-    CGIRequest {
-                -- | Environment variables.
-                cgiVars :: Map String String,
-                -- | Input parameters. For better laziness in reading inputs,
-                --   this is not a Map.
-                cgiInputs :: [(String, Input)],
-                -- | Raw request body. To avoid memory leaks,
-                -- this is the empty string if the request body has been
-                -- interpreted as inputs in
-                -- "application\/x-www-form-urlencoded" or
-                -- "multipart\/form-data" format.
-                cgiRequestBody :: ByteString
-               }
-    deriving (Show)
-
--- #if ! MIN_VERSION_base(4,7,0)
--- instance Typeable CGIResult where
---     typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") []
--- #endif
-
--- | The value of an input parameter, and some metadata.
-data Input = Input {
-                    inputValue :: ByteString,
-                    inputFilename :: Maybe String,
-                    inputContentType :: ContentType
-                   }
-              deriving Show
-
---
--- * CGI response
---
-
--- | The result of a CGI program.
-data CGIResult = CGIOutput ByteString
-               | CGINothing
--- #if MIN_VERSION_base(4,7,0)
---                  deriving (Show, Read, Eq, Ord, Typeable)
--- #else
-                 deriving (Show, Read, Eq, Ord)
--- #endif
-
---
--- * Running CGI actions
---
-
--- | Runs a CGI action in a given environment. Uses Handles for input and output.
-hRunCGI :: MonadIO m =>
-           [(String,String)] -- ^ CGI environment variables, e.g. from 'getCGIVars'.
-        -> Handle -- ^ Handle that input will be read from, e.g. 'System.IO.stdin'.
-        -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'.
-        -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action
-        -> m ()
-hRunCGI env hin hout f =
-    do liftIO $ hSetBinaryMode hin True
-       inp <- liftIO $ BS.hGetContents hin
-       outp <- runCGIEnvFPS env inp f
-       liftIO $ BS.hPut hout outp
-       liftIO $ hFlush hout
-
--- | Runs a CGI action in a given environment. Uses lazy ByteStrings
---   for input and output.
-runCGIEnvFPS :: Monad m =>
-             [(String,String)] -- ^ CGI environment variables.
-          -> ByteString -- ^ Request body.
-          -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action.
-          -> m ByteString -- ^ Response (headers and content).
-runCGIEnvFPS vars inp f
-    = do let (inputs,body) = decodeInput vars inp
-         (hs,outp) <- f $ CGIRequest {
-                                      cgiVars = Map.fromList vars,
-                                      cgiInputs = inputs,
-                                      cgiRequestBody = body
-                                     }
-         return $ case outp of
-           CGIOutput c -> formatResponse c hs'
-               where hs' = if isJust (lookup ct hs)
-                              then hs else hs ++ [(ct,defaultContentType)]
-                     ct = HeaderName "Content-type"
-           CGINothing -> formatResponse BS.empty hs
-
-formatResponse :: ByteString -> Headers -> ByteString
-formatResponse c hs =
-    -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle
-    -- just LF if there are CRs in the content.
-    unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs]
-                ++ [BS.empty,c])
-  where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")
-
-defaultContentType :: String
-defaultContentType = "text/html; charset=ISO-8859-1"
-
---
--- * Inputs
---
-
--- | Gets and decodes the input according to the request
---   method and the content-type.
-decodeInput :: [(String,String)] -- ^ CGI environment variables.
-            -> ByteString        -- ^ Request body.
-            -> ([(String,Input)],ByteString)
-               -- ^ A list of input variables and values, and the request body
-               -- if it was not interpreted.
-decodeInput env inp =
-  let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body)
-
--- | Builds an 'Input' object for a simple value.
-simpleInput :: String -> Input
-simpleInput v = Input { inputValue = BS.pack v,
-                        inputFilename = Nothing,
-                        inputContentType = defaultInputType }
-
--- | The default content-type for variables.
-defaultInputType :: ContentType
-defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?
-
---
--- * Environment variables
---
-
--- | Gets the values of all CGI variables from the program environment.
-getCGIVars :: MonadIO m => m [(String,String)]
-getCGIVars = liftIO getEnvironment
-
---
--- * Logging
---
-
--- | Logs some message using the server\'s logging facility.
--- FIXME: does this have to be more general to support
--- FastCGI etc? Maybe we should store log messages in the
--- CGIState?
-logCGI :: MonadIO m => String -> m ()
-logCGI s = liftIO (hPutStrLn stderr s)
-
---
--- * Query string
---
-
--- | Gets inputs from the query string.
-queryInput :: [(String,String)] -- ^ CGI environment variables.
-           -> [(String,Input)] -- ^ Input variables and values.
-queryInput env = formInput $ lookupOrNil "QUERY_STRING" env
-
--- | Decodes application\/x-www-form-urlencoded inputs.
-formInput :: String
-          -> [(String,Input)] -- ^ Input variables and values.
-formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs]
-
---
--- * URL encoding
---
-
--- | Formats name-value pairs as application\/x-www-form-urlencoded.
-formEncode :: [(String,String)] -> String
-formEncode xs =
-    concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs]
-
--- | Converts a single value to the application\/x-www-form-urlencoded encoding.
-urlEncode :: String -> String
-urlEncode = replace ' ' '+' . escapeURIString okChar
-  where okChar c = c == ' ' ||
-                   (isUnescapedInURI c && c `notElem` "&=+")
-
--- | Gets the name-value pairs from application\/x-www-form-urlencoded data.
-formDecode :: String -> [(String,String)]
-formDecode "" = []
-formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)
-    where (nv,rs) = break (=='&') s
-          (n,v) = break (=='=') nv
-
--- | Converts a single value from the
---   application\/x-www-form-urlencoded encoding.
-urlDecode :: String -> String
-urlDecode = unEscapeString . replace '+' ' '
-
---
--- * Request content and form-data stuff
---
-
--- | Gets input variables from the body, if any.
-bodyInput :: [(String,String)]
-          -> ByteString
-          -> ([(String,Input)], ByteString)
-bodyInput env inp =
-   case lookup "REQUEST_METHOD" env of
-      Just "POST" ->
-          let ctype = lookup "CONTENT_TYPE" env >>= parseContentType
-           in decodeBody ctype $ takeInput env inp
-      _ -> ([], inp)
-
--- | Decodes a POST body.
-decodeBody :: Maybe ContentType
-           -> ByteString
-           -> ([(String,Input)], ByteString)
-decodeBody ctype inp =
-    case ctype of
-               Just (ContentType "application" "x-www-form-urlencoded" _)
-                   -> (formInput (BS.unpack inp), BS.empty)
-               Just (ContentType "multipart" "form-data" ps)
-                   -> (multipartDecode ps inp, BS.empty)
-               Just _ -> ([], inp) -- unknown content-type, the user will have to
-                            -- deal with it by looking at the raw content
-               -- No content-type given, assume x-www-form-urlencoded
-               Nothing -> (formInput (BS.unpack inp), BS.empty)
-
--- | Takes the right number of bytes from the input.
-takeInput :: [(String,String)]  -- ^ CGI environment variables.
-          -> ByteString         -- ^ Request body.
-          -> ByteString         -- ^ CONTENT_LENGTH bytes from the request
-                                --   body, or the empty string if there is no
-                                --   CONTENT_LENGTH.
-takeInput env req =
-    case len of
-           Just l  -> BS.take l req
-           Nothing -> BS.empty
-     where len = lookup "CONTENT_LENGTH" env >>= maybeRead
-
--- | Decodes multipart\/form-data input.
-multipartDecode :: [(String,String)] -- ^ Content-type parameters
-                -> ByteString        -- ^ Request body
-                -> [(String,Input)]  -- ^ Input variables and values.
-multipartDecode ps inp =
-    case lookup "boundary" ps of
-         Just b -> let MultiPart bs = parseMultipartBody b inp
-                    in map bodyPartToInput bs
-         Nothing -> [] -- FIXME: report that there was no boundary
-
-bodyPartToInput :: BodyPart -> (String,Input)
-bodyPartToInput (BodyPart hs b) =
-    case getContentDisposition hs of
-              Just (ContentDisposition "form-data" ps) ->
-                  (lookupOrNil "name" ps,
-                   Input { inputValue = b,
-                           inputFilename = lookup "filename" ps,
-                           inputContentType = ctype })
-              _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error
-    where ctype = fromMaybe defaultInputType (getContentType hs)
-
---
--- * Utilities
---
-
--- | Replaces all instances of a value in a list by another value.
-replace :: Eq a =>
-           a   -- ^ Value to look for
-        -> a   -- ^ Value to replace it with
-        -> [a] -- ^ Input list
-        -> [a] -- ^ Output list
-replace x y = map (\z -> if z == x then y else z)
-
-maybeRead :: Read a => String -> Maybe a
-maybeRead = fmap fst . listToMaybe . reads
-
--- | Same as 'lookup' specialized to strings, but
---   returns the empty string if lookup fails.
-lookupOrNil :: String -> [(String,String)] -> String
-lookupOrNil n = fromMaybe "" . lookup n