packages feed

Dao 0.0.0.0 → 0.1.0.2

raw patch · 27 files changed

+20532/−821 lines, 27 filesdep +Cryptodep +arraydep +binarydep ~base

Dependencies added: Crypto, array, binary, bytestring, containers, data-binary-ieee754, deepseq, directory, filepath, mtl, process, random, time, transformers, utf8-string

Dependency ranges changed: base

Files

Dao.cabal view
@@ -1,29 +1,98 @@-Name: Dao-Version: 0.0.0.0-Cabal-Version: >= 1.6-Copyright: 2008-2009, Ramin Honary-License: GPL-License-File: LICENSE-Author: Ramin Honary <ramin.honary@gmail.com>-Maintainer: ramin.honary@gmail.com-Homepage: -Synopsis: An interactive knowledge base, natural language interpreter.-Description:-        This program is still largely incomplete.-        Dao is an artificial intelligence program which allows users to construct-        a knowledge base for intepreting natural language input. The idea is to-        let users interactively build their own knowledge base by adding rules at-        runtime.  The state of the knowledge base can be updated by enacting it's-        own production rules, or by a user entering commands to alter the state-        directly. Regular-expression-like patterns are associated with rules so-        natural language input can be used to invoke rules at any time.-Category: AI-Build-Type: Simple+-- "dao.cabal" The metafile for building the Dao System using Cabal.+-- +-- Copyright (C) 2008-2012  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>. -Extra-Source-Files: README +Name:          Dao+Version:       0.1.0.2+Cabal-Version: >= 1.10+License:       GPL-3+Copyright:     (C) 2008-2014 Ramin Honary, all rights reserved.+Author:        Ramin Honary+Maintainer:    ramin.honary@gmail.com+Build-Type:    Simple+Synopsis:      Dao is meta programming language with its own built-in+               interpreted language, designed with artificial+               intelligence applications in mind.+Description:+     The Dao modules and interactive program is a meta programming language+     intended for artificial intelligence uses. It is very much like the+     classic UNIX "AWK" scripting language, but instead of using POSIX-style+     regular epxressions, the patterns used in Dao are designed to more easily+     match natural language input.+Library+  HS-source-dirs:   src+  Default-Language: Haskell2010+  GHC-options:      -threaded -Wall+    -fno-warn-name-shadowing+    -fno-warn-unused-do-bind+  Build-Depends:+    base                == 4.*    ,  mtl        >= 2.0.1.0,  random     >= 1.0.0.1,+    time                >= 1.4.2  ,  directory  >= 1.1.0.0,  filepath   >= 1.2.0.0,+    process             >= 1.0.1.2,  array      >= 0.3.0.2,  bytestring >= 0.9.1.2,+    utf8-string         >= 0.3.2  ,  binary     >= 0.5.0.2,  Crypto     >= 4.0.0.0,+    transformers        >= 0.2.2.0,  containers >= 0.4.0.0,  deepseq    >= 1.0.0.0,+    data-binary-ieee754 >= 0.4.4+  Default-Extensions:+    TemplateHaskell            ScopedTypeVariables        RankNTypes                 +    MultiParamTypeClasses      FunctionalDependencies     FlexibleInstances          +    FlexibleContexts           DeriveFunctor              DeriveDataTypeable         +    GeneralizedNewtypeDeriving +  Exposed-Modules:+    Dao.Interval, Dao.Tree     , Dao.RefTable   , Dao.Random  ,+    Dao.StepList, Dao.Predicate, Dao.Binary     , Dao.HashMap ,+    Dao.String  , Dao.Stack    , Dao.PPrint     , Dao.Parser  ,+    Dao.Token   , Dao.Glob     , Dao.Interpreter, Dao.Lib.File,+    Dao.Lib.ListEditor, Dao.Lib.Array,+    Dao.Interpreter.Tokenizer, Dao.Interpreter.AST, Dao.Interpreter.Parser+ Executable dao-  Main-is: Main.hs-  Build-Depends: base-  Hs-Source-Dirs: .-  GHC-Options: -Wall+  HS-source-dirs: src+  Main-is: dao-main.hs+  Default-language: Haskell2010+  Build-Depends:+    base                >= 4.3.1.0,  mtl        >= 2.0.1.0,  random     >= 1.0.0.1,+    time                >= 1.4.2  ,  directory  >= 1.1.0.0,  filepath   >= 1.2.0.0,+    process             >= 1.0.1.2,  array      >= 0.3.0.2,  bytestring >= 0.9.1.2,+    utf8-string         >= 0.3.2  ,  binary     >= 0.5.0.2,  Crypto     >= 4.0.0.0,+    transformers        >= 0.2.2.0,  containers >= 0.4.0.0,  deepseq    >= 1.0.0.0,+    data-binary-ieee754 >= 0.4.4+  Default-Extensions:+    TemplateHaskell            ScopedTypeVariables        RankNTypes                 +    MultiParamTypeClasses      FunctionalDependencies     FlexibleInstances          +    FlexibleContexts           DeriveFunctor              DeriveDataTypeable         +    GeneralizedNewtypeDeriving ++Test-suite main+  HS-source-dirs:   tests+  Main-is:          main.hs+  Default-language: Haskell2010+  Type: exitcode-stdio-1.0+  Build-Depends:+    base                >= 4.3.1.0,  mtl        >= 2.0.1.0,  random     >= 1.0.0.1,+    time                >= 1.4.2  ,  directory  >= 1.1.0.0,  filepath   >= 1.2.0.0,+    process             >= 1.0.1.2,  array      >= 0.3.0.2,  bytestring >= 0.9.1.2,+    utf8-string         >= 0.3.2  ,  binary     >= 0.5.0.2,  Crypto     >= 4.0.0.0,+    transformers        >= 0.2.2.0,  containers >= 0.4.0.0,  deepseq    >= 1.0.0.0,+    data-binary-ieee754 >= 0.4.4+  Extensions:+    TemplateHaskell            ScopedTypeVariables        RankNTypes                 +    MultiParamTypeClasses      FunctionalDependencies     FlexibleInstances          +    FlexibleContexts           DeriveFunctor              DeriveDataTypeable         +    GeneralizedNewtypeDeriving +
− LICENSE 
@@ -1,674 +0,0 @@-                    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.--  If, pursuant to or in connection with a single transaction or-arrangement, you convey, or propagate by procuring conveyance of, a-covered work, and grant a patent license to some of the parties-receiving the covered work authorizing them to use, propagate, modify-or convey a specific copy of the covered work, then the patent license-you grant is automatically extended to all recipients of the covered-work and works based on it.--  A patent license is "discriminatory" if it does not include within-the scope of its coverage, prohibits the exercise of, or is-conditioned on the non-exercise of one or more of the rights that are-specifically granted under this License.  You may not convey a covered-work if you are a party to an arrangement with a third party that is-in the business of distributing software, under which you make payment-to the third party based on the extent of your activity of conveying-the work, and under which the third party grants, to any of the-parties who would receive the covered work from you, a discriminatory-patent license (a) in connection with copies of the covered work-conveyed by you (or copies made from those copies), or (b) primarily-for and in connection with specific products or compilations that-contain the covered work, unless you entered into that arrangement,-or that patent license was granted, prior to 28 March 2007.--  Nothing in this License shall be construed as excluding or limiting-any implied license or other defenses to infringement that may-otherwise be available to you under applicable patent law.--  12. No Surrender of Others' Freedom.--  If conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License.  If you cannot convey a-covered work so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you may-not convey it at all.  For example, if you agree to terms that obligate you-to collect a royalty for further conveying from those to whom you convey-the Program, the only way you could satisfy both those terms and this-License would be to refrain entirely from conveying the Program.--  13. Use with the GNU Affero General Public License.--  Notwithstanding any other provision of this License, you have-permission to link or combine any covered work with a work licensed-under version 3 of the GNU Affero General Public License into a single-combined work, and to convey the resulting work.  The terms of this-License will continue to apply to the part which is the covered work,-but the special requirements of the GNU Affero General Public License,-section 13, concerning interaction through a network will apply to the-combination as such.--  14. Revised Versions of this License.--  The Free Software Foundation may publish revised and/or new versions of-the GNU General Public License from time to time.  Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.--  Each version is given a distinguishing version number.  If the-Program specifies that a certain numbered version of the GNU General-Public License "or any later version" applies to it, you have the-option of following the terms and conditions either of that numbered-version or of any later version published by the Free Software-Foundation.  If the Program does not specify a version number of the-GNU General Public License, you may choose any version ever published-by the Free Software Foundation.--  If the Program specifies that a proxy can decide which future-versions of the GNU General Public License can be used, that proxy's-public statement of acceptance of a version permanently authorizes you-to choose that version for the Program.--  Later license versions may give you additional or different-permissions.  However, no additional obligations are imposed on any-author or copyright holder as a result of your choosing to follow a-later version.--  15. Disclaimer of Warranty.--  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY-APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM-IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.--  16. Limitation of Liability.--  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF-SUCH DAMAGES.--  17. Interpretation of Sections 15 and 16.--  If the disclaimer of warranty and limitation of liability provided-above cannot be given local legal effect according to their terms,-reviewing courts shall apply local law that most closely approximates-an absolute waiver of all civil liability in connection with the-Program, unless a warranty or assumption of liability accompanies a-copy of the Program in return for a fee.--                     END OF TERMS AND CONDITIONS--            How to Apply These Terms to Your New Programs--  If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these terms.--  To do so, attach the following notices to the program.  It is safest-to attach them to the start of each source file to most effectively-state the exclusion of warranty; and each file should have at least-the "copyright" line and a pointer to where the full notice is found.--    <one line to give the program's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    This program is free software: you can redistribute it and/or modify-    it under the terms of the GNU General Public License as published by-    the Free Software Foundation, either version 3 of the License, or-    (at your option) any later version.--    This program is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-    GNU General Public License for more details.--    You should have received a copy of the GNU General Public License-    along with this program.  If not, see <http://www.gnu.org/licenses/>.--Also add information on how to contact you by electronic and paper mail.--  If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:--    <program>  Copyright (C) <year>  <name of author>-    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.-    This is free software, and you are welcome to redistribute it-    under certain conditions; type `show c' for details.--The hypothetical commands `show w' and `show c' should show the appropriate-parts of the General Public License.  Of course, your program's commands-might be different; for a GUI interface, you would use an "about box".--  You should also get your employer (if you work as a programmer) or school,-if any, to sign a "copyright disclaimer" for the program, if necessary.-For more information on this, and how to apply and follow the GNU GPL, see-<http://www.gnu.org/licenses/>.--  The GNU General Public License does not permit incorporating your program-into proprietary programs.  If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications with-the library.  If this is what you want to do, use the GNU Lesser General-Public License instead of this License.  But first, please read-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
− Main.hs 
@@ -1,73 +0,0 @@-{- Main -- The main source of the Dao program.- - Copyright (C) March 6, 2009, Ramin Honary- -- - The main source of the Dao program. This file contains little more than the main- - function, a function to manage input arguments and the environment, and then a- - run loop which calls the "readline" library and passes the string input to the Dao- - runtime interpreter in the "Dao.hs" source file.- -- - THIS PROGRAM IS INCOMPLETE AS OF: March 15, 2009- - ------------------------------------------------- -- - This program is free software: you can redistribute it and/or modify- - it under the terms of the GNU General Public License as published by- - the Free Software Foundation, either version 3 of the License, or- - (at your option) any later version.- -- - This program is distributed in the hope that it will be useful,- - but WITHOUT ANY WARRANTY; without even the implied warranty of- - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the- - GNU General Public License for more details.- -- - You should have received a copy of the GNU General Public License- - along with this program.  If not, see <http://www.gnu.org/licenses/>.- -- - Licensed under the GNU General Public License <http://www.gnu.org/licenses/gpl.html>- -}--module Dao where---- import qualified Data.Map as Map--- import qualified Data.Set as Set--import System-import System.Environment-import System.Console.Readline-import System.IO--- import System.IO.Error--- import System.Process--import Ramins_mod-import Errst-import Parser_st-import Dao_base_parser-import Dao_base-import Dao-----------1---------2---------3---------4---------5---------6---------7---------8---------9--------10--{- Take an input string from the "readline" library routine, run the "dao" state with that input- - string, then loop. If the "dao" state comes back with it's on-off switch set to False, return- - control to the main function and (presumably) quit the program.  -}-run_loop :: Dao -> IO ()-run_loop  dao = do-  if (onoff_switch dao)-    then do-      instr <- readline ">> "-      case instr of-        Nothing -> return ()-        (Just instr) -> do-          dao1 <- apply_string_input instr dao-          run_loop dao1-    else return ()--manage_args :: [String] -> [(String, String)] -> IO Dao-manage_args args env = do-  return (Dao True args env [Map.empty] Map.empty Map.empty [] [] [])--main = do-  args <- getArgs-  env <- getEnvironment-  dao <- manage_args args env-  run_loop dao-
− README 
@@ -1,48 +0,0 @@-Dao -- An interactive knowledge base, natural language interpreter.-Copyright (C) March 25, 2009, Ramin Honary--This program is my first attempt to re-write my entire Master's thesis-as a Haskell program. It was initially written in C, and then when I-realized I couldn't finish my project in time making it in C, I switched-to Perl. I completed my thesis, but I was largely unsatisfied with my-work and continued to make improvements. Then I discovered Haskell and-decided it was the best way to make it work. I would like to publish the-work I have completed so far so I can continue to make improvements-publicly and with an open source license, the GPL.--Dao is an artificial intelligence program which allows users to construct-a knowledge base for intepreting natural language input. The idea is to-let users interactively build their own knowledge base by adding rules at-runtime.  The state of the knowledge base can be updated by enacting it's-own production rules, or by a user entering commands to alter the state-directly. Regular-expression-like patterns are associated with rules so-natural language input can be used to invoke rules at any time.--Because the knowledge base is built interactively, it is very simple to-define a new regular expression production rule and test it out-immediately, to see if it interferes with other production rules in the-knowledge base, or to see if the regular expression was defined-correctly.--A future release of this program should be able to deduce regular-expressions and production rules without requiring the users to define-regular expressions directly.--THIS PROGRAM IS INCOMPLETE AS OF: March 15, 2009---------------------------------------------------This program is free software: you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation, either version 3 of the License, or-(at your option) any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program.  If not, see <http://www.gnu.org/licenses/>.--(See the file "LICENSE" included in the same directory with this file.)-
+ src/Dao/Binary.hs view
@@ -0,0 +1,640 @@+-- "src/Dao/Binary.hs"  declares the binary serializing monad.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module provides an essential wrapper around the 'Data.Binary.Binary' monad which allows a+-- binary serializer to read data type tags in the byte stream and select the next parser to be used+-- by looking up the parser with data type tag.+-- +-- Dao's binary protocol is compact and efficient, with every fundamental data type prefixed with a+-- single byte of information. Integers of arbitrary length are stored using Variable Length Integer+-- (VLI) encoding. However the byte stream is not compressed, and there are no functions in this+-- module which facilitate this, it is up to you to do compression. Using algorithms like GZip or+-- BZip2 will almost certainly decrese the size of the byte stream as Dao's binary protocol makes+-- no attempt to reduce data entropy.+--+-- Arbitrary data types can be encoded as long as they instantiate 'Data.Typeable.Typeable' and+-- 'Dao.Interpreter.ObjectInterface' and have been made available to the 'Dao.Interpreter.Runtime' during+-- initialization of the Dao program. Each new type placed in the stream creates an integer tag in+-- an index with the 'Data.Typeable.TypeRep', and every item of the type that is placed after that+-- tag is prefixed with the integer index value. When decoding, the index of tags is constructed on+-- the fly as they are read from arbitrary points in the stream, and the index is used to select the+-- correct binary decoder from the 'Dao.Interpreter.ObjectInterface' stored in the 'Dao.Interpreter.Runtime'.+-- +-- Of course, this module is not a full re-writing of "Data.Binary", it relies heavily on the+-- "Data.Binary" module, and provides a Dao-friendly wrapper around it.+module Dao.Binary where++import           Dao.String+import qualified Dao.Tree             as T+import           Dao.Token+import           Dao.Predicate++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Error+import qualified Control.Monad.State  as S++import           Data.Monoid+import           Data.Dynamic+import           Data.Char+import           Data.Int+import           Data.Ratio+import           Data.Complex+import           Data.Word+import           Data.Bits+import           Data.Time+import           Data.Array.IArray+import qualified Data.Map             as M+import qualified Data.IntMap          as Im+import qualified Data.Set             as S+import qualified Data.IntSet          as Is+import qualified Data.ByteString.Lazy as Z++import           Data.Digest.SHA1     as SHA1+import qualified Data.Binary.IEEE754  as B+import qualified Data.ByteString      as B+import qualified Data.Binary          as B+import qualified Data.Binary.Get      as B+import qualified Data.Binary.Put      as B++----------------------------------------------------------------------------------------------------++type Byte = Word8+type InStreamID = Word32+type ByteOffset = B.ByteOffset++-- | A data type used to help instantiate the 'Dao.Binary.Binary' class. Refer to the+-- 'fromDataBinary' function for more details.+data Serializer mtab a = Serializer{ serializeGet :: GGet mtab a, serializePut :: a -> GPutM mtab () }++-- | Minimal complete definition is to either instantiate both 'get' and 'put', or to instnatiate+-- just 'serializer'. You can instantiate all three if you want but that may cause a lot of+-- confusion. Apart from 'serializer', it is identical to the 'Data.Binary.Binary' class, so please+-- refer to that module for more background information on how to use this one.+class Binary a mtab where+  get :: GGet mtab a+  get = serializeGet serializer+  put :: a -> GPutM mtab ()+  put = serializePut serializer+  serializer :: Serializer mtab a+  serializer = Serializer{serializeGet=Dao.Binary.get,serializePut=Dao.Binary.put}++class HasCoderTable mtab where+  getEncoderForType :: Name -> mtab -> Maybe (Dynamic -> GPut mtab)+  getDecoderForType :: Name -> mtab -> Maybe (GGet mtab Dynamic)++-- | To evaluate a 'GPut' or 'GGet' function without providing any coder table, simply pass @()@.+instance HasCoderTable () where+  getEncoderForType _ _ = Nothing+  getDecoderForType _ _ = Nothing++data EncodeIndex mtab+  = EncodeIndex+    { indexCounter :: InStreamID+    , encodeIndex  :: M.Map Name InStreamID+    , encMTabRef   :: mtab+    }++data DecodeIndex mtab+  = DecodeIndex+    { decodeIndex  :: M.Map InStreamID Name+    , decMTabRef   :: mtab+    }++newtype GPutM mtab a = PutM{ encoderToStateT :: S.StateT (EncodeIndex mtab) B.PutM a }+type GPut mtab = GPutM mtab ()++data GGetErr = GetErr { gGetErrOffset :: ByteOffset, gGetErrMsg :: UStr }+instance Show GGetErr where { show (GetErr ofst msg) = "(offset="++show ofst++") "++uchars msg }++newtype GGet mtab a = Get{ decoderToStateT :: PredicateT GGetErr (S.StateT (DecodeIndex mtab) B.Get) a }++instance Functor (GPutM mtab) where { fmap f (PutM a) = PutM (fmap f a) }+instance Monad (GPutM mtab) where+  return = PutM . return+  (PutM a) >>= fn = PutM (a >>= encoderToStateT . fn)+  fail = PutM . fail+instance Applicative (GPutM mtab) where { pure=return; (<*>)=ap; }+instance Monoid a => Monoid (GPutM mtab a) where+  mempty=return mempty+  mappend a b = a >>= \a -> b >>= \b -> return (mappend a b)+instance HasCoderTable mtab => S.MonadState (EncodeIndex mtab) (GPutM mtab) where+  state fn = PutM (S.state fn)++instance Functor (GGet mtab) where { fmap f (Get a) = Get (fmap f a) }+instance Monad (GGet mtab) where+  return = Get . return+  (Get a) >>= fn = Get (a >>= decoderToStateT . fn)+  Get a >> Get b = Get (a >> b)+  fail msg = bytesRead >>= \ofst -> Get (throwError (GetErr ofst (toUStr msg)))+instance MonadPlus   (GGet mtab) where { mzero = Get mzero; mplus (Get a) (Get b) = Get (mplus a b); }+instance Applicative (GGet mtab) where { pure=return; (<*>)=ap;    }+instance Alternative (GGet mtab) where { empty=mzero; (<|>)=mplus; }+instance Monoid a => Monoid (GGet mtab a) where+  mempty=return mempty+  mappend a b = a >>= \a -> b >>= \b -> return (mappend a b)+instance S.MonadState (DecodeIndex mtab) (GGet mtab) where+  state = Get . lift . S.state+instance MonadError GGetErr (GGet mtab) where+  throwError = Get . throwError+  catchError (Get fn) catch = Get (catchError fn (decoderToStateT . catch))++-- | This class only exists to provide the the function 'getCoderTable' with the exact same function+-- in both the 'GPutM' and 'GGet' monads, rather than having a separate function for each monad.+class HasCoderTable mtab => ProvidesCoderTable m mtab where { getCoderTable :: m mtab }+instance HasCoderTable mtab => ProvidesCoderTable (GPutM mtab) mtab where { getCoderTable = S.gets encMTabRef }+instance HasCoderTable mtab => ProvidesCoderTable (GGet  mtab) mtab where { getCoderTable = S.gets decMTabRef }++data InStreamIndex = InStreamIndex{ inStreamIndexID :: InStreamID, inStreamIndexLabel :: Name }+  deriving (Eq, Ord, Show)+instance HasCoderTable mtab => Binary InStreamIndex mtab where+  put (InStreamIndex a b) = prefixByte 0x01 $ put a >> put b+  get = tryWord8 0x01 $ pure InStreamIndex <*> get <*> get++-- | Find the 'Dao.String.UStr' that was associated with this 'InStreamID' when the byte stream was+-- constructed when 'newInStreamID' was called.+decodeIndexLookup :: HasCoderTable mtab => InStreamID -> GGet mtab (Maybe Name)+decodeIndexLookup tid = M.lookup tid <$> S.gets decodeIndex++-- | Given an 'Data.Int.Int64' length value, compute how many VLI bytes of hash code should be+-- necessary to for a byte stream of that length, and return an 'Data.Word.Word64' value trimmed to+-- that byte length.+trimIntegerHash :: Int64 -> Integer -> (Int, Integer)+trimIntegerHash i h = snd $ head $ dropWhile ((i<) . fst) $+  map (\x -> (2^(8+4*(fromIntegral x :: Int)), (x, h .&. (2^(7*x)-1)))) [0..14::Int]++-- | A trimmed hash is an hash produced by SHA1 along with the length of the original data. However+-- it instantiates 'Prelude.Eq', and 'Binary' in such a way that only a maximum of 5 bytes of the+-- hash value are ever stored and used for verification. This is to conserve space in a byte stream+-- when writing smaller chunks of data. For example, it is not necessary to store all 20 bytes of+-- the hash code when the data you are storing or reading is itself 20 bytes long.+data TrimmedHash = TrimmedHash Int64 Integer deriving (Eq, Ord)+instance Binary TrimmedHash mtab where+  put (TrimmedHash i h0) =+    let (len, h) = trimIntegerHash i h0+    in  if len>0 then putPosIntegral h else return ()+  get = TrimmedHash (error "TrimmedHash length not set") <$> getPosIntegral++-- | Create a 'TrimmedHash' a list of bytes as the second parameter and the maximum length of the+-- list as the first parameter.+trimmedHash :: Z.ByteString -> TrimmedHash+trimmedHash blk = mkTrimmedHash blk where+  len = Z.length blk+  mkTrimmedHash = TrimmedHash len . snd . trimIntegerHash len . SHA1.toInteger . hash .+    map snd . takeWhile ((>0) . fst) . zip (iterate (\x->x-1) len) . Z.unpack++-- not for export+setTrimmedHashLength :: Int64 -> TrimmedHash -> TrimmedHash+setTrimmedHashLength i (TrimmedHash _ h) = TrimmedHash i h++trimmedHashVerify :: Z.ByteString -> TrimmedHash -> Bool+trimmedHashVerify b = (trimmedHash b ==)++-- | A lazy block stream that wraps up a 'Data.ByteString.Lazy.ByteString' in a data type that+-- instantiates 'Binary' in such a way that the bytes are written lazily in chunks of 1 megabyte+-- blocks with checksums, providing a protocol that can encode and decode arbitrarily large data+-- without interfearing with the protocol used by this module.+newtype BlockStream1M = BlockStream1M { block1MStreamToByteString :: Z.ByteString }+instance Binary BlockStream1M mtab where+  put =+    mapM_ (\ blk -> put blk >> put (trimmedHash blk)+          ) . fix (\ loop blk ->+                      let (a,b) = Z.splitAt (2^(20::Int)) blk in a : if Z.null b then [] else loop b+                  ) . block1MStreamToByteString+  get = (BlockStream1M . Z.concat) <$> loop [] where+    loop bx = get >>= \b -> get >>= \cksum ->+      if trimmedHashVerify b (setTrimmedHashLength (Z.length b) cksum)+        then loop (bx++[b])+        else fail "bad checksum"++-- | If the type signature in the given 'Dao.String.UStr' already has an associated type ID in the+-- encoder table, the existing ID is returned rather than creating a new one, and nothing changes.+-- If a new ID is created, the 'Dao.String.UStr' is paired with the new ID and written to the byte+-- stream.+newInStreamID :: HasCoderTable mtab => Name -> GPutM mtab InStreamID+newInStreamID typ = S.get >>= \st -> let idx = encodeIndex st in case M.lookup typ idx of+  Nothing  -> do+    let nextID = indexCounter st + 1+    S.put $ st{indexCounter=nextID, encodeIndex=M.insert typ nextID idx}+    put $ InStreamIndex{inStreamIndexID=nextID, inStreamIndexLabel=typ}+    return nextID+  Just tid -> return tid++-- | When decoding a byte stream, it is up to you to check for the 'InStreamIndex'ies that are+-- scattered throughout. To do this, 'newInStreamID' is only called after a special escape byte+-- prefix is seen, for example, the byte prefix used when the 'Dao.Interpreter.OHaskell' constructor is+-- to be encoded. Once this prefix is decoded you should call 'newInStreamID'. That way, when you+-- are decoding the byte stream, you will know that 'updateTypes' must be called whenever you decode+-- the byte prefix for 'Dao.Interpreter.OHaskell'.+-- +-- This function simply checks if a 'InStreamIndex' exists at the current location in the byte+-- stream. If it does not exist, this function simply returns and does nothing. If it does exist,+-- the data is pulled out of the stream and the index is updated.+updateTypes :: HasCoderTable mtab => GGet mtab ()+updateTypes = tryWord8 0x01 $ do+  (InStreamIndex tid label) <- get+  S.modify $ \st -> st{decodeIndex = M.insert tid label (decodeIndex st)}++runPut :: HasCoderTable mtab => mtab -> GPut mtab -> Z.ByteString+runPut mtab fn = B.runPut $ S.evalStateT (encoderToStateT fn) $+  EncodeIndex{indexCounter=1, encodeIndex=mempty, encMTabRef=mtab}++runGet :: HasCoderTable mtab => mtab -> GGet mtab a -> Z.ByteString -> Predicate GGetErr a+runGet mtab fn = B.runGet $ S.evalStateT (runPredicateT $ decoderToStateT fn) $+  DecodeIndex{decodeIndex=mempty, decMTabRef=mtab}++encode :: (HasCoderTable mtab, Binary a mtab) => mtab -> a -> Z.ByteString+encode mtab = runPut mtab . put++decode :: (HasCoderTable mtab, Binary a mtab) => mtab -> Z.ByteString -> Predicate GGetErr a+decode mtab = runGet mtab get++encodeFile :: (HasCoderTable mtab, Binary a mtab) => mtab -> FilePath -> a -> IO ()+encodeFile mtab path = Z.writeFile path . encode mtab++decodeFile :: (HasCoderTable mtab, Binary a mtab) => mtab -> FilePath -> IO (Predicate GGetErr a)+decodeFile mtab path = decode mtab <$> Z.readFile path++putWithBlockStream1M :: HasCoderTable mtab => GPut mtab -> GPut mtab+putWithBlockStream1M fn = getCoderTable >>= \mtab -> put $ BlockStream1M $ runPut mtab fn++getWithBlockStream1M :: HasCoderTable mtab => GGet mtab a -> GGet mtab a+getWithBlockStream1M fn = do+  mtab <- getCoderTable+  (BlockStream1M bs1m) <- get+  Get (predicate (runGet mtab fn bs1m))++----------------------------------------------------------------------------------------------------++class (Ix i, Binary i mtab, Binary a mtab) => HasPrefixTable a i mtab where { prefixTable :: PrefixTable mtab i a }++-- | For data types with many constructors, especially enumerated types, it is effiecient if your+-- decoder performs a single look-ahead to retrieve an index, then use the index to lookup the next+-- parser in a table. This is a lookup table using 'Data.Array.IArray.Array' as the table which does+-- exactly that.+data PrefixTable mtab i a = PrefixTable String (Maybe (GGet mtab i)) (Maybe (Array i (GGet mtab a)))++instance Ix i => Functor (PrefixTable mtab i) where+  fmap f (PrefixTable msg getIdx t) = PrefixTable msg getIdx (fmap (amap (fmap f)) t)+instance (Integral i, Show i, Ix i, Binary a mtab) => Monoid (PrefixTable mtab i a) where+  mempty = PrefixTable "" Nothing Nothing+  mappend (PrefixTable msgA getIdxA a) (PrefixTable msgB getIdxB b) =+    PrefixTable (msgA<>"<>"<>msgB) (msum [getIdxA >> getIdxB, getIdxB, getIdxA]) $ msum $+      [ a >>= \a -> b >>= \b -> do+          let ((loA, hiA), (loB, hiB)) = (bounds    a, bounds    b)+          let ( lo       ,  hi       ) = (min loA loB, max hiA hiB)+          Just $ accumArray (flip mplus) mzero (lo, hi) (assocs a ++ assocs b)+      , a, b+      ]++-- | For each 'GGet' function stored in the 'PrefixTable', bind it to the function provided here and+-- store the bound functions back into the table. It works similar to the 'Control.Monad.>>='+-- function.+bindPrefixTable :: Ix i => PrefixTable mtab i a -> (a -> GGet mtab b) -> PrefixTable mtab i b+bindPrefixTable (PrefixTable msg getIdx arr) fn = PrefixTable msg getIdx (fmap (amap (>>=fn)) arr)++-- | Construct a 'Serializer' from a list of serializers, and each list item will be prefixed with a+-- byte in the range given. It is necesary for the data type to instantiate 'Data.Typeable.Typeable'+-- in order to +mkPrefixTable+  :: (Integral i, Show i, Ix i, Num i)+  => String -> GGet mtab i -> i -> i -> [GGet mtab a] -> PrefixTable mtab i a+mkPrefixTable msg getIdx lo' hi' ser =+  let len   = fromIntegral (length ser)+      lo    = min lo' hi'+      hi    = max lo' hi'+      idxs  = takeWhile (<=hi) (iterate (+1) lo)+      table = PrefixTable msg (Just getIdx) $ Just $+        accumArray (flip const) (fail ("in "++msg++" table")) (lo, hi) (zip idxs ser)+  in  if null ser+      then PrefixTable msg (Just getIdx) Nothing+      else+        if 0<len && len<=hi-lo+1+        then table+        else error ("too many prefix table items for mkPrefixTable for "++msg)++mkPrefixTableWord8 :: String -> Byte -> Byte -> [GGet mtab a] -> PrefixTable mtab Byte a+mkPrefixTableWord8 msg = mkPrefixTable msg getWord8++runPrefixTable :: (Integral i, Show i, Ix i, Binary i mtab) => PrefixTable mtab i a -> GGet mtab a+runPrefixTable (PrefixTable _msg getIdx t) = flip (maybe mzero) t $ \decoderArray -> do+  prefix <- lookAhead (maybe get id getIdx)+  guard $ inRange (bounds decoderArray) prefix+  prefix <- maybe get id getIdx+  decoderArray!prefix++word8PrefixTable :: HasPrefixTable a Byte mtab => GGet mtab a+word8PrefixTable = runPrefixTable (prefixTable :: HasPrefixTable a Byte mtab => PrefixTable mtab Byte a)++prefixByte :: Byte -> GPut mtab -> GPut mtab+prefixByte w fn = putWord8 w >> fn++-- | This is a polymorphic object that has been constructed using the instances of the canonical+-- 'Data.Binary.Binary'. This makes it possible to write your binary instances like so:+-- > import Data.Binary+-- > import Dao.Binary+-- > import MyObject -- exports data type MyObject which instantiates the canonical 'Data.Binary.Binary'.+-- > instance Dao.Binary.Binary MyObject where { serializer = fromDataBinary }+--+-- I cannot just use GHC's @UndecidableInstances@ feature to declare all type which instantiate the+-- canonical 'Data.Binary.Binary' to also instantiate my own 'Dao.Binary.Binary' because+-- I need my own versions of 'Data.Binary.get' and 'Data.Binary.put' for certain types like+-- 'Data.Maybe' and list types. So unfortunately, we are stuck declaring a new instance for every+-- data type that needs serialization.+fromDataBinary :: B.Binary a => Serializer mtab a+fromDataBinary =+  Serializer+  { serializeGet = dataBinaryGet B.get+  , serializePut = dataBinaryPut . B.put+  }++dataBinaryPut :: B.PutM a -> GPutM mtab a+dataBinaryPut = PutM . lift++dataBinaryGet :: B.Get a -> GGet mtab a+dataBinaryGet = Get . lift . lift++lookAhead :: GGet mtab a -> GGet mtab a+lookAhead (Get fn) = S.get >>= Get . lift . lift . B.lookAhead . S.evalStateT (runPredicateT fn) >>= Get . predicate++bytesRead :: GGet mtab ByteOffset+bytesRead = Get $ lift $ lift B.bytesRead++isEmpty :: GGet mtab Bool+isEmpty = dataBinaryGet B.isEmpty++putWord8 :: Word8 -> GPut mtab+putWord8    = PutM . lift . B.putWord8++putWord16be :: Word16 -> GPut mtab+putWord16be = PutM . lift . B.putWord16be++putWord16le :: Word16 -> GPut mtab+putWord16le = PutM . lift . B.putWord16le++putWord32be :: Word32 -> GPut mtab+putWord32be = PutM . lift . B.putWord32be++putWord32le :: Word32 -> GPut mtab+putWord32le = PutM . lift . B.putWord32le++putWord64be :: Word64 -> GPut mtab+putWord64be = PutM . lift . B.putWord64be++putWord64le :: Word64 -> GPut mtab+putWord64le = PutM . lift . B.putWord64le++getWord8 :: GGet mtab Word8+getWord8    = Get $ lift $ lift $ B.getWord8++getWord16be :: GGet mtab Word16+getWord16be = Get $ lift $ lift $ B.getWord16be++getWord16le :: GGet mtab Word16+getWord16le = Get $ lift $ lift $ B.getWord16le++getWord32be :: GGet mtab Word32+getWord32be = Get $ lift $ lift $ B.getWord32be++getWord32le :: GGet mtab Word32+getWord32le = Get $ lift $ lift $ B.getWord32le++getWord64be :: GGet mtab Word64+getWord64be = Get $ lift $ lift $ B.getWord64be++getWord64le :: GGet mtab Word64+getWord64le = Get $ lift $ lift $ B.getWord64le++putIntegral :: (Integral a, Bits a) => a -> GPut mtab+putIntegral = putInteger . fromIntegral++getIntegral :: (Integral a, Bits a) => GGet mtab a+getIntegral = fromIntegral <$> getInteger++putPosIntegral :: (Integral a, Bits a) => a -> GPut mtab+putPosIntegral = putPosInteger . fromIntegral++getPosIntegral :: (Integral a, Bits a) => GGet mtab a+getPosIntegral = fromIntegral <$> getPosInteger++putInteger :: Integer -> GPut mtab+putInteger = dataBinaryPut . vlPutInteger++getInteger :: GGet mtab Integer+getInteger = fmap fromIntegral $ dataBinaryGet vlGetInteger++putPosInteger :: Integer -> GPut mtab+putPosInteger = dataBinaryPut . vlPutPosInteger++getPosInteger :: GGet mtab Integer+getPosInteger = dataBinaryGet vlGetPosInteger++putByteString :: B.ByteString -> GPut mtab+putByteString = dataBinaryPut . B.putByteString++getByteString :: Int -> GGet mtab B.ByteString+getByteString = dataBinaryGet . B.getByteString++putLazyByteString :: Z.ByteString -> GPut mtab+putLazyByteString = dataBinaryPut . B.putLazyByteString++getLazyByteString :: Int64 -> GGet mtab Z.ByteString+getLazyByteString = dataBinaryGet . B.getLazyByteString++-- | Look ahead one byte, if the byte is the number you are expecting drop the byte and evaluate the+-- given 'GGet' function, otherwise backtrack.+tryWord8 :: Word8 -> GGet mtab a -> GGet mtab a+tryWord8 w fn = lookAhead getWord8 >>= guard . (w==) >> getWord8 >> fn++instance Binary Int8   mtab  where+  put = putWord8 . fromIntegral+  get = fmap fromIntegral getWord8+instance Binary Int16  mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }+instance Binary Int32  mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }+instance Binary Int64  mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }+instance Binary Int    mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }+instance Binary Word8  mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }+instance Binary Word16 mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }+instance Binary Word32 mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }+instance Binary Word64 mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }+instance Binary Word   mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }+instance Binary Float  mtab  where+  put = dataBinaryPut . B.putFloat32be+  get = dataBinaryGet B.getFloat32be+instance Binary Double mtab  where+  put = dataBinaryPut . B.putFloat64be+  get = dataBinaryGet B.getFloat64be+instance (RealFloat a, Binary a mtab) => Binary (Complex a) mtab where+  put (a :+ b) = put a >> put b+  get = pure (:+) <*> get <*> get++instance (Num a, Bits a, Integral a, Binary a mtab) => Binary (Ratio a) mtab where+  put o = putIntegral (numerator o) >> putPosIntegral (denominator o)+  get = pure (%) <*> getIntegral <*> getPosIntegral++instance Binary Integer mtab where { put = putInteger; get = getInteger; }+instance Binary Char    mtab where { put = putPosIntegral . ord; get = chr <$> getPosIntegral; }++instance Binary UTCTime mtab where+  put t = do+    put (toModifiedJulianDay (utctDay t))+    put (toRational (utctDayTime t))+  get = do+    d <- fmap ModifiedJulianDay get+    t <- fmap fromRational get+    return (UTCTime{ utctDay=d, utctDayTime=t })++instance Binary NominalDiffTime mtab where+  put t = put (toRational t)+  get = fmap fromRational get++instance Binary B.ByteString mtab where+  put o = putPosIntegral (B.length o) >> Dao.Binary.putByteString o+  get = getPosIntegral >>= Dao.Binary.getByteString++instance Binary Z.ByteString mtab where+  put o = putPosIntegral (Z.length o) >> Dao.Binary.putLazyByteString o+  get = getPosIntegral >>= Dao.Binary.getLazyByteString++instance (Binary a t, Binary b t) => Binary (a, b) t where+  put (a, b) = put a >> put b+  get = pure (,) <*> get <*> get+instance (Binary a t, Binary b t, Binary c t) => Binary (a, b, c) t where+  put (a, b, c) = put a >> put b >> put c+  get = pure (,,) <*> get <*> get <*> get+instance (Binary a t, Binary b t, Binary c t, Binary d t) => Binary (a, b, c, d) t where+  put (a, b, c, d) = put a >> put b >> put c >> put d+  get = pure (,,,) <*> get <*> get <*> get <*> get+instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t) => Binary (a, b, c, d, e) t where+  put (a, b, c, d, e) = put a >> put b >> put c >> put d >> put e+  get = pure (,,,,) <*> get <*> get <*> get <*> get <*> get+instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t) => Binary (a, b, c, d, e, f) t where+  put (a, b, c, d, e, f) = put a >> put b >> put c >> put d >> put e >> put f+  get = pure (,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get+instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t, Binary g t) => Binary (a, b, c, d, e, f, g) t where+  put (a, b, c, d, e, f, g) = put a >> put b >> put c >> put d >> put e >> put f >> put g+  get = pure (,,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get <*> get+instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t, Binary g t, Binary h t) => Binary (a, b, c, d, e, f, g, h) t where+  put (a, b, c, d, e, f, g, h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h+  get = pure (,,,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get++instance (Ord i, Binary i mtab, Binary a mtab) => Binary (M.Map   i a) mtab where { put = put . M.assocs ; get = M.fromList  <$> get; }+instance (                      Binary a mtab) => Binary (Im.IntMap a) mtab where { put = put . Im.assocs; get = Im.fromList <$> get; }+instance (Ord a,                Binary a mtab) => Binary (S.Set     a) mtab where { put = put . S.elems  ; get = S.fromList  <$> get; }+instance                                          Binary (Is.IntSet  ) mtab where { put = put . Is.elems ; get = Is.fromList <$> get; }++instance (Eq p, Ord p, Binary p mtab, Binary a mtab) => Binary (T.Tree p a) mtab where+  put t = case t of+    T.Void           -> prefixByte 0x00 $ return ()+    T.Leaf       a   -> prefixByte 0x01 $ put a+    T.Branch       t -> prefixByte 0x02 $ put t+    T.LeafBranch a t -> prefixByte 0x03 $ put a >> put t where+  get = word8PrefixTable++instance (Eq p, Ord p, Binary p mtab, Binary a mtab) => HasPrefixTable (T.Tree p a) Byte mtab where+  prefixTable = mkPrefixTableWord8 "Tree" 0x00 0x03 $+    [ return T.Void+    , T.Leaf   <$> get+    , T.Branch <$> get+    , pure T.LeafBranch <*> get <*> get+    ]++instance Binary () mtab where { get = return (); put () = return (); }++putNullTerm :: GPut mtab+putNullTerm = putWord8 0x00++getNullTerm :: GGet mtab ()+getNullTerm = tryWord8 0x00 $ return ()++instance Binary Bool mtab where+  put o = putWord8 (if o then 0x04 else 0x05)+  get   = word8PrefixTable+instance HasPrefixTable Bool Byte mtab where+  prefixTable = mkPrefixTableWord8 "Bool" 0x04 0x05 [return False, return True]++instance Binary a mtab => Binary (Maybe a) mtab where+  put = maybe (putWord8 0x00) (\o -> putWord8 0x01 >> put o) +  get = word8PrefixTable <|> fail "expecting Data.Maybe.Maybe"+instance Binary a mtab => HasPrefixTable (Maybe a) Byte mtab where+  prefixTable = mkPrefixTableWord8 "Maybe" 0x00 0x01 [return Nothing, Just <$> get]++instance Binary a mtab => Binary [a] mtab where+  put o = mapM_ (put . Just) o >> putNullTerm+  get   = concatMap (maybe [] return) <$> loop [] where+    loop ox = msum $+      [ getNullTerm >> return ox+        -- It is important to check for the null terminator first, then try to parse, that way the+        -- parser dose not backtrack (which may cause it to fail) if we are at a null terminator.+      , optional get >>= maybe (fail "expecting list element") (loop . (ox++) . (:[]))+      ]++-- | Like 'putUnwrapped' but takes an arbitrary binary encoder for encoding individual list+-- parameters.+putUnwrappedWith :: (a -> GPut mtab) -> [a] -> GPut mtab+putUnwrappedWith put list = mapM_ put list >> putNullTerm++-- | The inverse of 'getUnwrapped', this function is simply defined as:+-- > \list -> 'Control.Monad.mapM_' 'put' list >> 'putNullterm'+-- This is useful when you want to place a list of items, but you dont want to waste space on a+-- prefix byte for each list element. In lists of millions of elements, this can save you megabytes+-- of space, but placing any elements which are prefixed with a null byte will result in undefined+-- behavior when decoding.+putUnwrapped :: Binary a mtab => [a] -> GPut mtab+putUnwrapped = putUnwrappedWith put++-- | Like 'getUnwrapped' but takes an arbitrary binary decoder for encoding individual list+-- parameters.+getUnwrappedWith :: GGet mtab a -> GGet mtab [a]+getUnwrappedWith get = fix (\loop ox -> (getNullTerm >> return ox) <|> (get >>= \o -> loop (ox++[o]))) []++-- | The inverse of 'putUnwrapped', this function is simply defined as: 'Control.Applicative.many'+-- 'get' >>= \list -> 'getNullTerm' >> 'Control.Monad.return' list This assumes that+-- every element placed by 'get' has a non-null prefixed encoding. If any elements in the list might+-- be encoded such that they start with a 0x00 byte, the @'Control.Applicative.many'@ 'get'+-- expression will parse the null terminator of the list as though it were an element and continue+-- looping which results in undefined behavior. Examples of elements that may start with null @0x00@+-- bytes are 'Dao.String.UStr', 'Dao.String.Name', 'Prelude.Integer', or any 'Prelude.Integral' type.+getUnwrapped :: Binary a mtab => GGet mtab [a]+getUnwrapped = getUnwrappedWith get++instance Binary UStr mtab where+  put o = dataBinaryPut (B.put o)+  get = dataBinaryGet B.get++instance Binary Name mtab where+  put o = dataBinaryPut (B.put o)+  get = dataBinaryGet B.get++instance Binary Location mtab where+  put o = case o of+    LocationUnknown  -> return ()+    Location a b c d -> prefixByte 0x7F $ put a >> put b >> put c >> put d+  get = msum $+    [ isEmpty >>= guard >> return LocationUnknown+    , tryWord8 0x7F $ pure Location <*> get <*> get <*> get <*> get+    , return LocationUnknown+    ]+
+ src/Dao/Glob.hs view
@@ -0,0 +1,439 @@+-- "src/Dao/Glob.hs"  functions and data types related to the Glob+-- data type, for matching unix-like glob patterns to strings.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.+++{-# LANGUAGE DeriveDataTypeable #-}++-- | The 'Glob' expression data type is constructed by parsing a string containing a 'Glob'+-- expression. Reminscent of old-fashioned POSIX glob expressions that you would use in UNIX or+-- Linux systems on the command line (@ls *.hs@).+-- +-- Also of use is the 'PatternTree' type. This 'Dao.Tree.Tree' data type allows you to associate+-- arbitrary object values with 'Glob' expressions. You can insert 'Glob' expressions into a+-- 'PatternTree' with 'insertMultiPattern' and then use 'matchTree' to match a string expression.+-- Every pattern that matches will return the object value associated with it along with a+-- @'Dao.Tree.Tree' 'Dao.String.Name'@ mapping which substrings matched which wildcards.+-- +-- The syntax for a glob expression is just an arbitrary string with @'$'@ characters indicating+-- variables. A @'$'@ must be followed by at least one alphabetic or underscore character, and then+-- zero or more alphanumeric characters or underschore characters. These characters may then be+-- followed by a @'?'@. For example:+-- > "some text $wildcard more text"+-- > "some text $wildcard* more text"+-- > "some text $anyone? more text"+-- The first and second forms are identical, you may choose to follow a wildcard with a @'*'@ if you+-- want the 'Wildcard' variable to be followed by text with no space or punctuation in between.+-- 'Wildcard's match arbitrary-length sequences of string constants. For example, the above 'Glob'+-- containing the variable called @wildcard@ will match the following strings:+-- > "some text more text" -> a variable called "wildcard" is assigned an empty list+-- > "some text a more text" -> a variable called "wildcard" is assigned the list [a]+-- > "some text a b more text" -> a variable called "wildcard" is assigned the list [a b]+-- > "some text a b c more text" -> a variable called "wildcard" is assigned the list [a b c]+-- An 'AnyOne' variable matches any string constant, but one and only one. The following strings+-- will match the above example:+-- > "some text then more text" -> a variable called "anyone" is assigned the list [then]+-- > "some text with more text" -> a variable called "anyone" is assigned the list [with]+-- But the above exaple will not match:+-- > "some text more text"+-- > "some text then with more text"+-- Variable matched are stored in @('Dao.Tree.Tree' 'Dao.String.Name')@ structures.+-- +-- Glob expressions are wrappers around lists of 'GlobUnit's. Each 'GlobUnit' is a 'Wildcard',+-- 'AnyOne' variable, or a string constant called a 'Single'. It is called 'Single' rather than+-- 'Control.Applicative.Const' to avoid conflicting with the data type defined in the+-- "Control.Applicative" module.+-- +-- The data type used to store 'Single' string constants is polymorphic. So you can construct a+-- 'Glob' containing 'Prelude.String's, 'Dao.String.UStr's, or anything that can be constructed from+-- a 'Prelude.String'.+-- +-- /NOTE:/ that when a 'Glob' is parsed using 'Prelude.read', the string constant is the substring+-- of all characters between the variables. If there are no variables, the whole string will be+-- stored into a list of just one 'Single' string constant. However this behavior may not be useful.+-- It may be useful to break down string constants into smaller 'Single' string constants. To do+-- this, use the 'parseOverSingles' function.+-- +-- The following is a simple program you can use from the command line in GHCi to observe how to+-- construct 'Glob' expressions and try matching strings to these 'Glob's to see the result.+-- > import System.IO.Unsafe+-- > import Data.IORef+-- > +-- > -- Establish a global variable for GHCi.+-- > testref :: IORef (PatternTree String String)+-- > testref = unsafePerformIO (newIORef T.Void)+-- > +-- > -- A function to break-up a string into clusters of spaces, numbers, or letters.+-- > breakstr :: String -> [String]+-- > breakstr cx = loop cx where+-- >   check cx func = case cx of+-- >     c:cx | func c -> Just $ span func (c:cx)+-- >     _             -> Nothing+-- >   loop cx =+-- >     if null cx+-- >     then  []+-- >     else  maybe ([head cx] : loop (tail cx)) (\ (cx, rem) -> cx : loop rem) $+-- >             foldl (\a -> mplus a . check cx) Nothing [isSpace, isAlpha, isDigit]+-- > +-- > -- Use 'Prelude.read' to parse a 'Glob' expression with 'Prelude.String's as the constant+-- values. Also, use 'parseOverSignles' to break-down the string constants using breakstr above.+-- > parsepat :: String -> Glob String+-- > parsepat = flip parseOverSingles breakstr . read+-- > +-- > newpat :: String -> String -> IO ()+-- > newpat pat act = do+-- >   let glob = parsepat pat+-- >   modifyIORef testref (insertMultiPattern (flip const) [glob] act)+-- >   putStrLn $ "added pattern: "++show glob+-- > +-- > delpat :: String -> IO ()+-- > delpat str = modifyIORef testref (T.delete (getPatUnits $ parsepat str))+-- > +-- > ls :: IO ()+-- > ls = readIORef testref >>= putStrLn . disp "" where+-- >   disp ind t = case t of+-- >     T.Void           -> "()"+-- >     T.Leaf       o   -> show o+-- >     T.Branch       m -> dispMap ind m+-- >     T.LeafBranch o m -> " = " ++ show o ++ " ..." ++ dispMap ind m+-- >   dispMap ind m = (++(ind++"}")) $ ("{\n"++) $+-- >     if M.null m+-- >     then "(empty map)"+-- >     else  unlines $ do+-- >             (g, tree) <- M.assocs m+-- >             ['\t':ind ++ unwords ['"':show g++"\"", "=", disp ('\t':ind) tree]]+-- > +-- > trypat :: String -> IO ()+-- > trypat instr = do+-- >   tree <- readIORef testref+-- >   forM_ (matchTree True tree (breakstr instr)) $ \ (glob, vars, o) -> do+-- >     putStrLn $ "pattern: "++show glob+-- >     putStrLn $ "action:  "++show o+-- >     putStrLn $ ("vars assigned:\n"++) $ unlines $ flip map (T.assocs vars) $ \ (nm, o) -> unwords $+-- >       ['\t':show nm, "=", show (unwords o)]+module Dao.Glob where++import           Dao.String+import qualified Dao.Tree as T+import           Dao.PPrint+import           Dao.Random++import           Control.Applicative+import           Control.Monad.Identity+import           Control.DeepSeq++import           Data.Typeable+import           Data.Monoid+import           Data.List+import           Data.Char+import qualified Data.Map as M++----------------------------------------------------------------------------------------------------++-- | Tokenize a 'Prelude.String' grouping together whitespace, numbers, letters, and punctuation+-- makrs, except for brackets and quote markers which will all be tokenized as single character+-- strings.+simpleTokenize :: String -> [UStr]+simpleTokenize ax = map ustr (loop ax) where+  loop ax = case ax of+    [] -> []+    a:ax | elem a "([{}])\"'`" -> [a] : loop ax+    a:ax -> case msum (map (check a ax) kinds) of+      Nothing -> [a] : loop ax+      Just (got, ax) -> got : loop ax+  check a ax fn = if fn a then let (got, ax') = span fn ax in Just (a:got, ax') else Nothing+  kinds = [isSpace, isAlpha, isNumber, isPunctuation, isAscii, not . isAscii]++----------------------------------------------------------------------------------------------------++-- | A 'GlobUnit' is a single unit of a 'Glob' pattern, which is either a constant token value (a+-- 'Single'), a wildcard matching a single token (an 'AnyOne') or a 'Wildcard' matching zero or more+-- tokens. This is a very glob data type, remeniscent of the good old-fashioned Unix glob expression+-- but not restricted to single-character tokens. The unit token type need not be a string, but most the+-- instances of 'GlobUnit' into 'Prelude.Show' and 'Prelude.Read' are only defined for 'GlobUnit's+-- of 'Dao.String.UStr's.+data GlobUnit tok+  = Wildcard Name (Maybe Name)+  | AnyOne   Name (Maybe Name)+  | Single   tok+  deriving (Eq, Typeable)++-- Order such that sorting will group 'Wildcards' first, 'AnyOne's second, and 'Single's third.+instance Ord tok => Ord (GlobUnit tok) where+  compare a b = case a of+    Wildcard a a1 -> case b of+      Wildcard b b1 -> compare a b <> compare a1 b1+      _          -> LT+    AnyOne   a a1 -> case b of+      Wildcard{} -> GT+      AnyOne   b b1 -> compare a b <> compare a1 b1+      Single{}   -> LT+    Single   a -> case b of+      Single   b -> compare a b+      _          -> GT++instance Functor GlobUnit where+  fmap f o = case o of+    Single   o   -> Single (f o)+    Wildcard n t -> Wildcard n t+    AnyOne   n t -> AnyOne   n t++isSingle :: GlobUnit o -> Bool+isSingle o = case o of { Single _ -> True; _ -> False }++isVariable :: GlobUnit o -> Bool+isVariable = not . isSingle++-- not for export -- strips the leadnig and trailing quote @'"'@ characters.+toStringWithoutQuotes :: String -> String+toStringWithoutQuotes cx = loop $ case cx of { '"':cx -> cx ; cx -> cx ; } where+  loop cx = case cx of { '"':"" -> ""; "" -> ""; c:cx -> c : loop cx; }++-- | Use this function to instantiate your version of 'GlobUnit' into the 'Prelude.Show' class. This+-- function assumes your data type is a string-like type where evaluating 'Prelude.show' on your+-- type produces a string of characters with a leading and trailing quote @'"'@ character.+showGlobUnitOfStrings :: (tok -> String) -> GlobUnit tok -> String+showGlobUnitOfStrings gshow tok = let printyp = maybe "" (\n -> "::"++uchars n) in case tok of+  Wildcard nm t -> '$':uchars (toUStr nm)++printyp t+  AnyOne   nm t -> '$':uchars (toUStr nm)++printyp t++"?"+  Single   tok  -> toStringWithoutQuotes (gshow tok)++instance Show (GlobUnit UStr)   where { show = showGlobUnitOfStrings uchars }+instance Show (GlobUnit String) where { show = showGlobUnitOfStrings id }++-- | Use this function to instantiate your version of 'Glob' into the 'Prelude.Show' class. The+-- function you pass to convert the 'Single' type to a string is passed to 'showGlobUnitOfStrings'.+showGlobUnitList :: (tok -> String) -> [GlobUnit tok] -> String+showGlobUnitList gshow gx = show $ concatMap (showGlobUnitOfStrings gshow) gx++instance Read (GlobUnit String) where+  readsPrec _prec str = let init c = c=='_' || isAlpha c in case str of+    '$':c:str | init c -> do+      (cx, str) <- [span isAlphaNum str]+      (typfunc, str) <- case str of+        ':':':':str -> return $ head $ concat $+          [ case str of+              c:str | init c -> do+                (cx, str) <- [span isAlphaNum str]+                [(Just $ ustr $ c:cx, str)]+              _ -> []+          , [(Nothing, str)]+          ]+        str         -> [(Nothing, str)]+      case str of+        '?':str -> [(AnyOne   (ustr $ c:cx) typfunc, str)]+        _       -> [(Wildcard (ustr $ c:cx) typfunc, str)]+    '$':str -> [span (/='$') str] >>= \ (cx, str) -> [(Single ('$':cx), str)]+    _       -> []++instance Read (GlobUnit UStr) where+  readsPrec prec str = readsPrec prec str >>= \ (tok, str) -> return (fmap ustr tok, str)++instance UStrType (GlobUnit UStr) where+  maybeFromUStr str = case readsPrec 0 (uchars str) of { [(o, "")] -> Just o; _ -> Nothing; }+  toUStr = ustr . show++instance NFData o => NFData (GlobUnit o) where+  rnf (Wildcard a b) = deepseq a $! deepseq b ()+  rnf (AnyOne   a b) = deepseq a $! deepseq b ()+  rnf (Single   a  ) = deepseq a ()++instance HasRandGen o => HasRandGen (GlobUnit o) where+  randO = countNode $ runRandChoice+  randChoice = randChoiceList $+    [ Single <$> randO+    , return Wildcard <*> randO <*> randO+    , return AnyOne   <*> randO <*> randO+    ]++----------------------------------------------------------------------------------------------------++-- | A 'Glob' is a kind of pattern that can be matched against tokens. A 'Glob' pattern contains a+-- list of 'GlobUnit's, and a 'GlobUnit' is either a constant (a 'Single') token, or variable (a+-- 'Wildcard' or 'AnyOne') that can be matched against a list constant tokens using 'matchPattern'.+-- When you have a large number of 'Glob' patterns and you would like to match any of them to a list+-- of tokens, merge the 'Glob' patterns together into a 'PatternTree' using the 'globTree' function,+-- and match them all at once using the 'matchTree' function.+data Glob tok = Glob { getPatUnits :: [GlobUnit tok], getGlobLength :: Int }+  deriving (Eq, Ord, Typeable)++makeGlob :: [GlobUnit tok] -> Glob tok+makeGlob ox = Glob{ getPatUnits=ox, getGlobLength=length ox }++instance Functor Glob where+  fmap f g = g{ getPatUnits = fmap (fmap f) (getPatUnits g) }++instance Show (Glob UStr)   where { show = showGlobUnitList uchars . getPatUnits }+instance Show (Glob String) where { show = showGlobUnitList id     . getPatUnits }++instance Read (Glob String) where+  readsPrec prec str = if null str then return mempty else do+    (units, str) <- loop [] str+    return (Glob{ getPatUnits=units, getGlobLength=length units }, str)+    where+      loop units str = case break (=='$') str of+        ("", "" ) -> return (units, "")+        ("", str) -> readsPrec prec str >>= \ (unit, str) -> loop (units++[unit]) str+        (cx, str) -> loop (units++[Single cx]) str++instance Read (Glob UStr) where+  readsPrec prec str = readsPrec prec str >>= \ (g, str) -> return (fmap ustr g, str)++instance Monoid (Glob o) where+  mempty = nullValue+  mappend (Glob{ getPatUnits=a, getGlobLength=lenA }) (Glob{ getPatUnits=b, getGlobLength=lenB }) =+    Glob{ getPatUnits=a++b, getGlobLength=lenA+lenB }++instance NFData o => NFData (Glob o) where { rnf (Glob a b) = deepseq a $! deepseq b () }++instance HasNullValue (Glob o) where+  nullValue = Glob{ getPatUnits=[], getGlobLength=0 }+  testNull (Glob{ getPatUnits=ax }) = null ax++instance UStrType (Glob UStr) where+  maybeFromUStr str = case readsPrec 0 (uchars str) of { [(o, "")] -> Just o; _ -> Nothing; }+  toUStr = ustr . show++instance PPrintable (Glob UStr) where { pPrint = pShow }++instance HasRandGen o => HasRandGen (Glob o) where+  randO = randList 1 6 >>= \o -> return $ Glob{ getPatUnits=o, getGlobLength=length o }++----------------------------------------------------------------------------------------------------++-- | A pattern is a list of tokens/variables that can be compared to a token list using+-- 'matchPattern' or 'matchTree'. A 'PatternTree' contains many patterns which have been merged into+-- a tree structure, which can match N patterns of maximum length M to a token list of L tokens in+-- O(L*log(M*N)) time, making it a much more efficient data structure for matching against a large+-- database of patterns. Every 'Glob' pattern in the tree is mapped to result value called an+-- "action", which is the polymorphic type @act@. Every pattern in the tree that matches a list of+-- tokens produces an "action" and also contains a list of associations of which labeled wildcards+-- matched which substring of tokens.+type PatternTree tok act = T.Tree (GlobUnit tok) act++-- | When a 'Glob' is constructed with a function of the 'Prelude.Read' class, the 'Single' items+-- produced are all contiguous characters in between 'Wildcard' and 'AnyOne' markers. For example+-- the string:+-- > read "$X will do $Y? too" :: 'Glob' 'Prelude.String'+-- will parse to a 'Glob' where the 'getPatUnits' is the following list of items:+-- > ['Wildcard' "X", 'Single' " will do ", 'AnyOne' "Y", 'Single' " too"]+-- Notice how the 'Single' items contain spaces. This may or may not be desirable.+--+-- In the case that you would like to further parse the 'Single' strings, you can use the+-- 'parseOverSingles' function, breaking a 'Single' down into a list of 'Single's.+parseOverSinglesM :: Monad m => Glob tokA -> (tokA -> m [tokB]) -> m (Glob tokB)+parseOverSinglesM g convert =+  forM (getPatUnits g)+    (\u -> case u of+        Single   u    -> convert u >>= mapM (return . Single)+        AnyOne   nm t -> return [AnyOne   nm t]+        Wildcard nm t -> return [Wildcard nm t]+    ) >>= return . makeGlob . concat++-- | Like 'parseOverSinglesM' but is a pure function.+parseOverSingles :: Glob tokA -> (tokA -> [tokB]) -> Glob tokB+parseOverSingles g = runIdentity . parseOverSinglesM g . (return.)++-- | Insert an item at multiple points in the 'PatternTree'+insertMultiPattern :: (Eq tok, Ord tok) => (act -> act -> act) -> [Glob tok] -> act -> PatternTree tok act -> PatternTree tok act+insertMultiPattern plus pats act tree =+  foldl (\tree pat -> T.update (getPatUnits pat) (maybe (Just act) (Just . flip plus act)) tree) tree pats++-- | By converting an ordinary 'Glob' to a pattern tree, you are able to use all of the methods+-- in the "Dao.Tree" module to modify the patterns in it.+globTree :: (Eq tok, Ord tok) => Glob tok -> act -> PatternTree tok act+globTree pat a = T.insert (getPatUnits pat) a T.Void++-- | Calls 'matchTree' with the 'PatternTree' stored within the given 'Glob' object, and returns+-- only the matching results.+matchPattern :: (Eq tok, Ord tok) => Bool -> Glob tok -> [tok] -> [M.Map Name (Maybe Name, [tok])]+matchPattern greedy pat tokx = matchTree greedy (globTree pat ()) tokx >>= \ (_, m, ()) -> [m]++-- | Match a list of token items to a set of 'Glob' expressions that have been combined into a+-- single 'PatternTree', matching every possible pattern in the 'PatternTree' to the list of token+-- items in depth-first order. The first boolean parameter indicates whether 'Wildcard's should be+-- matched greedily (pass 'Prelude.False' for non-greedy matching). Be aware that greedy matching is+-- /not lazy/ which could cause freezes if you are working with infinitely recursive data types.+-- Non-greedy matching is lazy and works fine with everything.+--+-- Each match is returned as a triple indicating 1. the 'Glob' that matched the token list, 2. the+-- token list items that were bound to the 'Dao.String.Name's in the 'Wildcard' and 'AnyOne'+-- 'GlobUnit's, and 3. the item associated with the 'Glob' expression that matched.+--+-- The 'Data.Map.Map' objects returned map which variable names matched to pairs containing in the+-- 'Prelude.fst' slot the type of the token that the variable expects (the type is the part of the+-- pattern variable after the "::" symbol), and in the 'Prelude.snd' slot contains the tokens that+-- matched in that variable position.+matchTree+  :: (Eq tok, Ord tok)+  => Bool -> PatternTree tok act -> [tok] -> [(Glob tok, M.Map Name (Maybe Name, [tok]), act)]+matchTree greedy tree tokx = loop M.empty 0 [] tree tokx where+  loop vars p path tree tokx = case tree of+    T.Void           -> []+    T.Leaf       a   -> guard (null tokx) >> done vars p path a+    T.Branch       b -> branch vars p path []  b tokx+    T.LeafBranch a b -> branch vars p path [a] b tokx+  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+  partStep bind tokx = (if greedy then reverse else id) $ (bind, tokx) :+    fix (\loop bind tokx -> if null tokx then [] else do+            bind <- [bind++[head tokx]]+            tokx <- [tail tokx]+            ((bind, tokx) : loop bind tokx)+        ) bind tokx+  -- partStep takes a list of tokens, like [a,b,c] and returns a list for every possible+  -- 2-way partition: [([],[a,b,c]), ([a],[b,c]), ([a,b],[c]), ([a,b,c],[])]+  -- This forms a list of (bind, tokx) pairs where 'bind' will be assigned to a variable and 'tokx'+  -- is the remaining tokens to be matched. So when a 'Wildcard' variable is matched, it tries every+  -- possible ('bind', 'tokx') pair, binding the 'bind' to a variable and looping on 'tokx'.+  done vars p path a = [(Glob{ getPatUnits=path, getGlobLength=p }, vars, a)]+  branch vars p path a b tokx = case tokx of+    []       -> msum $+      [a >>= \a -> done vars p path a+      ,do (pat, tree) <- M.assocs b+          a <- case tree of+            T.Void           -> []+            T.Branch       _ -> []+            T.Leaf       a   -> [a]+            T.LeafBranch a _ -> [a]+          case pat of+            Wildcard nm t -> case M.lookup nm vars of+              Nothing       -> done (M.insert nm (t, []) vars) p path a+              Just (_, pfx) -> guard (null pfx) >> done vars p path a+            AnyOne{}      -> []+            Single{}      -> []+      ]+    tok:tokx -> let next pat vars tree = loop vars (p+1) (path++[pat]) tree in msum $+      [do tree <- maybe [] (:[]) $ M.lookup (Single tok) b+          next (Single tok) vars tree tokx+      ,do -- Next we use 'takeWhile' because of how the 'Ord' instance of 'GlobUnit' is defined,+          -- 'Wildcard's and 'AnyOne's are always first in the list of 'assocs'.+          (pat, tree) <- takeWhile (isVariable . fst) (M.assocs b)+          let defVar nm t mkAssoc = case M.lookup nm vars of+                Just (_, pfx) -> maybe [] (:[]) (stripPrefix pfx (tok:tokx)) >>= next pat vars tree+                Nothing       -> do+                  (bind, tokx) <- mkAssoc+                  next pat (M.insert nm (t, bind) vars) tree tokx+          case pat of+            Wildcard nm t -> defVar nm t (partStep [] (tok:tokx))+            AnyOne   nm t -> defVar nm t [([tok], tokx)]+            Single{}      -> error "undefined behavior in Dao.Glob.matchTree:branch: case Single"+            -- 'Single' cases must not occur, they should have been filtered out by the code:+            -- > takeWhile (isVariable . fst)+      ]+
+ src/Dao/HashMap.hs view
@@ -0,0 +1,256 @@+-- "src/Dao/HashMap.hs"  a simple hash map using Data.IntMap+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++module Dao.HashMap+  ( Hash128, Int128Hashable(hash128),+    hash128_md5, deriveHash128_Show, deriveHash128_UStr,+    deriveHash128_DataBinary, deriveHash128_DaoBinary,+    Index, indexToPair, hashNewIndex, newIndex, indexHash, indexKey,+    HashMap, hashLookup, hashAlter, hashInsert, hashDelete, hashAdjust, hashModify,+    Dao.HashMap.lookup, alter, Dao.HashMap.insert, Dao.HashMap.delete, adjust, modify,+    unionWith, unionsWith, Dao.HashMap.union, unions, differenceWith, difference, intersectionWith, intersection,+    assocs, elems, keys, fromListWith, fromList, size, empty+  ) where++import           Dao.String+import           Dao.PPrint+import           Dao.Binary++import           Control.Applicative hiding (empty)+import           Control.Monad++import           Data.Typeable+import           Data.Monoid+import           Data.List+import           Data.Char+import           Data.Word+import qualified Data.Binary          as B+import qualified Data.Binary.Get      as B+import qualified Data.Binary.Put      as B+import qualified Data.ByteString.Lazy as B+import qualified Data.Map             as M+import qualified Data.IntMap          as I+import qualified Data.Digest.MD5      as MD5++----------------------------------------------------------------------------------------------------++type Hash128 = (Word64, Word64)+type Int128Map a = I.IntMap (I.IntMap a)++_lookup :: Hash128 -> Int128Map a -> Maybe a+_lookup (h1, h2) = I.lookup (fromIntegral h1) >=> I.lookup (fromIntegral h2)++_alter :: (Maybe a -> Maybe a) -> Hash128 -> Int128Map a -> Int128Map a+_alter alt (h1, h2) =+  I.alter+    ((\m -> if I.null m then Nothing else Just m) . I.alter alt (fromIntegral h2) . maybe mempty id)+    (fromIntegral h1)++_unionWith :: (a -> a -> a) -> Int128Map a -> Int128Map a -> Int128Map a+_unionWith f = I.unionWith (I.unionWith f)++_differenceWith :: (a -> b -> Maybe a) -> Int128Map a -> Int128Map b -> Int128Map a+_differenceWith f = I.differenceWith (\a b -> let m = I.differenceWith f a b in guard (not $ I.null m) >> return m)++_intersectionWith :: (a -> b -> c) -> Int128Map a -> Int128Map b -> Int128Map c+_intersectionWith f = I.intersectionWith (I.intersectionWith f)++_assocs :: Int128Map a -> [(Hash128, a)]+_assocs m = I.assocs m >>= \ (h1, m) -> I.assocs m >>= \ (h2, a) -> [((fromIntegral h1, fromIntegral h2), a)]++_fromListWith :: (a -> a -> a) -> [(Hash128, a)] -> Int128Map a+_fromListWith f = fmap (I.fromListWith f) . I.fromListWith (++) . fmap (\ ((h1, h2), a) -> (fromIntegral h1, [(fromIntegral h2, a)]))++----------------------------------------------------------------------------------------------------++class Ord key => Int128Hashable key where { hash128 :: key -> Hash128 }++hash128_md5 :: [Word8] -> Hash128+hash128_md5 = B.runGet (pure (,) <*> B.getWord64be <*> B.getWord64be) . B.pack . MD5.hash++deriveHash128_Show :: Show a => a -> Hash128+deriveHash128_Show = deriveHash128_UStr . show++deriveHash128_UStr :: UStrType a => a -> Hash128+deriveHash128_UStr = hash128_md5 . utf8bytes++deriveHash128_DataBinary :: B.Binary a => a -> Hash128+deriveHash128_DataBinary = hash128_md5 . B.unpack . B.encode++deriveHash128_DaoBinary :: (HasCoderTable mtab, Binary a mtab) => mtab -> a -> Hash128+deriveHash128_DaoBinary mtab = hash128_md5 . B.unpack . encode mtab++----------------------------------------------------------------------------------------------------++data Index key = Index { indexHash :: Hash128, indexKey :: key } deriving (Eq, Ord, Typeable)++indexToPair :: Index key -> (B.ByteString, key)+indexToPair (Index{ indexHash=(h1, h2), indexKey=key }) =+  (B.runPut (B.putWord64be h1 >> B.putWord64be h2), key)++instance Show key => Show (Index key) where+  show (Index{ indexKey=key }) = concat ["Index (", show key, ")"]++instance (Read key, Int128Hashable key) => Read (Index key) where+  readsPrec p s = do+    s <- maybe [] return $ stripPrefix "Index" $ dropWhile isSpace s+    (key, s) <- case dropWhile isSpace s of { '(':s -> readsPrec p s; _ -> [] }+    case dropWhile isSpace s of+      ')':s -> [(Index{ indexHash=hash128 key, indexKey=key }, s)]+      _     -> []++instance Binary key mtab => Binary (Index key) mtab where+  put (Index{ indexHash=(h1, h2), indexKey=key }) = putWord64be h1 >> putWord64be h2 >> put key+  get = do+    h1 <- getWord64be+    h2 <- getWord64be+    key <- get+    return $ Index{ indexHash=(h1, h2), indexKey=key }++instance PPrintable key => PPrintable (Index key) where { pPrint i = pPrint (indexKey i) }++hashNewIndex :: (key -> Hash128) -> key -> Index key+hashNewIndex hash key = Index{ indexHash = hash key, indexKey = key }++newIndex :: Int128Hashable key => key -> Index key+newIndex = hashNewIndex hash128++----------------------------------------------------------------------------------------------------++newtype HashMap key a = HashMap (Int128Map (M.Map key a)) deriving (Eq, Ord, Typeable)++instance (Show key, Show a) => Show (HashMap key a) where+  show = ("fromList "++) . show . assocs++instance (Read key, Int128Hashable key, Read a) => Read (HashMap key a) where+  readsPrec p s = maybe [] return (stripPrefix "fromList" $ dropWhile isSpace s) >>=+    readsPrec p . dropWhile isSpace >>= \ (hmap, s) -> return (fromList hmap, s)++instance Functor (HashMap key) where+  fmap f (HashMap m) = HashMap $ fmap (fmap (fmap f)) m++instance (Ord key, Monoid a) => Monoid (HashMap key a) where+  mempty = HashMap mempty+  mappend a b = unionWith mappend a b++instance HasNullValue (HashMap key a) where+  nullValue = HashMap mempty+  testNull = Dao.HashMap.null++instance (Ord key, Binary key mtab, Binary a mtab) => Binary (HashMap key a) mtab where+  put = put . assocs+  get = fromList <$> get++instance (PPrintable key, PPrintable a) => PPrintable (HashMap key a) where+  pPrint = pList (pString "HashMap") "{" ", " "}" .+    map (\ (a, b) -> pInline [pPrint a, pString " = ", pPrint b]) . assocs++null :: HashMap key a -> Bool+null (HashMap a) = I.null a++hashLookup :: Ord key => Index key -> HashMap key a -> Maybe a+hashLookup key (HashMap intmap) = _lookup (indexHash key) intmap >>= M.lookup (indexKey key)++lookup :: Int128Hashable key => key -> HashMap key a -> (Index key, Maybe a)+lookup key hmap = let i = Index{ indexHash=hash128 key, indexKey=key } in (i, hashLookup i hmap)++hashAlter :: Ord key => (Maybe a -> Maybe a) -> Index key -> HashMap key a -> HashMap key a+hashAlter alt key (HashMap intmap) = HashMap $+  _alter+    ((\m -> guard (not $ M.null m) >> Just m) . M.alter alt (indexKey key) . maybe mempty id)+    (indexHash key)+    intmap++alter :: Int128Hashable key => (Maybe a -> Maybe a) -> key -> HashMap key a -> HashMap key a+alter f key = hashAlter f (Index{ indexHash=hash128 key, indexKey=key })++hashInsert :: Ord key => Index key -> a -> HashMap key a -> HashMap key a+hashInsert key a = hashAlter (const $ Just a) key++insert :: Int128Hashable key => key -> a -> HashMap key a -> HashMap key a+insert key = hashInsert (Index{ indexHash=hash128 key, indexKey=key})++hashDelete :: Ord key => Index key -> HashMap key a -> HashMap key a+hashDelete = hashAlter (const Nothing)++delete :: Int128Hashable key => key -> HashMap key a -> HashMap key a+delete key = hashDelete (Index{ indexHash=hash128 key, indexKey=key })++hashAdjust :: Ord key => (a -> a) -> Index key -> HashMap key a -> HashMap key a+hashAdjust f = hashAlter (fmap f)++adjust :: Int128Hashable key => (a -> a) -> key -> HashMap key a -> HashMap key a+adjust f key = hashAdjust f (Index{ indexHash=hash128 key, indexKey=key })++hashModify :: Ord key => (a -> Maybe a) -> Index key -> HashMap key a -> HashMap key a+hashModify f = hashAlter (>>=f)++modify :: Int128Hashable key => (a -> Maybe a) -> key -> HashMap key a -> HashMap key a+modify f key = hashModify f (Index{ indexHash=hash128 key, indexKey=key })++unionWith :: Ord key => (a -> a -> a) -> HashMap key a -> HashMap key a -> HashMap key a+unionWith f (HashMap a) (HashMap b) = HashMap $ _unionWith (M.unionWith f) a b++union :: Ord key => HashMap key a -> HashMap key a -> HashMap key a+union = unionWith const++unionsWith :: Ord key => (a -> a -> a) -> [HashMap key a] -> HashMap key a+unionsWith f = foldl (unionWith f) empty++unions :: Ord key => [HashMap key a] -> HashMap key a+unions = unionsWith const++differenceWith :: Ord key => (a -> b -> Maybe a) -> HashMap key a -> HashMap key b -> HashMap key a+differenceWith f (HashMap a) (HashMap b) = HashMap $+  _differenceWith (\a b -> let m = M.differenceWith f a b in guard (not $ M.null m) >> return m) a b++difference :: Ord key => HashMap key a -> HashMap key b -> HashMap key a+difference = differenceWith (\ _ _ -> Nothing)++intersectionWith :: Ord key => (a -> b -> c) -> HashMap key a -> HashMap key b -> HashMap key c+intersectionWith f (HashMap a) (HashMap b) = HashMap $ _intersectionWith (M.intersectionWith f) a b++intersection :: Ord key => HashMap key a -> HashMap key a -> HashMap key a+intersection = intersectionWith const++assocs :: HashMap key a -> [(Index key, a)]+assocs (HashMap m) = do+  (hash, m) <- _assocs m+  (key , a) <- M.assocs m+  [(Index{ indexHash=hash, indexKey=key }, a)]++elems :: HashMap key a -> [a]+elems = fmap snd . assocs++keys :: HashMap key a -> [Index key]+keys = fmap fst . assocs++fromListWith :: Ord key => (a -> a -> a) -> [(Index key, a)] -> HashMap key a+fromListWith f = HashMap . fmap (fmap $ M.fromListWith f) . _fromListWith (++) .+  fmap (\ (Index{ indexHash=hash, indexKey=key }, a) -> (hash, [(key, a)]))++fromList :: Ord key => [(Index key, a)] -> HashMap key a+fromList = fromListWith (flip const)++size :: HashMap key a -> Integer+size (HashMap m) = I.foldl (I.foldl (\i -> (i+) . toInteger . M.size)) 0 m++empty :: HashMap key a+empty = HashMap I.empty+
+ src/Dao/Interpreter.hs view
@@ -0,0 +1,8391 @@+-- "src/Dao/Interpreter.hs"  defines the Dao programming language semantics.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE CPP #-}++module Dao.Interpreter(+    Action(Action), actionTokens, actionPattern, actionMatch, actionCodeBlock,+    makeActionsForQuery, betweenBeginAndEnd, daoShutdown, getLocalRuleSet,+    getGlobalRuleSet, defaultTokenizer, constructPatternWith, constructPattern,+    DaoSetupM(), DaoSetup, haskellType, daoProvides, daoClass, daoConstant, daoFunction,+    daoFunction0, daoInitialize, setupDao, evalDao, DaoFunc, daoFunc, funcAutoDerefParams,+    daoForeignFunc, executeDaoFunc,+    Sizeable(getSizeOf),+    ObjectClass(obj, fromObj, castToCoreType),+    execCastToCoreType, listToObj, listFromObj, new, opaque, objFromHata,+    Struct(Nullary, Struct), structLookup,+    ToDaoStructClass(toDaoStruct), toDaoStructExec, pPrintStructForm,+    FromDaoStructClass(fromDaoStruct), withFromDaoStructExec, fromDaoStructExec,+    StructError(StructError),+    structErrName, structErrField, structErrValue, structErrExtras,+    mkLabel, mkStructName, mkFieldName,+    ToDaoStruct(),+    fromData, innerToStruct, innerToStructWith, renameConstructor, makeNullary, putNullaryUsingShow,+    define, optionalField, setField, defObjField, (.=), putObjField, (.=@), defMaybeObjField, (.=?),+    FromDaoStruct(),+    toData, constructor, innerFromStruct, nullary, getNullaryWithRead, structCurrentField,+    tryCopyField, tryField, copyField, field,+    convertFieldData, req, opt, reqList, optList,+    ObjectUpdate, ObjectTraverse,+    ObjectLens(updateIndex), ObjectFunctor(objectFMap),+    ObjectFocus, ObjFocusState(), getFocalReference,+    execToFocusUpdater, withInnerLens, runObjectFocus, focusObjectClass, focusStructAsDict,+    focusLiftExec, focalPathSuffix, focusGuardStructName, updateHataAsStruct, callMethod,+    innerDataUpdateIndex, referenceUpdateName, referenceLookupName,+    Object(+      ONull, OTrue, OType, OInt, OWord, OLong,+      OFloat, ORatio, OComplex, OAbsTime, ORelTime,+      OChar, OString, ORef, OList, ODict, OTree, OBytes, OHaskell+    ),+    T_type, T_int, T_word, T_long, T_ratio, T_complex, T_float, T_time, T_diffTime,+    T_char, T_string, T_ref, T_bytes, T_list, T_dict, T_struct,+    isNumeric, typeMismatchError,+    initializeGlobalKey, destroyGlobalKey, evalTopLevelAST,+    Reference(Reference, RefObject), reference, refObject, referenceHead, refUnwrap,+    refNames, referenceFromUStr, fmapReference, setQualifier, modRefObject,+    refAppendSuffix, referenceLookup, referenceUpdate,+    CoreType(+      NullType, TrueType, TypeType, IntType, WordType, DiffTimeType, FloatType,+      LongType, RatioType, ComplexType, TimeType, CharType, StringType, RefType,+      ListType, DictType, TreeType, BytesType, HaskellType+    ),+    typeOfObj, coreType, hataType, objTypeFromCoreType, objTypeFromName,+    TypeSym(CoreType, TypeSym, TypeVar), TypeStruct(TypeStruct), ObjType(ObjType), typeChoices,+    RefSuffix(NullRef, DotRef, Subscript, FuncCall),+    refSuffixHead, refSuffixHasFuncCall, refSuffixToList, dotRef, subscript, funcCall,+    Complex(Complex),+    realPart, imagPart, mkPolar, cis, polar, magnitude, phase, conjugate, complex,+    minAccumArray, minArray,+    FuzzyStr(FuzzyStr),+    ExecUnit(), ExecTokenizer(ExecTokenizer), runExecTokenizer,+    globalMethodTable, defaultTimeout, importGraph, currentWithRef, taskForExecUnits,+    currentQuery, currentPattern, currentBranch, providedAttributes, programModuleName,+    preExec, postExec, quittingTime, programTokenizer, currentCodeBlock, ruleSet,+    newExecUnit, inModule,+    Task(), initTask, throwToTask, killTask, taskLoop, taskLoop_,+    Executable(execute), DerefAssignExpr,+    ExecRef(execReadRef, execTakeRef, execPutRef, execSwapRef, execModifyRef, execModifyRef_),+    ExecControl(ExecReturn, ExecError), execReturnValue,+    execErrorMessage, execErrorInModule, execErrorLocation, execErrorSubtype, execErrorInfo,+    ExecErrorSubtype(+      ExecErrorUntyped, ExecThrow, ExecStructError, ExecUndefinedRef, ExecTypeError,+      ExecUpdateOpError, ExecInfixOpError, ExecIOException, ExecHaskellError+    ),+    errInFunc, errInConstr, errInInitzr, errOfReference, argNum, numArgsPassed,+    expectNumArgs, exectDimension, expectType, actualType, leftSideType, rightSideType,+    modifiedConst, assertFailed, returnedVoid, errorDict,+    newError, throwArityError, throwParseError, throwBadTypeError, errLocation, errModule,+    errCurrentModule, errInfo, updateExecErrorInfo, logUncaughtErrors, clearUncaughtErrorLog,+    execForM, execForM_,+    Exec(Exec), execToPredicate, XPure(XPure), xpureToState, runXPure, evalXPure, xpure, xobj,+    xnote, xonUTF8, xmaybe,+    ExecThrowable(toExecErrorInfo, execThrow), ioExec,+    ExecHandler(ExecHandler), execHandler,+    newExecIOHandler, execCatchIO, execHandleIO, execIOHandler,+    execErrorHandler, catchReturn, execNested, execNested_, execFuncPushStack,+    execFuncPushStack_, execWithStaticStore, execWithWithRefStore, withExecTokenizer,+    Subroutine(Subroutine), setupCodeBlock,+    origSourceCode, staticVars, staticRules, staticLambdas, executable, runCodeBlock, runCodeBlock_,+    RuleSet(), CallableCode(CallableCode), argsPattern, returnType, codeSubroutine, +    PatternRule(PatternRule), rulePatterns, ruleAction, +    asReference, asInteger, asRational, asPositive, asComplex, objConcat,+    objToBool, extractStringElems, requireAllStringArgs,+    shiftLeft, shiftRight,+    evalArithPrefixOp, evalInfixOp, evalUpdateOp, runTokenizerWith, runTokenizer, makePrintFunc,+    paramsToGlobExpr, matchFuncParams, execGuardBlock, objToCallable, callCallables,+    callObject, checkPredicate, checkVoid,+    evalConditional,+    localVarDefine, localVarUpdate, localVarLookup, maybeDerefObject, derefObjectGetReference, derefObject,+    updateExecError,+    assignUnqualifiedOnly,+    LimitedObject(LimitedObject, unlimitObject),+    MethodTable(), execGetObjTable, lookupMethodTable,+    ReadIterable(readForLoop), UpdateIterable(updateForLoop),+    HataClass(haskellDataInterface), toHata, fromHata,+    InitItem(InitSingle, InitAssign),+    Interface(),+    objCastFrom, objEquality, objOrdering, objBinaryFormat, objNullTest, objPPrinter,+    objSizer, objIndexer, objIndexUpdater, objToStruct, objFromStruct, objInitializer, objTraverse,+    objInfixOpTable, objArithPfxOpTable, objCallable, objDereferencer,+    interfaceAdapter, interfaceToDynamic,+    DaoClassDefM(), interface, DaoClassDef,+    defCastFrom, autoDefEquality, defEquality, autoDefOrdering, defOrdering, autoDefBinaryFmt,+    defBinaryFmt, autoDefNullTest, defNullTest, defPPrinter, autoDefPPrinter, defReadIterable,+    autoDefReadIterable, defUpdateIterable, autoDefUpdateIterable, defIndexer, defIndexUpdater,+    defSizer, autoDefSizeable, autoDefToStruct, defToStruct, autoDefFromStruct, defFromStruct,+    defInitializer, defTraverse, autoDefTraverse, defInfixOp, defPrefixOp, defCallable, defDeref,+    defMethod, defMethod0, defLeppard+  )+  where++import           Dao.Glob+import           Dao.PPrint+import           Dao.Predicate+import           Dao.Random+import           Dao.Stack+import           Dao.String+import           Dao.Token+import           Dao.RefTable+import qualified Dao.HashMap as H+import qualified Dao.Binary  as B+import qualified Dao.Interval as Iv+import qualified Dao.Tree    as T+import           Dao.Interpreter.Tokenizer+import           Dao.Interpreter.AST++import           Data.Array.IArray+import           Data.Binary (encode)+import           Data.Bits+import           Data.Char+import           Data.Dynamic+import           Data.IORef+import           Data.List+import           Data.Monoid+import           Data.Ratio+import           Data.Time.Clock+import           Data.Word+import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Data.ByteString.Lazy      as B+import qualified Data.Binary               as D+import qualified Data.Binary.Put           as D+import qualified Data.Binary.Get           as D+import qualified Data.Complex              as C+import qualified Data.Map                  as M+import qualified Data.Set                  as S++import           Control.Applicative+import           Control.Concurrent+import           Control.DeepSeq+import           Control.Exception+import           Control.Monad+import           Control.Monad.Error+import           Control.Monad.Reader+import           Control.Monad.State++#if 0+import Debug.Trace+import System.IO+strace :: PPrintable s => String -> s -> s+strace msg s = trace (msg++": "++prettyShow s) s+dbg :: MonadIO m => String -> m ()+dbg = liftIO . hPutStrLn stderr . ("(DEBUG) "++) . (>>=(\c -> if c=='\n' then "\n(DEBUG) " else [c]))+dbg' :: MonadIO m => String -> m a -> m a+dbg' msg f = f >>= \a -> dbg msg >> return a+dbg0 :: (MonadPlus m, MonadIO m, MonadError e m, Show e) => String -> m a -> m a+dbg0 msg f = do+  dbg (msg++" (BEGIN)")+  catchError+    (mplus (f >>= \a -> dbg (msg++" (DONE)") >> return a) (dbg (msg++" (BACKTRACKED)") >> mzero))+    (\e -> dbg (msg++" (ERROR) "++show e) >> throwError e)+updbg :: MonadIO m => String -> (Maybe Object -> m (Maybe Object)) -> Maybe Object -> m (Maybe Object)+updbg msg f o = dbg ("(update with "++msg++")") >> f o >>= \o -> dbg ("(update complete "++show o++")") >> return o+#endif+#if 0+_randTrace :: String -> RandO a -> RandO a+_randTrace = Dao.Random.randTrace+#else+_randTrace :: String -> RandO a -> RandO a+_randTrace _ = id+#endif++----------------------------------------------------------------------------------------------------++-- A note on the binary format.+--     Most constructors have a unique prefix byte, and this allows more efficient encoding because+-- it is not necessary to place null terminators everywhere and you can determine exactly which+-- constructor is under the decoder cursor just from the byte prefix. This means there is an+-- address space for prefix bytes between 0x00 and 0xFF. This is an overview of that address space.+-- +-- 0x00..0x07 > The "Dao.Binary" module declares a few unique prefixes of its own for booleans,+--              variable-length integers, and maybe types, and of course the null terminator.+-- 0x08..0x1A > Each prefix here used alone indicates a 'CoreType's. But each prefix may be followed+--              by data which indicates that it is actuall one of the constructors for the 'Object'+--              data type.+-- +-- 0x25..0x26 'Struct'+-- 0x2E..0x2F 'TypeSym'+-- 0x33       'TypeStruct'+-- 0x37       'ObjType' (T_type)+-- +-- 0x42..0x45 > The 'RefSuffix' data type. These prefixes are re-used for the 'ReferenceExpr' data type+--              because there is a one-to-one mapping between these two data types.+-- 0x48..0x4F > The 'Reference' data type. These prefixes are re-used for the 'ReferenceExpr' data type+--              execpt for the 'RefWrapper' constructor which is mapped to @'RefPrefixExpr' 'REF'@.+-- +-- -- the abstract syntax tree -- --+-- +-- 0x52..0x53 'RefPrefixExpr'+-- 0x59       'ParenExpr'+-- 0x60..0x64 'ObjectExpr'+-- 0x6A       'ArithExpr'+-- 0x6F       'AssignExpr'+-- 0x73       'ObjTestExpr'+-- 0x74..0x76 'RuleFuncExpr'+-- 0x7A..0x7B 'RuleHeadExpr'+-- 0x81       'DotLabelExpr'+-- 0x82       'AttributeExpr'+-- 0x86       'ObjListExpr'+-- 0xBA..0xCD 'InfixOp'+-- 0x8D..0x9D 'UpdateOp' -- Partially overlaps with 'InfixOp'+-- 0x8E..0x9B 'ArithPfxOp' -- Partially overlaps with 'InfixOp'+-- 0xA8..0xAF 'ScriptExpr'+-- 0xB6       'ElseExpr'+-- 0xBA       'IfElseExpr'+-- 0xBE       'WhileExpr'+-- 0xC5..0xC7 'TyChkExpr'+-- 0xCF..0xD0 'ParamExpr'+-- 0xD6       'ParamListExpr'+-- 0xDD       'CodeBlock'+-- 0xE9..0xEE 'TopLevelExpr'++----------------------------------------------------------------------------------------------------++-- | An 'Action' is the result of a pattern match that occurs during an input string query. It is a+-- data structure that contains all the information necessary to run an 'Subroutine' assocaited with+-- a 'Glob', including the parent 'ExecUnit', the 'Dao.Glob.Glob' and the 'Dao.Glob.Match' objects,+-- and the 'Executables'. Use 'execute' to evaluate a 'Action' in the current thread.+-- +-- To execute an action in a separate thread, use 'forkExecAction'.+data Action+  = Action+    { actionTokens    :: [Object]+    , actionPattern   :: Glob Object+    , actionMatch     :: M.Map Name Object+    , actionCodeBlock :: Subroutine+    }+  deriving (Eq, Typeable)++instance PPrintable Action where { pPrint = pPrintStructForm }++instance ToDaoStructClass Action where+  toDaoStruct = renameConstructor "Action" $ do+    "tokens"  .=@ actionTokens+    "pattern" .=@ actionPattern+    "match"   .=@ actionMatch+    "code"    .=@ actionCodeBlock++instance FromDaoStructClass Action where+  fromDaoStruct = do+    constructor "Action"+    let err name o = flip (execThrow "match dictionary items must contain lists of tokens") [] $+          StructError+          { structErrName   = Nothing+          , structErrField  = Just (toUStr name)+          , structErrValue  = Just $ obj (typeOfObj o)+          , structErrExtras = []+          }+    let fmtMatches = fmap M.fromList .+          mapM (\ (name, o) -> xmaybe (fromObj o) <|> err name o >>= return . (,) name) . M.assocs+    return Action <*> req "tokens" <*> req "pattern" <*> (req "match" >>= fmtMatches) <*> req "code"++instance ObjectClass Action where { obj=new; fromObj=objFromHata; }++instance HataClass Action where+  haskellDataInterface = interface "Action" $ do+    autoDefEquality >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++instance Executable Action (Maybe Object) where+  execute act = do+    cq  <- gets currentQuery+    cp  <- gets currentPattern+    ccb <- gets currentCodeBlock+    let setVar :: ObjectClass o => String -> (Action -> o) -> T_dict -> T_dict+        setVar name f = M.insert (ustr name) (obj $ f act)+    let setTokensVar = setVar "tokens" actionTokens+    let setSelfVar = M.union (M.singleton (ustr "self") (obj $ setTokensVar $ mempty))+    let localVars = setSelfVar $ actionMatch act+    modify $ \xunit -> +      xunit+      { currentQuery     = Just $ actionTokens act+      , currentPattern   = Just $ actionPattern act+      , currentCodeBlock = Just $ actionCodeBlock act+      }+    success <- optional $ runCodeBlock_ localVars (actionCodeBlock act)+    modify (\xunit -> xunit{ currentQuery=cq, currentPattern=cp, currentCodeBlock=ccb })+    xmaybe success++instance Executable [Action] [Object] where+  execute = fmap concat .+    mapM (\act -> catchPredicate (execute act) >>= \p -> case p of+             OK                (Just o)  -> return [o]+             PFail (ExecReturn (Just o)) -> return [o]+             PFail              err      -> logUncaughtErrors [err] >> return []+             _                           -> return []+         )++-- | Using an 'ExecTokenizer' function, break up a string into a list of tokens, returning them as a+-- 'TokenList' object. Input paramaters can be strings or lists of strings. If an input paramter is+-- a string, it is tokenized to a list of strings. If an input parameter is a list of strings, it is+-- considered to be already tokenized and simply appended to list of tokens produced by previous+-- parameters.+runTokenizerWith :: ExecTokenizer -> [Object] -> Exec [Object]+runTokenizerWith tok ox = fmap concat $ forM ox $ \o -> case o of+  OString o -> fmap obj <$> runExecTokenizer tok o+  OList  ox -> return ox+  o         -> return [o]++-- | Like 'runTokenizerWith', but uses the default tokenizer function set for this module.+runTokenizer :: [Object] -> Exec [Object]+runTokenizer ox = gets programTokenizer >>= \tok -> runTokenizerWith tok ox++-- | Match a given input string to the 'Dao.Evaluator.currentPattern' of the current 'ExecUnit'.+-- Return all patterns and associated match results and actions that matched the input string, but+-- do not execute the actions. This is done by tokenizing the input string and matching the tokens+-- to the program using 'Dao.Glob.matchTree'. NOTE: Rules that have multiple patterns may execute+-- more than once if the input matches more than one of the patterns associated with the rule. *This+-- is not a bug.* Each pattern may produce a different set of match results, it is up to the+-- programmer of the rule to handle situations where the action may execute many times for a single+-- input.+-- +-- Once you have created an action group, you can execute it with 'Dao.Evaluator.execute'.+makeActionsForQuery :: [PatternTree Object [Subroutine]] -> [Object] -> Exec [Action]+makeActionsForQuery tree tokens = do+  let match = matchTree False (T.unionsWith (++) tree) tokens+  fmap concat $ forM match $ \ (patn, match, execs) -> do+    match <- catchPredicate $ fmap M.fromList $ -- evaluate pattern type checkers+      forM (M.assocs match) $ \ (name, (vartyp, ox)) -> case vartyp of+        Nothing     -> return (name, obj ox)+        Just vartyp -> do+          match <- catchPredicate $ referenceLookup $ Reference UNQUAL vartyp $ FuncCall [OList ox] NullRef+          case match of+            OK (_, Nothing)             -> return (name, obj ox)+            OK (_, Just  o)             -> return (name, o)+            PFail (ExecReturn Nothing)  -> return (name, obj ox)+            PFail (ExecReturn (Just o)) -> return (name, o)+            PFail err                   -> throwError err+            Backtrack                   -> mzero+    case match of+      Backtrack -> return []+      PFail err -> logUncaughtErrors [err] >> return []+      OK  match -> return $+        flip fmap execs $ \exec -> deepseq exec $! deepseq tokens $! deepseq patn $! deepseq match $!+          Action+          { actionPattern   = patn+          , actionTokens    = fmap obj tokens+          , actionMatch     = match+          , actionCodeBlock = exec+          }++-- | Evaluate an executable function between evaluating all of the "BEGIN{}" and "END{}" statements.+betweenBeginAndEnd :: Exec a -> Exec a+betweenBeginAndEnd runInBetween = get >>= \xunit -> do+  -- Run all "BEGIN{}" procedures.+  mapM_ execute (preExec xunit)+  clearUncaughtErrorLog+  -- Run the given function, presumably it performs a string execution.+  a <- runInBetween+  -- Update the "global this" pointer to include the uncaught exceptions.+  errs <- OList . map new <$> clearUncaughtErrorLog+  let upd = M.union (M.singleton (ustr "errors") errs)+  referenceUpdate (Dao.Interpreter.reference GLOBAL (ustr "self")) False $ \o ->+    return $ Just $ ODict $ upd $ case o of { Just (ODict o) -> o; _ -> mempty; }+  -- Run all "END{}" procedures.+  mapM_ execute (postExec xunit)+  return a++-- | Evaluates the @EXIT@ scripts for every presently loaded dao program, and then clears the+-- 'Dao.Interpreter.importGraph', effectively removing every loaded dao program and idea file from memory.+daoShutdown :: Exec ()+daoShutdown = (M.elems <$> gets importGraph) >>=+  mapM_ (\xunit -> inModule xunit $ gets quittingTime >>= mapM_ execute)++-- | Returns a list of @'PatternTree' 'Object' ['Subroutine']@ objects from the global rule set and+-- the local rule set.+getLocalRuleSet :: Exec [PatternTree Object [Subroutine]]+getLocalRuleSet = do+  sub <- gets currentCodeBlock+  return $ maybe [] (return . staticRules) sub++-- | Returns a list of @'PatternTree' 'Object' ['Subroutine']@ objects from the global rule set and+-- the local rule set.+getGlobalRuleSet :: Exec [PatternTree Object [Subroutine]]+getGlobalRuleSet = return <$> gets ruleSet++_mkDoFunc :: String -> [Exec [PatternTree Object [Subroutine]]] -> (DaoFunc (), DaoFunc (), DaoFunc ())+_mkDoFunc name selectors = (mkDo, mkDoAll, mkQuery) where+  run f () ox = do+    inTrees <- concat <$> sequence selectors+    flip (,) () <$> (runTokenizer ox >>= makeActionsForQuery inTrees >>= f)+  mkQuery = daoFunc{daoFuncName=ustr("query"++name), daoForeignFunc=run(return . Just . obj . fmap obj)}+  mkDo    = daoFunc{daoFuncName=ustr("do"   ++name), daoForeignFunc=run(betweenBeginAndEnd . msum . fmap execute)}+  mkDoAll = daoFunc{daoFuncName=ustr("doAll"++name), daoForeignFunc=run(betweenBeginAndEnd . fmap (Just . obj) . execute)}++builtin_do    :: DaoFunc ()+builtin_doAll :: DaoFunc ()+builtin_query :: DaoFunc ()+(builtin_do, builtin_doAll, builtin_query) = _mkDoFunc "" [getLocalRuleSet, getGlobalRuleSet]++builtin_doLocal    :: DaoFunc ()+builtin_doAllLocal :: DaoFunc ()+builtin_queryLocal :: DaoFunc ()+(builtin_doLocal, builtin_doAllLocal, builtin_queryLocal) = _mkDoFunc "Local" [getLocalRuleSet]++builtin_doGlobal    :: DaoFunc ()+builtin_doAllGlobal :: DaoFunc ()+builtin_queryGlobal :: DaoFunc ()+(builtin_doGlobal, builtin_doAllGlobal, builtin_queryGlobal) = _mkDoFunc "Global" [getGlobalRuleSet]++----------------------------------------------------------------------------------------------------++-- | When a 'Dao.Interpreter.AST.RuleExpr' is evaluated to an 'Object', it takes this form.+-- 'PatternRule' instantiats 'Executable' such that 'execute' converts it to a 'PatternTree'.+data PatternRule+  = PatternRule{ rulePatterns :: [Object], ruleAction :: Subroutine }+  deriving (Show, Typeable)++instance NFData PatternRule where { rnf (PatternRule a b) = deepseq a $! deepseq b () }++instance HasNullValue PatternRule where+  nullValue = PatternRule{rulePatterns=[], ruleAction=nullValue}+  testNull (PatternRule a b) = null a && testNull b++instance PPrintable PatternRule where+  pPrint (PatternRule pats exe) = (\a -> ppCallableAction "rule" a nullValue exe) $ case pats of+    []    -> pString "()"+    [pat] -> pPrint pat+    pats  -> pList (pString "rule") "(" ", " ")" (map pPrint pats)++instance ToDaoStructClass PatternRule where+  toDaoStruct = renameConstructor "PatternRule" $ do+    "patterns" .=@ rulePatterns+    "action"   .=@ ruleAction++instance FromDaoStructClass PatternRule where+  fromDaoStruct = return PatternRule <*> req "patterns" <*> req "action"++instance Executable PatternRule (PatternTree Object [Subroutine]) where+  execute (PatternRule{ rulePatterns=pats, ruleAction=sub }) = do+    globs <- mapM (constructPattern . return) pats+    return $ insertMultiPattern (++) globs [sub] mempty++instance ObjectClass PatternRule where { obj=new; fromObj=objFromHata; }++instance HataClass PatternRule where+  haskellDataInterface = interface "PatternRule" $ do+    autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct++defaultTokenizer :: ExecTokenizer+defaultTokenizer = ExecTokenizer $ return . fmap obj . simpleTokenizer . uchars++-- | This function takes a list of objects and constructs a list of @('Dao.Glob.Glob' 'Object')@s to+-- be inserted into a 'Dao.Glob.PatternTree' object. The input list of @['Object']@s will each form+-- a single pattern, then all of the patterns are unioned together to form the pattern tree. This+-- means token strings matched against the resulting @('Dao.Glob.Glob' 'Object')@ constructed by+-- this function will match any and all of the patterns.  If any of the objects in the input list+-- are strings, the strings will be parsed into 'Dao.Glob.Glob' objects, and each string constant+-- within the 'Dao.Glob.Glob' object will be further tokenized with the 'programTokenizer'.+constructPatternWith :: ExecTokenizer -> [Object] -> Exec (Glob Object)+constructPatternWith tok = fmap (mconcat . mconcat) . mapM (derefObject>=>construct) where+  construct o = case o of+    OString o -> case readsPrec 0 (uchars o) of+      [(glob, "")] -> fmap return $ parseOverSinglesM glob $ \str -> case str of+        ""  -> return []+        str -> fmap obj <$> runExecTokenizer tok (ustr str)+      _ -> execThrow "unable to parse pattern" ExecErrorUntyped []+    OList ox -> return [makeGlob $ fmap Single ox]+    OHaskell (Hata _ d) -> do+      let err = throwBadTypeError "could not use as pattern expression" o []+      maybe err return $ msum $+        [ return <$> fromDynamic d+        , fmap (makeGlob . fst) . T.assocs . ruleSetRules <$> fromDynamic d+        ]+    _ -> throwBadTypeError "could not create pattern from data of type" o []++-- | Like 'constructPatternWith' but uses the default 'ExecTokenizer' that has been set for the+-- current 'ExecUnit'.+constructPattern :: [Object] -> Exec (Glob Object)+constructPattern ox = gets programTokenizer >>= flip constructPatternWith ox++----------------------------------------------------------------------------------------------------++-- The stateful data for the 'DaoSetup' monad.+data SetupModState+  = SetupModState+    { daoSatisfies      :: M.Map UStr ()+      -- ^ a set of references that can satisfy "required" statements in Dao scripts.+    , daoSetupConstants :: M.Map Name Object+    , daoClasses        :: MethodTable+    , daoEntryPoint     :: Exec ()+    }++-- | This monadic type allows you to define a built-in module using procedural+-- programming syntax. Simply define each addition to the module one line at a time. Functions that+-- you can use include 'modProvides', 'modFunction', 'daoClass', and 'daoInitalize'.+-- +-- Define clever names for every 'DaoSetup' you write, then +type DaoSetup = DaoSetupM ()+newtype DaoSetupM a = DaoSetup{ daoSetupM :: State SetupModState a }+  deriving (Functor, Applicative, Monad)++-- | This function is a placeholder used by the type system. The value of this function is+-- undefined, so strictly evaluating it will throw an exception. Fortunately, the only time you will+-- ever use this function is with the 'daoClass' function, which uses the type of this function but+-- never it's value. Refer to the documentation on 'daoClass' to see how to properly use this+-- function.+haskellType :: HataClass o => o+haskellType = error $ unwords $+  [ "the haskellType function is just a placeholder"+  , "used by the type system, it must not be evaluated."+  ]++_updateSetupModState :: (SetupModState -> SetupModState) -> DaoSetup+_updateSetupModState f = DaoSetup (modify f)++-- | Dao programs can declare "requires" statements along with it's imports. If your built-in module+-- provides what Dao programs might "required", then declare that this module provides that feature+-- using this function.+daoProvides :: UStrType s => s -> DaoSetup+daoProvides label = _updateSetupModState $ \st ->+  st{ daoSatisfies = M.insert (toUStr label) () $ daoSatisfies st }++-- | Associate an 'HataClass' with a 'Name'. This 'Name' will be callable from within Dao scripts.+-- > newtype MyClass = MyClass { ... } deriving (Eq, Ord)+-- >+-- > instance 'HataClass' MyClass where+-- >     'haskellDataInterface' = 'interface' $ do+-- >         'autoDefEquality'+-- >         'autoDefOrdering'+-- >         ...+-- >+-- > setupDao :: 'DaoSetup'+-- > setupDao = do+-- >     daoClass "myClass" (haskellType::MyClass)+-- >     ...+daoClass :: (Typeable o, HataClass o) => o -> DaoSetup+daoClass ~o = _updateSetupModState $ \st ->+  st{ daoClasses = _insertMethodTable o haskellDataInterface (daoClasses st) }++-- | Define a built-in top-level function that is not a member method of any object. Examples of+-- built-in functions provided in this module are "println()" and "typeof()".+daoFunction :: (Show name, UStrType name) => name -> DaoFunc () -> DaoSetup+daoFunction name func = _updateSetupModState $ \st -> let nm = (fromUStr $ toUStr name) in+  st{ daoSetupConstants = M.insert nm (new $ func{ daoFuncName=nm }) (daoSetupConstants st) }++-- | Like 'daoFunction' but creates a function that takes no parameters.+daoFunction0 :: Name -> Exec (Maybe Object) -> DaoSetup+daoFunction0 name f = daoFunction name $+  DaoFunc+  { daoFuncClass = []+  , daoFuncName  = nil+  , funcAutoDerefParams = False+  , daoForeignFunc = \ () ox -> case ox of+      [] -> flip (,) () <$> f+      _  -> throwArityError "" 0 ox [(errInFunc, obj $ reference UNQUAL name)]+  }++-- | Define a constant value for any arbitrary 'Object'.+daoConstant :: (Show name, UStrType name) => name -> Object -> DaoSetup+daoConstant name o = _updateSetupModState $ \st ->+  st{ daoSetupConstants = M.insert (fromUStr $ toUStr name) o (daoSetupConstants st) }++-- | Provide an 'Exec' monad to perform when 'setupDao' is evaluated. You may use this function as+-- many times as you wish, every 'Exec' monad will be executed in the order they are specified. This+-- is a good way to create a read-eval-print loop.+daoInitialize :: Exec () -> DaoSetup+daoInitialize f = _updateSetupModState $ \st -> st{ daoEntryPoint = daoEntryPoint st >> f }++-- | Use this function evaluate a 'DaoSetup' in the IO () monad. Use this to define the 'main'+-- function of your program.+setupDao :: DaoSetup -> IO (Predicate ExecControl ())+setupDao setup0 = do+  let setup = execState (daoSetupM $ loadEssentialFunctions >> setup0) $+        SetupModState+        { daoSatisfies      = M.empty+        , daoSetupConstants = M.empty+        , daoClasses        = mempty+        , daoEntryPoint     = return ()+        }+  xunit  <- _initExecUnit+  fmap fst $ ioExec (daoEntryPoint setup) $+    xunit+    { providedAttributes = daoSatisfies setup+    , builtinConstants   = daoSetupConstants setup+    , globalMethodTable  = daoClasses setup+    }++-- | Simply run a single 'Exec' function in a fresh environment with no setup, and delete the+-- envrionment when finished returning only the 'Dao.Predicate.Predicate' result of the 'Exec'+-- evaluation. If you want to have more control over the runtime in which the 'Exec' function runs,+-- use 'setupDao' with 'daoInitialize'.+evalDao :: Exec a -> IO (Predicate ExecControl a)+evalDao f = _initExecUnit >>= fmap fst . ioExec f++----------------------------------------------------------------------------------------------------++-- | All object methods that operate on object data types built-in to the Dao language, or built-in+-- to a library extending the Dao language, are stored in 'Data.Map.Map's from the functions name to+-- an object of this type.+--+-- The @this@ of this function is the data type of what languages like C++ or Java would call the+-- "self" variable. 'DaoFunc's where the @this@ is () are considered ordinary functions that do not+-- operate on any object apart from their input parameters.+data DaoFunc this+  = DaoFunc+    { daoFuncClass        :: [Name]+    , daoFuncName         :: Name+    , funcAutoDerefParams :: Bool+    , daoForeignFunc      :: this -> [Object] -> Exec (Maybe Object, this)+    }+  deriving Typeable+instance Eq   (DaoFunc this) where { a == b = daoFuncName a == daoFuncName b; }+instance Ord  (DaoFunc this) where { compare a b = compare (daoFuncName a) (daoFuncName b) }+instance Show (DaoFunc this) where+  show func =+    if null (daoFuncClass func)+    then uchars (daoFuncName func)+    else foldr (\name str -> uchars name ++ "." ++ str) (uchars $ daoFuncName func) (daoFuncClass func)+instance PPrintable (DaoFunc this) where { pPrint = pShow }++-- | Use this as the constructor of a 'DaoFunc'. By default the @this@ type is (). To change the+-- @this@ type, simply supply a different function type for the 'daoForeignFunc' field. For example:+-- > daoFunc{ daoFuncName=ustr "add", daoForeignFunc = retrun . (+1) } :: DaoFunc Int+daoFunc :: DaoFunc typ+daoFunc =+  DaoFunc+  { daoFuncClass        = []+  , daoFuncName         = nil+  , funcAutoDerefParams = True+  , daoForeignFunc      = \typ _ -> return (Nothing, typ)+  }++-- | Execute a 'DaoFunc' +executeDaoFunc :: DaoFunc this -> this -> [Object] -> Exec (Maybe Object, this)+executeDaoFunc fn this params = do+  args <- (if funcAutoDerefParams fn then mapM derefObject else return) params+  pval <- catchPredicate (daoForeignFunc fn this args)+  case pval of+    OK            (o, this) -> return (o, this)+    PFail (ExecReturn    o) -> return (o, this)+    PFail              err  -> throwError err+    Backtrack               -> mzero++-- Evaluate this function as one of the instructions in the monadic function passed to the+-- 'setupDao' function in order to install the most fundamental functions into the Dao evaluator.+-- This function must be evaluated in order to have access to the following functions:+-- > print, join, defined, delete+loadEssentialFunctions :: DaoSetup+loadEssentialFunctions = do+  daoClass (haskellType :: H.HashMap Object Object)+  daoClass (haskellType :: RuleSet)+  daoClass (haskellType :: Pair)+  daoFunction "print"    builtin_print+  daoFunction "println"  builtin_println+  daoFunction "join"     builtin_join+  daoFunction "str"      builtin_str+  daoFunction "quote"    builtin_quote+  daoFunction "concat"   builtin_concat+  daoFunction "concat1"  builtin_concat1+  daoFunction "reverse"  builtin_reverse+  daoFunction "int"      builtin_int+  daoFunction "long"     builtin_long+  daoFunction "ratio"    builtin_ratio+  daoFunction "float"    builtin_float+  daoFunction "complex"  builtin_complex+  daoFunction "imag"     builtin_imag+  daoFunction "phase"    builtin_phase+  daoFunction "conj"     builtin_conj+  daoFunction "abs"      builtin_abs+  daoFunction "time"     builtin_time+  daoFunction "now"      builtin_now+  daoFunction "ref"      builtin_ref+  daoFunction "defined"  builtin_check_if_defined+  daoFunction "delete"   builtin_delete+  daoFunction "typeof"   builtin_typeof+  daoFunction "sizeof"   builtin_sizeof+  daoFunction "call"     builtin_call+  daoFunction "toHash"   builtin_toHash+  daoFunction "fromHash" builtin_fromHash+  daoFunction "tokenize" builtin_tokenize+  daoFunction "query"    builtin_query+  daoFunction "doAll"    builtin_doAll+  daoFunction "do"       builtin_do+  daoFunction "fromStruct"  builtin_fromStruct+  daoFunction "toStruct"    builtin_toStruct+  daoFunction "queryGlobal" builtin_queryGlobal+  daoFunction "doAllGlobal" builtin_doAllGlobal+  daoFunction "doGlobal"    builtin_doGlobal+  daoFunction "queryLocal"  builtin_queryLocal+  daoFunction "doAllLocal"  builtin_doAllLocal+  daoFunction "doLocal"     builtin_doLocal+  daoFunction "HashMap"     builtin_HashMap+  daoFunction "assocs"      builtin_assocs+  daoFunction "Pair"        builtin_Pair+  mapM_ (uncurry daoConstant) $ flip fmap [minBound..maxBound] $ \t ->+    (toUStr $ show t, OType $ objTypeFromCoreType t)++instance ObjectClass (DaoFunc ())      where { obj=new; fromObj=objFromHata; }+instance ObjectClass (DaoFunc Dynamic) where { obj=new; fromObj=objFromHata; }+instance ObjectClass (DaoFunc Hata)    where { obj=new; fromObj=objFromHata; }+instance ObjectClass (DaoFunc Object)  where { obj=new; fromObj=objFromHata; }++instance HataClass (DaoFunc ()) where+  haskellDataInterface = interface "Builtin_Function" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter++instance HataClass (DaoFunc Dynamic) where+  haskellDataInterface = interface "Builtin_Dynamic_Method" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter++instance HataClass (DaoFunc Hata) where+  haskellDataInterface = interface "Builtin_Haskell_Data_Method" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter++instance HataClass (DaoFunc Object) where+  haskellDataInterface = interface "Builtin_Object_Method" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++-- | This class provides a consistent interface, the 'obj' function, for converting a wide range of+-- types to an 'Object' type.+class ObjectClass o where+  obj            :: o -> Object+  fromObj        :: Object -> Maybe o+  castToCoreType :: CoreType -> o -> XPure Object+  castToCoreType _ _ = mzero++execCastToCoreType :: ObjectClass o => CoreType -> o -> Exec Object+execCastToCoreType t = execute . castToCoreType t++instance ObjectClass () where+  obj () = ONull+  fromObj o = case o of { ONull -> return (); _ -> mzero; }+  castToCoreType t () = case t of+    NullType     -> return ONull+    CharType     -> return $ OChar '\0'+    IntType      -> return $ OInt 0+    WordType     -> return $ OWord 0+    LongType     -> return $ OLong 0+    DiffTimeType -> return $ ORelTime 0+    FloatType    -> return $ OFloat 0+    RatioType    -> return $ ORatio 0+    ComplexType  -> return $ OComplex $ complex 0 0+    StringType   -> return $ OString nil+    BytesType    -> return $ OBytes mempty+    ListType     -> return $ OList []+    DictType     -> return $ ODict mempty+    _            -> mzero++instance ObjectClass Bool where+  obj true = if true then OTrue else ONull+  fromObj o = case o of { OTrue -> return True; ONull -> return False; _ -> mzero }+  castToCoreType t o = case t of+    NullType     -> guard (not o) >> return ONull+    TrueType     -> guard o >> return OTrue+    CharType     -> return $ OChar    $ if o then '1' else '0'+    IntType      -> return $ OInt     $ if o then 1 else 0+    WordType     -> return $ OWord    $ if o then 1 else 0+    LongType     -> return $ OLong    $ if o then 1 else 0+    DiffTimeType -> return $ ORelTime $ if o then 1 else 0+    FloatType    -> return $ OFloat   $ if o then 1 else 0+    RatioType    -> return $ ORatio   $ if o then 1 else 0+    ComplexType  -> return $ OComplex $ if o then complex 1 0 else complex 0 0+    StringType   -> return $ obj      $ if o then "true" else "false"+    BytesType    -> return $ OBytes $ B.pack $ return $ if o then 1 else 0+    _            -> mzero++instance ObjectClass Char where+  obj = OChar+  fromObj o = case o of { OChar o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o=='\0') >> return ONull+    TrueType     -> \o -> case o of+      '0' -> return ONull+      '1' -> return OTrue+      _   -> mzero+    CharType     -> return . OChar+    IntType      -> return . OInt     . ord+    WordType     -> return . OWord    . fromIntegral . ord+    LongType     -> return . OLong    . fromIntegral . ord+    DiffTimeType -> return . ORelTime . fromRational . toRational . ord+    FloatType    -> return . OFloat   . fromRational . toRational . ord+    RatioType    -> return . ORatio   . toRational   . ord+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational . ord+    StringType   -> return . obj      . (:[])+    BytesType    -> return . OBytes . D.runPut . D.putWord64le . fromIntegral . ord+    _            -> \ _ -> mzero++charFromIntegral :: (MonadPlus m, Integral i) => i -> m Char+charFromIntegral i0 =+  let i = fromIntegral i0+  in if ord(minBound::Char) <= i && i <= ord(maxBound::Char) then return (chr i) else mzero++instance ObjectClass Int where+  obj = OInt+  fromObj o = case o of { OInt o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o==0) >> return ONull+    TrueType     -> \o -> return $ if o==0 then ONull else OTrue+    CharType     -> fmap OChar . charFromIntegral+    IntType      -> return . OInt+    WordType     -> return . OWord    . fromIntegral+    LongType     -> return . OLong    . toInteger+    FloatType    -> return . OFloat   . fromRational   . toRational+    RatioType    -> return . ORatio   . toRational+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational+    DiffTimeType -> return . ORelTime . fromRational   . toRational+    StringType   -> return . obj      . prettyShow     . obj+    BytesType    -> return . OBytes . D.runPut . D.putWord64le . fromIntegral+    _            -> \ _ -> mzero++instance ObjectClass Word where+  obj = OWord . fromIntegral+  fromObj o = case o of { OWord o -> return (fromIntegral o); _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o==0) >> return ONull+    TrueType     -> \o -> return $ if o==0 then ONull else OTrue+    CharType     -> fmap OChar . charFromIntegral+    IntType      -> return . OInt     . fromIntegral+    WordType     -> return . OWord    . fromIntegral+    LongType     -> return . OLong    . toInteger+    FloatType    -> return . OFloat   . fromRational . toRational+    RatioType    -> return . ORatio   . toRational+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational+    DiffTimeType -> return . ORelTime . fromRational . toRational+    StringType   -> return . obj      . prettyShow . obj+    BytesType    -> return . OBytes . D.runPut . D.putWord64le . fromIntegral+    _            -> \ _ -> mzero++instance ObjectClass Word64 where+  obj = OWord+  fromObj o = case o of { OWord o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o==0) >> return ONull+    TrueType     -> \o -> return $ if o==0 then ONull else OTrue+    CharType     -> fmap OChar . charFromIntegral+    IntType      -> return . OInt     . fromIntegral+    WordType     -> return . OWord+    LongType     -> return . OLong    . toInteger+    FloatType    -> return . OFloat   . fromRational . toRational+    RatioType    -> return . ORatio   . toRational+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational+    DiffTimeType -> return . ORelTime . fromRational . toRational+    StringType   -> return . obj      . prettyShow . obj+    BytesType    -> return . OBytes   . D.runPut . D.putWord64le . fromIntegral+    _            -> \ _ -> mzero++instance ObjectClass Integer where+  obj = OLong+  fromObj o = case o of { OLong o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o==0) >> return ONull+    TrueType     -> \o -> return $ if o==0 then ONull else OTrue+    CharType     -> fmap OChar . charFromIntegral+    IntType      -> return . OInt     . fromInteger+    WordType     -> return . OWord    . fromInteger+    LongType     -> return . OLong+    FloatType    -> return . OFloat   . fromRational . toRational+    RatioType    -> return . ORatio   . toRational+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational+    DiffTimeType -> return . ORelTime . fromRational . toRational+    StringType   -> return . obj      . show+    BytesType    -> return . OBytes . B.reverse . D.encode+    _            -> \ _ -> mzero++instance ObjectClass NominalDiffTime where+  obj = ORelTime+  fromObj o = case o of { ORelTime o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (toRational o == 0) >> return ONull+    TrueType     -> \o -> return $ if toRational o == 0 then ONull else OTrue+    IntType      -> return . OInt . round+    WordType     -> return . OWord . round+    LongType     -> return . OLong . round+    FloatType    -> return . OFloat . fromRational . toRational+    DiffTimeType -> return . ORelTime+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational+    _            -> \ _ -> mzero++instance ObjectClass Double where+  obj = OFloat+  fromObj o = case o of { OFloat o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o==0) >> return ONull+    TrueType     -> \o -> return $ if o==0 then ONull else OTrue+    CharType     -> fmap OChar . charFromIntegral . (round :: Double -> Int)+    IntType      -> return . OInt     . round+    WordType     -> return . OWord    . round+    LongType     -> return . OLong    . round+    FloatType    -> return . OFloat+    RatioType    -> return . ORatio   . toRational+    ComplexType  -> return . OComplex . flip complex 0 . fromRational . toRational+    DiffTimeType -> return . ORelTime . fromRational . toRational+    StringType   -> return . obj      . show+    BytesType    -> return . OBytes . D.encode+    _            -> \ _ -> mzero++instance ObjectClass Rational where+  obj = ORatio+  fromObj o = case o of { ORatio o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (o==0) >> return ONull+    TrueType     -> \o -> return $ if o==0 then ONull else OTrue+    CharType     -> fmap OChar . charFromIntegral . (round :: Rational -> Int)+    IntType      -> return . OInt     . round+    WordType     -> return . OWord    . round+    LongType     -> return . OLong    . round+    FloatType    -> return . OFloat   . fromRational+    RatioType    -> return . ORatio+    ComplexType  -> return . OComplex . flip complex 0 . fromRational+    DiffTimeType -> return . ORelTime . fromRational . toRational+    StringType   -> return . obj      . prettyShow . obj+    _            -> \ _ -> mzero++instance ObjectClass Complex where+  obj = OComplex+  fromObj o = case o of { OComplex o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType     -> \o -> guard (complex 0 0 == o) >> return ONull+    TrueType     -> \o -> return $ if complex 0 0 == o then ONull else OTrue+    IntType      -> i OInt+    WordType     -> return . OWord . round . magnitude+    LongType     -> i OLong+    FloatType    -> f OFloat+    RatioType    -> f ORatio+    ComplexType  -> return . OComplex+    DiffTimeType -> f ORelTime+    StringType   -> return . obj . prettyShow+    _            -> \ _ -> mzero+    where+      f constr o = guard (imagPart o == 0) >> return (constr $ fromRational $ toRational $ realPart o)+      i constr = f (constr . fromInteger . (round :: Rational -> Integer))++instance ObjectClass UStr where+  obj = OString+  fromObj o = case o of { OString o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    StringType -> return . OString+    _          -> castToCoreType t . uchars++instance ObjectClass String where+  obj = obj . toUStr+  fromObj = fromObj >=> maybeFromUStr+  castToCoreType t = case t of+      NullType   -> \o -> guard (o=="null") >> return ONull+      TrueType   -> \o -> case map toLower o of+        "true"   -> return OTrue+        "yes"    -> return OTrue+        "no"     -> return ONull+        "false"  -> return ONull+        "null"   -> return ONull+        _        -> mzero+      IntType    -> pars OInt+      WordType   -> pars OWord+      LongType   -> pars OLong+      FloatType  -> pars OFloat+      TimeType   -> pars OAbsTime+      StringType -> return . OString . ustr+      RefType    -> pars ORef+      _          -> \ _ -> mzero+    where+      nospc = dropWhile isSpace+      pars f str = case fmap (reverse . nospc . reverse) <$> readsPrec 0 (nospc str) of+        [(o, "")] -> return (f o)+        _         -> mzero++instance ObjectClass B.ByteString where+  obj = OBytes+  fromObj o = case o of { OBytes o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    NullType  -> f (D.isEmpty >>= guard >> return ONull)+    TrueType  ->+      f (D.getWord8 >>= \w ->+          return $ case w of { 0->Just ONull; 1->Just OTrue; _->mzero; }) >=> xmaybe+    CharType  -> fmap OChar . (f D.getWord64le >=> charFromIntegral)+    IntType   -> fmap (OInt . fromIntegral) . f D.getWord64le+    WordType  -> fmap (OWord . fromIntegral) . f D.getWord64le+    LongType  -> return . OLong . D.decode . B.reverse+    FloatType -> return . OFloat . D.decode+    _         -> \ _ -> mzero+    where+      f :: D.Get o -> B.ByteString -> XPure o+      f get = return . D.runGet get++instance ObjectClass [Object] where+  obj = OList+  fromObj o = case o of { OList o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    StringType -> fmap OList . loop return+    BytesType  -> fmap (OBytes . D.runPut . mapM_ D.putLazyByteString) . loop (\ (OBytes o) -> [o])+    ListType   -> return . OList+    _          -> \ _ -> mzero+    where+      loop f = fmap concat .+        mapM (\o -> (xmaybe (fromObj o) >>= loop f) <|> (f <$> castToCoreType t o))++instance ObjectClass (M.Map Name Object) where+  obj = ODict+  fromObj o = case o of { ODict o -> return o; _ -> mzero; }+  castToCoreType t o = case t of+    NullType -> guard (M.null o) >> return ONull+    DictType -> return $ ODict o+    _        -> mzero++instance ObjectClass Reference where+  obj = ORef+  fromObj o = case o of { ORef o -> return o; _ -> mzero; }+  castToCoreType t o = case t of+    StringType -> return $ obj $ '$':prettyShow o+    RefType    -> return (ORef o)+    _          -> mzero++instance ObjectClass Name where+  obj n = ORef $ Reference UNQUAL n NullRef+  fromObj o = case o of+    OString o -> maybeFromUStr o+    ORef (Reference UNQUAL name NullRef) -> return name+    _ -> mzero++instance ObjectClass ObjType where+  obj = OType+  fromObj o = case o of { OType o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    TypeType   -> return . OType+    StringType -> return . obj . prettyShow+    _          -> \ _ -> mzero++instance ObjectClass CoreType where+  obj = OType . objTypeFromCoreType+  fromObj o = case o of+    OType (ObjType [TypeStruct [CoreType o]]) -> return o+    _ -> mzero+  castToCoreType t = case t of+    IntType    -> return . OInt  . fromIntegral . fromEnum+    WordType   -> return . OWord . fromIntegral . fromEnum+    LongType   -> return . OLong . fromIntegral . fromEnum+    StringType -> return . obj   . show+    TypeType   -> return . obj+    _          -> \ _ -> mzero++instance ObjectClass Struct where+  obj = OTree+  fromObj o = case o of { OTree o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    TreeType   -> return . OTree+    RefType    -> return . obj . structName+    StringType -> return . obj . prettyShow+    _          -> \ _ -> mzero++instance ObjectClass UTCTime where+  obj = OAbsTime+  fromObj o = case o of { OAbsTime o -> return o; _ -> mzero; }+  castToCoreType t = case t of+    StringType -> return . obj . prettyShow . obj+    TimeType   -> return . OAbsTime+    _          -> \ _ -> mzero++instance ObjectClass Hata where+  obj = OHaskell+  fromObj o = case o of { OHaskell o -> return o; _ -> mzero; }++instance ObjectClass Dynamic where+  obj = opaque+  fromObj o = case o of { OHaskell (Hata _ o) -> return o; _ -> mzero; }++instance ObjectClass Object where+  obj = id;+  fromObj = return;+  castToCoreType t o = case o of+    ONull      ->  f False+    OTrue      ->  f True+    OChar    o ->  f o+    OInt     o ->  f o+    OWord    o ->  f o+    OLong    o ->  f o+    OAbsTime o ->  f o+    OFloat   o ->  f o+    ORatio   o ->  f o+    OComplex o ->  f o+    OString  o ->  f o+    OBytes   o ->  f o+    OList    o ->  f o+    ODict    o ->  f o+    ORef     o ->  f o+    OType    o ->  f o+    OTree    o ->  f o+    ORelTime o ->  f o+    OHaskell _ -> mzero+    where+      f :: ObjectClass o => o -> XPure Object+      f = castToCoreType t++instance ObjectClass Location where { obj=new; fromObj=objFromHata; }++instance ObjectClass Comment where { obj=new; fromObj=objFromHata; }++instance ObjectClass [Comment] where { obj=listToObj; fromObj=listFromObj; }++instance ObjectClass DotNameExpr where { obj=new; fromObj=objFromHata; }++instance ObjectClass AST_DotName where { obj=new; fromObj=objFromHata; }++instance ObjectClass DotLabelExpr where { obj=new; fromObj=objFromHata; }++instance ObjectClass AST_DotLabel where { obj=new; fromObj=objFromHata; }++listToObj :: ObjectClass o => [o] -> Object+listToObj = OList . map obj++listFromObj :: ObjectClass o => Object -> Maybe [o]+listFromObj o = case o of+  OList o -> mapM fromObj o+  _       -> mzero++-- | Create a new 'Object' containing the original value and a reference to the 'Interface'+-- retrieved by the instance of 'haskellDataInterface' for the data type.+new :: (HataClass typ, Typeable typ) => typ -> Object+new = OHaskell . toHata++-- | Create a completely opaque haskell data type that can be used stored to a Dao language+-- variable, but never inspected or modified in any way.+opaque :: forall typ . Typeable typ => typ -> Object+opaque o = OHaskell $ flip Hata (toDyn o) $+  interfaceToDynamic (interface (show $ typeOf o) (return ()) :: Interface typ)++-- | The inverse operation of 'new', uses 'fromObj' and 'fromHata' to extract the data type+-- wrapped up in the 'Object', assuming the 'Object' is the 'OHaskell' constructor holding a+-- 'Hata' container.+objFromHata :: (Typeable o, HataClass o) => Object -> Maybe o+objFromHata = fromObj >=> fromHata++----------------------------------------------------------------------------------------------------++-- | This is the "Haskell Data" data type used to wrap-up a Haskell data types into a+-- 'Data.Dynamic.Dynamic' data type and associate this dynamic data with the 'Interface' used by the+-- runtime to read and modify the data. Whenever an non-primitive 'Object' is created, the data is+-- converted to a 'Data.Dynamic.Dynamic' value and paired with a copy of the 'Interface'.+data Hata = Hata (Interface Dynamic) Dynamic deriving Typeable++instance Eq Hata where+  Hata ifcA a == Hata ifcB b =+    ((ifcA==ifcB)&&) $ maybe False id $ objEquality ifcA >>= \eq -> return (eq a b)++instance Ord Hata where+  compare (Hata ifcA a) (Hata ifcB b) = maybe err id $+    guard (ifcA==ifcB) >> objOrdering ifcA >>= \comp -> return (comp a b) where+      err = error $ unwords $+        [ "cannot compare object of type", show (objHaskellType ifcA)+        , "with obejct of type", show (objHaskellType ifcB)+        ]++instance Show Hata where { show (Hata o _) = show (objHaskellType o) }++instance NFData Hata where { rnf (Hata _ _) = () }++instance PPrintable Object where+  pPrint o = case o of+    ONull            -> pString "null"+    OTrue            -> pString "true"+    OChar      o     -> pShow o+    OInt       o     -> pShow o+    OWord      o     -> pString (show o++"U")+    OLong      o     -> pString (show o++"L")+    ORelTime   o     -> pShow o+    OFloat     o     -> pString (show o++"f")+    ORatio     o     ->+      if denominator o == 1+        then  pString (show (numerator o)++"R")+        else  pWrapIndent $+                [ pString "(", pString (show (numerator o)), pString "/"+                , pString (show (denominator o)++"R"), pString ")"+                ]+    OComplex   o     -> pPrint o+    OString    o     -> pShow o+    OBytes     o     ->+      if B.null o+        then  pString "data{}"+        else  pList (pString "data") "{" ", " "}" (map (pString . showHex) (B.unpack o))+    OList      ox    -> if null ox then pString "list{}" else pContainer "list " pPrint ox+    ODict      o     ->+      if M.null o+      then pString "dict{}"+      else pContainer "dict " (\ (a, b) -> pWrapIndent [pPrint a, pString " = ", pPrint b]) (M.assocs o)+    ORef       o     -> pPrint o+    OType      o     -> pPrint o+    OTree      o     -> pPrint o+    OAbsTime   o     -> pString ("date "++show o)+    OHaskell (Hata ifc o) -> case objPPrinter ifc of+      Nothing -> fail $ "cannot pretty print Haskell data type: "++show (objHaskellType ifc)+      Just pp -> pp o++instance B.Binary Hata MTab where+  put (Hata ifc o) = do+    let typeName = objInterfaceName ifc +    mtab <- B.getCoderTable+    case B.getEncoderForType typeName mtab of+      Just fn -> do+        tid  <- B.newInStreamID typeName+        B.put tid >> B.putWithBlockStream1M (fn o)+      Nothing -> fail $ unwords ["no binary format method defied for Haskell type", uchars (toUStr typeName)]+  get = do+    B.updateTypes+    mtab <- B.getCoderTable+    tid  <- B.get >>= B.decodeIndexLookup+    maybe mzero id $ do+      tid <- tid+      fn  <- B.getDecoderForType tid mtab+      tab <- lookupMethodTable tid mtab+      return (Hata tab <$> B.getWithBlockStream1M fn)++instance HasNullValue Hata where+  nullValue = toHata ()+  testNull (Hata ifc o) = case objNullTest ifc of+    Nothing -> error ("to check whether objects of type "++show (objHaskellType ifc)++" are null is undefined behavior")+    Just fn -> fn o++-- | This is a convenience function for calling 'OHaskell' using just an initial value of type+-- @typ@. The 'Interface' is retrieved automatically using the instance of 'haskellDataInterface' for+-- the @typ@.+toHata :: (HataClass typ, Typeable typ) => typ -> Hata+toHata t = flip Hata (toDyn t) (interfaceTo t haskellDataInterface) where+  interfaceTo :: Typeable typ => typ -> Interface typ -> Interface Dynamic+  interfaceTo _ ifc = interfaceToDynamic ifc++-- | Inverse operation of 'toHata', useful when instantiating 'ObjectClass', uses+-- 'Data.Dynamic.fromDynamic' to extract the value that has been wrapped in up the 'Hata'+-- constructor.+fromHata :: (HataClass typ, Typeable typ) => Hata -> Maybe typ+fromHata (Hata _ o) = fromDynamic o++----------------------------------------------------------------------------------------------------++class Sizeable o where { getSizeOf :: o -> Exec Object  }++instance Sizeable Char where { getSizeOf = return . obj . ord }+instance Sizeable Word64 where { getSizeOf = return . obj }+instance Sizeable Int where { getSizeOf = return . obj . abs }+instance Sizeable Double where { getSizeOf = return . obj . abs }+instance Sizeable Integer where { getSizeOf = return . obj . abs }+instance Sizeable NominalDiffTime where { getSizeOf = return . obj . abs }+instance Sizeable Rational where { getSizeOf = return . obj . abs }+instance Sizeable Complex where { getSizeOf = return . obj . magnitude }+instance Sizeable UStr where { getSizeOf = return . obj . ulength }+instance Sizeable [Object] where { getSizeOf = return . obj . length }+instance Sizeable (M.Map Name Object) where { getSizeOf = return . obj . M.size }+instance Sizeable (H.HashMap Object Object) where { getSizeOf = return . obj . H.size }+instance Sizeable Hata where { getSizeOf (Hata ifc o) = maybe mzero ($ o) (objSizer ifc) }++instance Sizeable Object where+  getSizeOf o = case o of+    OChar    o -> getSizeOf o+    OWord    o -> getSizeOf o+    OInt     o -> getSizeOf o+    OLong    o -> getSizeOf o+    ORelTime o -> getSizeOf o+    OFloat   o -> getSizeOf o+    ORatio   o -> getSizeOf o+    OComplex o -> getSizeOf o+    OString  o -> getSizeOf o+    OList    o -> getSizeOf o+    ODict    o -> getSizeOf o+    OHaskell o -> getSizeOf o+    _          -> mzero++----------------------------------------------------------------------------------------------------++-- $Building_structs+-- Here are all the basic functions for converting between Haskell language data types and Dao+-- language structures.+-- +-- Most 'FromDaoStruct' functions will backtrack when they fail to get the necessary data. This+-- function can make a backtracking function fail. For example:+-- > 'tryField' "x" >>= 'objType'+-- backtracks in any case+-- +-- > required (tryField "x" >>= objType)+-- > tryField "x" >>= required objType+-- These two forms do the same thing: fails if 'objType' backtracks, but not if the field doesn't+-- exist.+-- +-- > 'Control.Applicative.optional' ('tryField' "x" >>= 'objType')+-- returns 'Prelude.Nothing' if the field does not exist or if 'objType' backtracks+-- +-- > 'field' "x" >>= 'objType'+-- fails if the field does not exist, backtracks if it exists but is the wrong type+-- (you probably don't ever want to do this).+-- +-- > 'required' ('field' "x" >>= 'objType')+-- > 'field' "x" >>= 'required' 'objType'+-- These two forms are the same: fails if either the field does not exist or if 'objType'+-- backtracks.++-- | This is the data type used as the intermediary between Haskell objects and Dao objects. If you+-- would like your Haskell data type to be used as a non-opaque data type in a Dao language script,+-- the first step is to instantiate your data type into this class. The next step would be to+-- instantiate your object into the 'HataClass' class. Instantiating the+-- 'HataClass' class alone will make your object usable in Dao language scripts, but+-- it will be an opaque type. Instantiating 'Struct' and declaring 'autoDefStruct' in the+-- 'defObjectInterface' will allow functions in the Dao language script to read and write+-- information to your data structure, modifying it during runtime.+-- +-- 'Struct' values are used lazily, so your data types will only be converted to and from 'Struct's+-- when absolutely necessary. This helps to conserver memory usage.+data Struct+  = Nullary{ structName :: Name }+    -- ^ models a constructor with no fields, for example 'Prelude.EQ', 'Prelude.GT' and+    -- 'Prelude.LT'.+  | Struct+    { structName :: Name -- ^ provide the name for this constructor.+    , fieldMap   :: M.Map Name Object+    }+  deriving (Eq, Ord, Show, Typeable)++structLookup :: Name -> Struct -> Maybe Object+structLookup name struct = case struct of+  Nullary{}            -> Nothing+  Struct{ fieldMap=m } -> M.lookup name m++instance NFData Struct where+  rnf (Nullary a  ) = deepseq a ()+  rnf (Struct  a b) = deepseq a $! deepseq b ()++instance HasNullValue Struct where+  nullValue = Nullary{ structName=ustr "NULL" }+  testNull (Nullary{ structName=name }) = name == ustr "NULL"+  testNull _ = False++-- binary 0x25 0x26+instance B.Binary Struct MTab where+  put o = case o of+    Nullary  o -> B.putWord8 0x25 >> B.put o+    Struct n o -> B.putWord8 0x26 >> B.put n >> B.put o+  get = B.word8PrefixTable <|> fail "expecting Struct"++instance B.HasPrefixTable Struct B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "Struct" 0x25 0x26 $+    [ Nullary <$> B.get+    , return Struct <*> B.get <*> B.get+    ]++instance PPrintable Struct where+  pPrint o = case o of+    Nullary{ structName=name } -> pString ('#' : uchars (toUStr name))+    Struct{ structName=name, fieldMap=dict } ->+      pList (pString ('#' : uchars (toUStr name))) "{" ", " "}" $+        flip map (M.assocs dict) $ \ (left, right) -> pInline $+          [pPrint left, pString " = ", pPrint right]++instance HasRandGen Struct where+  randO = _randTrace "Struct" $ countNode $ runRandChoice +  randChoice = randChoiceList $+    [ scramble $+        return Struct <*> randO <*> (M.fromList <$> randListOf 1 4 (pure (,) <*> randO <*> randO))+    , Nullary <$> randO+    ]+  defaultO = _randTrace "D.Struct" $ Nullary <$> defaultO++instance ToDaoStructClass Struct where { toDaoStruct = return () }++instance FromDaoStructClass Struct where { fromDaoStruct = FromDaoStruct $ lift get }++instance HataClass Struct where+  haskellDataInterface = interface "Struct" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++-- | You can make your data type readable but not writable in the Dao runtime. That means a Dao+-- script can inspect elements of your data type, but not modify them As an example lets say you+-- have a 3D-point data type you would like to use in your Dao script.+-- > data Finite =+-- >     Point2D{ get_x::'T_float', get_y::'T_float' }+-- >   | Point3D{ get_x::'T_float', get_y::'T_float', get_z::'T_float' }+-- +-- Lets say you have already instantiated the 'HataClass' class and provided the Dao runtime with+-- a 'DaoFunc' (via 'setupDao') that constructs a Point3D at runtime:+-- > p = Point3D(1.9, 4.4, -2.1);+-- Now you would like to extend the 'HataClass' of your Point3D to also be readable at runtime.+-- If you instantiate 'ToDaoStructClass' your Dao language script could also read elements from the+-- point like so:+-- > distFromOrigin = sqrt(p.x*p.x + p.y*p.y + p.z*p.z);+-- However you cannot modify the point unless you also instantiate 'FromDaoStructClass'. So a statement+-- like this would result in an error:+-- > p.x /= distFromOrigin;+-- > p.y /= distFromOrigin;+-- > p.z /= distFromOrigin;+-- +-- You can convert this to a 'Struct' type using the 'fromData' function. There are many ways to+-- define fields in a 'Struct', here are a few:+-- > instance 'ToDaoStructClass' Point3D 'Object' where+-- >     'toDaoStruct' = 'fromData' "@Point2D@" $ do+-- >         'putPrimField' "x" get_x+-- >         'putPrimField' "y" get_y+-- >          obj <- 'Control.Monad.Reader.Class.ask'+-- >          case obj of+-- >             Point3D _ _ z -> 'renameConstructor' "@Point3D@" $ do+-- >                 'define' "z" ('obj' z)+-- >             _             -> return ()+-- +-- Finally, you should define the instantiation of Point3D into the 'HataClass' class so it+-- includes the directive 'autoDefToStruct'.+class ToDaoStructClass haskData where { toDaoStruct :: ToDaoStruct haskData () }++-- | Continuing the example from above, if you do want your data type to be modifyable by functions+-- running in the Dao language runtime, you must instantiate this class, which is facilitated by the+-- 'toData' function.+-- > instance 'FromDaoStructClass' 'Point3D' where+-- >     fromDaoStruct = 'toData' $ 'Control.Monad.msum' $+-- >         [ do 'constructor' "@Point2D@"+-- >              return Point3D 'Control.Applicative.<*>' 'req' "x" 'Control.Applicative.<*>' 'req' "y"+-- >         , do 'constructor' "@Point3D@"+-- >              return Point3D 'Control.Applicative.<*>' 'req' "x" 'Control.Applicative.<*>' 'req' "y" 'Control.Applicative.<*>' 'req' "z"+-- >         ]+-- +-- Do not forget to define the instantiation of Point3D into the 'HataClass' class so it+-- includes the directive 'autoDefFromStruct'.+-- +-- Note that an instance of 'FromDaoStructClass' must also instantiate 'ToDaoStructClass'. I can see no+-- use for objects that are only writable, that is they can be created at runtime but never+-- inspected at runtime.+class ToDaoStructClass haskData => FromDaoStructClass haskData where+  fromDaoStruct :: FromDaoStruct haskData++-- | If there is ever an error converting to or from your Haskell data type, you can+-- 'Control.Monad.Error.throwError' a 'StructError'.+data StructError+  = StructError+    { structErrName   :: Maybe UStr+    , structErrField  :: Maybe UStr+    , structErrValue  :: Maybe Object+    , structErrExtras :: [Name]+    }+  deriving (Eq, Ord, Typeable)++instance PPrintable StructError where+  pPrint err = do+    let pp p msg f = case f err of+          Nothing -> return ()+          Just  o -> pString (msg++": ") >> p o >> pNewLine+    pp pUStr "on constructor" structErrName+    pp pUStr "on field" structErrField+    pp pPrint "with value" structErrValue+    let extras = structErrExtras err+    if null extras then return () else pString ("non-member fields: "++show extras)++instance HasNullValue StructError where+  nullValue =+    StructError+    { structErrName=Nothing+    , structErrField=Nothing+    , structErrValue=Nothing+    , structErrExtras=[]+    }+  testNull+    ( StructError+      { structErrName=Nothing+      , structErrField=Nothing+      , structErrValue=Nothing+      , structErrExtras=[]+      }+    ) = True+  testNull _ = False++pPrintStructForm :: ToDaoStructClass o => o -> PPrint+pPrintStructForm o = case fromData toDaoStruct o of+  PFail err -> pPrint err+  Backtrack -> pString "(### FAILED TO CONVERT OBJECT TO STRUCT ###)"+  OK struct -> pPrint struct++----------------------------------------------------------------------------------------------------++-- Used to instantiate 'MonadError.throwError' by both the 'ToDaoStruct' and 'FromDaoStruct' monads.+_structThrowError+  :: (MonadError ExecControl m)+  => (forall a . PredicateT ExecControl (State st) a -> m a) -> (st -> Struct) -> ExecControl -> m b+_structThrowError constr inside err =+  constr (lift $ gets inside) >>= \struct -> constr $ throwError $ case err of+    ExecError{execErrorSubtype = ExecStructError info} ->+      err { execErrorSubtype = ExecStructError $+              info{ structErrName = structErrName info <|> Just (toUStr $ structName struct) } }+    err -> err++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass StructError where+  toDaoStruct = renameConstructor "StructError" $ do+    asks structErrName   >>= optionalField "structName" . fmap OString+    asks structErrField  >>= optionalField "field" . fmap OString+    asks structErrValue  >>= optionalField "value"+    asks structErrExtras >>= optionalField "extras" . fmap obj . refNames++instance ToDaoStructClass (ParseError () DaoTT) where+  toDaoStruct = renameConstructor "ParseError" $ do+    asks parseErrMsg >>= ("message" .=?)+    asks parseErrMsg >>= ("onToken" .=?) . fmap show+    asks parseErrLoc >>= putLocation++instance FromDaoStructClass StructError where+  fromDaoStruct = do+    constructor "StructError"+    let str o = case o of+          OString o -> return o+          _         -> fail "expecting string value"+    let ref o = case o of+          ORef    o -> case o of+            Reference UNQUAL o NullRef -> return o+            _ -> fail "not an unqualified reference singleton"+          _ -> fail "not a reference type"+    let lst o = case o of+          OList   o -> forM o ref+          _         -> fail "expecting list value"+    return StructError+      <*> optional (tryField "structName" $ str)+      <*> optional (tryField "field" $ str)+      <*> optional (tryField "value" return)+      <*> (tryField "extras" $ lst)++instance ToDaoStructClass Comment where+  toDaoStruct = ask >>= \co -> case co of+    InlineComment  o -> renameConstructor "InlineComment"  $ "comment" .= o+    EndlineComment o -> renameConstructor "EndlineComment" $ "comment" .= o++instance FromDaoStructClass Comment where+  fromDaoStruct = msum $+    [ constructor "InlineComment"  >> InlineComment  <$> req "comment"+    , constructor "EndlineComment" >> EndlineComment <$> req "comment"+    ]++instance ToDaoStructClass AST_DotName where+  toDaoStruct = renameConstructor "DotName" $ ask >>= \ (AST_DotName coms n) -> case coms of+    Com () -> "name"     .= n+    coms   -> "comments" .= coms >> "name" .= n++instance FromDaoStructClass AST_DotName where+  fromDaoStruct = constructor "DotName" >>+    return AST_DotName <*> (maybe (Com ()) id <$> opt "comments") <*> req "name"++instance ToDaoStructClass AST_DotLabel where+  toDaoStruct = renameConstructor "DotLabel" $ do+    (AST_DotLabel n nx loc) <- ask+    "head" .= n+    "tail" .= OList (map obj nx)+    putLocation loc++instance FromDaoStructClass AST_DotLabel where+  fromDaoStruct = do+    constructor "DotLabel"+    let convert o = case sequence (map fromObj o) of+          Nothing -> fail "\"tail\" field must contain a list of \"#DotName\" data types."+          Just ox -> return ox+    return AST_DotLabel <*> req "head" <*> (req "tail" >>= convert) <*> location++instance ObjectClass StructError where { obj=new; fromObj=objFromHata; }++instance HataClass StructError where+  haskellDataInterface = interface "StructError" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest+    autoDefToStruct >> autoDefFromStruct++-- | Used to convert a 'Prelude.String' to a 'Dao.String.Name' by functions like 'define' and+-- 'setField'. Usually you will not need to use it.+mkLabel :: (UStrType name, MonadPlus m) => name -> m Name+mkLabel name = xmaybe $ maybeFromUStr (toUStr name)++mkStructName :: (UStrType name, MonadPlus m) => name -> m Name+mkStructName name = mplus (mkLabel name) $ fail "invalid constructor name"++mkFieldName :: (UStrType name, MonadPlus m) => name -> m Name+mkFieldName name = mplus (mkLabel name) $ fail "invalid field name"++-- | This is a handy monadic and 'Data.Functor.Applicative' interface for instantiating+-- 'toDaoStruct' in the 'ToDaoStructClass' class.+newtype ToDaoStruct haskData a+  = ToDaoStruct+    { _runToDaoStruct :: PredicateT ExecControl (State (Struct, haskData)) a }+  deriving (Functor, Applicative, Alternative, MonadPlus)++instance Monad (ToDaoStruct haskData) where+  return = ToDaoStruct . return+  m >>= f = ToDaoStruct $ _runToDaoStruct m >>= _runToDaoStruct . f+  fail msg = execThrow msg (ExecStructError nullValue) []++instance MonadState Struct (ToDaoStruct haskData) where+  state f = ToDaoStruct $ lift $ state $ \ (struct, haskData) ->+    let (a, struct') = f struct in (a, (struct', haskData))++instance MonadReader haskData (ToDaoStruct haskData) where+  ask = ToDaoStruct $ lift $ fmap snd get+  local upd f = ToDaoStruct $ PredicateT $ do+    haskData <- gets snd+    modify (\ (struct, _) -> (struct, upd haskData))+    a <- runPredicateT $ _runToDaoStruct f+    modify (\ (struct, _) -> (struct, haskData))+    return a++instance MonadError ExecControl (ToDaoStruct haskData) where+  throwError = _structThrowError ToDaoStruct fst+  catchError f catch = ToDaoStruct $ catchError (_runToDaoStruct f) (_runToDaoStruct . catch)++instance MonadPlusError ExecControl (ToDaoStruct haskData) where+  catchPredicate = ToDaoStruct . catchPredicate . _runToDaoStruct+  predicate      = ToDaoStruct . predicate++-- | This function is typically used to evaluate the instantiation of 'toDaoStruct'. It takes two+-- parameters: first a computation to convert your data type to the 'Struct' using the 'ToDaoStruct'+-- monad, and second the data type you want to convert. You can use functions like 'defineWith' and+-- 'setField' to build your 'ToDaoStruct' computation. For example, lets say you have a Haskell data+-- type called @mydat::MyData@ where @MyData@ instantiates 'ToDaoStruct', you can convert it to a+-- Dao 'Struct' like so:+-- > 'fromData' 'toDaoStruct' mydat+-- Notice how it reads similar to ordinary English, "convert from (Haskell) data to a Dao 'Struct'"+fromData+  :: ToDaoStruct haskData x+  -> haskData+  -> Predicate ExecControl Struct+fromData pred hask = evalState (runPredicateT $ _runToDaoStruct $ pred >> get) $+  (Struct{ structName=nil, fieldMap=M.empty }, hask)++toDaoStructExec :: ToDaoStruct typ x -> typ -> Exec Struct+toDaoStructExec toDaoStruct = (predicate :: Predicate ExecControl T_struct -> Exec T_struct) .+  fmapPFail ((\o -> newError{ execReturnValue=Just o}) . new) . fromData toDaoStruct++-- | Overwrite the current 'Struct' with a 'Struct' produced by a 'toDaoStruct' instance of a+-- different type. This is useful when instantiating a newtype or a data type constructor that+-- contains only one item (the "inner" item), and the data type of the inner item instantiates+-- 'ToDaoStructClass', you can simply use the instance of 'toDaoStruct' for that data type to+-- instantiate 'toDaoStruct' for the outer data type. Just be sure that the constructor name for the+-- inner type does not conflict with the constructor name for the outer data type. For example:+-- > data X = X1 { ... } | X2 { ... }+-- > instance 'DaoToStructClass' X 'Object' where { ... }+-- > data Y = Y1 { ... } | Y2 { ... }+-- > instance 'DaoToStructClass' Y 'Object' where { ... }+-- > +-- > newtype WrapX = WrapX { unwrapX :: X }+-- > instance 'DaoToStructClass' WrapX 'Object' where+-- >     'toDaoStruct' = 'Control.Monad.Reader.ask' >>= 'innerToStruct' . unwrapX+-- > +-- > data X_or_Y = Is_X { getX :: X } | Is_Y { getY :: Y }+-- > instance 'DaoToStructClass' X_or_Y 'Object' where+-- >     'toDaoStruct' = 'Control.Monad.Reader.ask' >>= \xy -> case xy of+-- >         Is_X x -> 'innerToStruct' x+-- >         Is_Y y -> 'innerToStruct' y+-- +-- The inverse of this operation in the 'FromDaoStructClass' is 'Prelude.fmap', or equivalently the+-- 'Control.Applicative.<$>' operator. Here is an example using 'Control.Applicative.<$>':+-- > instance 'FromDaoStructClass' WrapX 'Object' where+-- >     'fromDaoStruct' = WrapX <$> 'fromDaoStruct'+-- > +-- > instance 'FromDaoStructClass' X_or_Y 'Object' where+-- >     'fromDaoStruct' = Is_X <$> 'fromDaoStruct' <|> Is_Y <$> 'fromDaoStruct'+-- +-- Another way to do exactly the same thing as the example above is:+-- > instance 'FromDaoStructClass' WrapX 'Object' where+-- >     'fromDaoStruct' = 'Prelude.fmap' WrapX 'fromDaoStruct'+-- > +-- > instance 'FromDaoStructClass' X_or_Y 'Object' where+-- >     'fromDaoStruct' = 'Prelude.fmap' Is_X 'fromDaoStruct' `'Control.Monad.mplus'` 'Prelude.fmap' Is_Y 'fromDaoStruct'+-- +-- It is possible to use 'renameConstructor' after evaluating 'innerToStruct' to use a different+-- constructor name while keeping all of the fields set by the evaluation of 'innerToStruct',+-- however if this is done, 'Prelude.fmap' will backtrack, so you should use 'innerFromStruct'+-- instead.+innerToStruct :: ToDaoStructClass inner => inner -> ToDaoStruct haskData ()+innerToStruct = innerToStructWith toDaoStruct++-- | Like 'innerToStruct' but lets you supply a 'ToDaoStruct' function for an arbitrary data type,+-- not just one that instantiates 'ToDaoStructClass'.+innerToStructWith :: ToDaoStruct inner () -> inner -> ToDaoStruct haskData ()+innerToStructWith toDaoStruct o = ask >>= \haskData ->+  predicate (fromData toDaoStruct o) >>= ToDaoStruct . lift . put . flip (,) haskData++fmapHaskDataToStruct :: (haskData -> dyn) -> (dyn -> haskData) -> ToDaoStruct haskData a -> ToDaoStruct dyn a+fmapHaskDataToStruct to from (ToDaoStruct (PredicateT f)) =+  ToDaoStruct $ PredicateT $ state $ fmap (fmap to) . runState f . fmap from++-- | Use this function to set the 'structName' name of the constructor at some point, for example+-- when you observe some condition of the @haskData@ type that merits an alternative constructor+-- name.+renameConstructor :: UStrType name => name -> ToDaoStruct haskData ig -> ToDaoStruct haskData ()+renameConstructor name f = do+  name <- mkStructName name+  modify $ \struct -> struct{ structName=name }+  void f++-- | Like 'renameConstructor' but deletes everything and makes the 'Struct' being constructed into a+-- 'Nullary'. You would typically do this only when you are instantiating 'toDaoStruct' and you+-- only have one constructor to define.+makeNullary :: UStrType name => name -> ToDaoStruct haskData ()+makeNullary name = mkStructName name >>= \name -> put $ Nullary{ structName=name }++-- | Use this when you have derived the "Prelude.Show" class for a data type where every constructor+-- in that data type takes no parameters, for example, the 'Prelude.Ordering' data type.+putNullaryUsingShow :: Show haskData => ToDaoStruct haskData ()+putNullaryUsingShow = ask >>= makeNullary . show++define :: UStrType name => name -> Object -> ToDaoStruct haskData Object+define name value = do+  name <- mkFieldName name+  modify $ \struct -> struct{ fieldMap = M.insert name value (fieldMap struct) }+  return value++-- | Defines an optional field. If the value given is 'Prelude.Nothing', nothing happens. Otherwise+-- the value is placed into the 'Struct' at the given @name@d field. This is the inverse opreation+-- of using 'Control.Applicative.optional' in the 'FromDaoStruct' monad.+optionalField :: UStrType name => name -> Maybe Object -> ToDaoStruct haskData (Maybe Object)+optionalField name = maybe (return Nothing) (fmap Just . define name)++setField :: UStrType name => name -> (haskData -> Object) -> ToDaoStruct haskData Object+setField name f = ask >>= define name . f++-- | This is an important function for instantiating 'ToDaoStructClass'. It takes any+-- value instantiating 'HataClass', converts it to an 'Object' using the 'new'+-- function. It is the inverse of 'objType'.+--+-- It is recommended you use this function instead of 'defStructField', 'defPrimField', or+-- 'defDynField' whenever it is possible, i.e. whenever the data type you are putting instantiated+-- the 'HataClass' class.+defObjField+  :: (UStrType name, Typeable o, ObjectClass o)+  => name -> o -> ToDaoStruct haskData Object+defObjField name o = define name (obj o)++-- | Synonym for 'defObjField'+(.=) :: (UStrType name, Typeable o, ObjectClass o) => name -> o -> ToDaoStruct haskData Object+(.=) = defObjField+infixr 2 .=++-- | Like 'defObjField' but takes a field accessor to extract the data to be stored from the object+-- being converted. This function is defined as:+-- > \name accessor -> asks accessor >>= defObjField name+putObjField+  :: (UStrType name, Typeable o, ObjectClass o)+  => name -> (haskData -> o) -> ToDaoStruct haskData Object+putObjField name which = asks which >>= defObjField name++-- | Synonym for 'putObjField'+(.=@)+  :: (UStrType name, Typeable o, ObjectClass o)+  => name -> (haskData -> o) -> ToDaoStruct haskData Object+(.=@) = putObjField+infixr 2 .=@++-- | Like 'putObjField' but operates on an object wrapped in a 'Prelude.Maybe', not doing anything+-- in the case of 'Prelude.Nothing'.+defMaybeObjField+  :: (UStrType name, Typeable o, ObjectClass o)+  => name -> Maybe o -> ToDaoStruct haskData (Maybe Object)+defMaybeObjField name = maybe (return Nothing) (fmap Just . defObjField name)++(.=?) +  :: (UStrType name, Typeable o, ObjectClass o)+  => name -> Maybe o -> ToDaoStruct haskData (Maybe Object)+(.=?) = defMaybeObjField++----------------------------------------------------------------------------------------------------++-- | This is a handy monadic and 'Data.Functor.Applicative' interface for instantiating+-- 'fromDaoStruct' in the 'FromDaoStructClass' class. It takes the form of a reader because what you+-- /read/ from the 'Struct' here in the Haskell language was /written/ by the Dao language+-- runtime. Think of it as "this is the data type used when the Dao runtime wants to write+-- information to my data structure."+-- +-- Because Dao is such a messy, fuzzy, not statically typed, interpreted language, the information+-- coming in from the Dao runtime requires a lot of sanitization. Therefore this monad provides+-- several functions for checking the type of information you are using to build your Haskell data+-- type.+--+-- Be sure to make ample use of the 'Control.Monad.guard', 'Control.Monad.Error.throwError', and+-- 'Control.Monad.fail' functions.+-- +-- /NOTE:/ refer to the documentation of the 'constructor' monad for an important note on reading+-- Haskell data types with multiple constructors.+newtype FromDaoStruct a =+  FromDaoStruct{ _runFromDaoStruct :: PredicateT ExecControl (State Struct) a }+  deriving (Functor, Applicative, Alternative, MonadPlus)++instance Monad FromDaoStruct where+  return = FromDaoStruct . return+  m >>= f = FromDaoStruct $ _runFromDaoStruct m >>= _runFromDaoStruct . f+  fail msg = FromDaoStruct (lift $ gets structName) >>= \name ->+    execThrow msg (ExecStructError $ nullValue{ structErrName = Just $ toUStr name }) []++instance MonadReader Struct FromDaoStruct where+  ask = FromDaoStruct $ lift get+  local upd f = FromDaoStruct $ PredicateT $ get >>= \st ->+   return $ evalState (runPredicateT $ _runFromDaoStruct f) (upd st)++instance MonadError ExecControl FromDaoStruct where+  throwError = _structThrowError FromDaoStruct id+  catchError (FromDaoStruct f) catch = FromDaoStruct $ catchError f (_runFromDaoStruct . catch)++instance MonadPlusError ExecControl FromDaoStruct where+  catchPredicate = FromDaoStruct . catchPredicate . _runFromDaoStruct+  predicate      = FromDaoStruct . predicate++-- | This function is typically used to evaluate the instantiation of 'fromDaoStruct'. It takes two+-- parameters: first a computation to convert your data type to the Haskell data type from a+-- 'Struct' using the 'FromDaoStruct' monad, and second the 'Struct' you want to convert. For+-- example, if you have a Haskell data type 'MyData' which instantiates 'FromDaoStruct', you could+-- construct it from a properly formatted Dao 'Struct' using this statement:+-- > 'toData' 'fromDaoStruct' struct+-- Notice that this reads similar to ordinary English: "convert to (Haskell) data from a dao+-- struct."+toData :: FromDaoStruct haskData -> Struct -> Predicate ExecControl haskData+toData f = evalState (runPredicateT $ _runFromDaoStruct $ f >>= \o -> checkEmpty >> return o)++-- | Using a 'FromDaoStruct' monadic function, convert a given 'Struct' to a Haskell data type+-- @typ@.+withFromDaoStructExec :: FromDaoStruct typ -> Struct -> Exec typ+withFromDaoStructExec fromDaoStruct =+  predicate . fmapPFail ((\o -> newError{ execReturnValue=Just o }) . new) .  toData fromDaoStruct++-- | Given a 'Struct', use the 'structName' to lookup a 'FromDaoStruct' monadic function in the+-- current 'ExecUnit' suitable for constructing a 'Hata' Haskell data type.+fromDaoStructExec :: Struct -> Exec Hata+fromDaoStructExec struct = do+  let name = structName struct+  (MethodTable mtab) <- gets globalMethodTable+  let badType msg = execThrow msg (ExecTypeError $ objTypeFromName name) []+  case M.lookup (structName struct) mtab of+    Nothing  -> badType "no available built-in data type"+    Just ifc -> case objFromStruct ifc of+      Nothing   -> badType "data type cannot be constructed from hashed structure"+      Just from -> Hata ifc <$> withFromDaoStructExec from struct++-- | Checks if the 'structName' is equal to the given name, and if not then backtracks. This is+-- important when constructing Haskell data types with multiple constructors.+--+-- A haskell data type with multiple constructors should be constructed with the+-- 'Control.Monad.msum' function like so:+-- > data MyData = A | B Int | C Int Int+-- > instance 'FromDaoStruct' ('Object) where+-- >     'fromDaoStruct' = 'toData' $ 'Control.Monad.msum' $+-- >         [ 'constructor' "A" >> return a,+-- >           do 'constructor' "B"+-- >              B 'Control.Applicative.<$>' ('field' "b1" >>= 'primType')+-- >           do 'constructor' "C"+-- >              'Control.Applicative.return' C+-- >                  'Control.Applicative.<*>' 'required' ('field' "c1" >>= 'primType')+-- >                  'Control.Applicative.<*>' 'required' ('field' "c2" >>= 'primType')+-- >         ]+-- /NOTE/ that if all three 'constructor's backtrack (evaluate to 'Control.Monad.mzero') the whole+-- monad will backtrack. By convention, you should let the monad backtrack, rather than writing a+-- 'Control.Monad.fail' statement as the final item in the 'Control.Monad.msum' list.+constructor :: UStrType name => name -> FromDaoStruct ()+constructor name = (return (==) <*> mkStructName name <*> asks structName) >>= guard++-- | The inverse operation of 'innerToStruct', but looks for a constructor of a different name. This+-- is important because every 'toDaoStruct' should set it's own unique constructor name, and if you+-- set a different constructor name while using the same 'fromDaoStruct' function to read the fields+-- of the struct, the 'fromDaoStruct' function will backtrack seeing the wrong constructor name.+-- If you have not renamed the constructor with 'renameConstructor' after using 'innerToStruct', do+-- not use this function, simply use 'Prelude.fmap' or the 'Control.Applicative.<$>' operator+-- instead.+-- +-- This function temporarily changes the constructor name to the constructor set by the @inner@+-- type, that way the 'fromDaoStruct' instance of the @inner@ type will be fooled and read the+-- 'Struct' fields without backtracking. For example:+-- > newtype X = X{ getX :: Int }+-- > instance 'ToDataStruct' X where+-- >     'toDaoStruct' = do+-- >         'renameConstructor' "X"+-- >         "getX" '.=@' getX+-- > +-- > newtype Y = Y{ innerX :: X }+-- > instance 'ToDataStruct' Y where+-- >     'toDaoStruct' = do+-- >         -- the 'innerToStruct' function will use the 'toDaoStruct' for X+-- >         'Control.Monad.Reader.ask' >>= 'innerToStruct' . innerX+-- >         -- then rename the constructor from "X" to "Y"+-- >         'renameConstructor' "Y"+-- > +-- Now when we want to define the accompanying 'FromDaoStructClass', we need to remember that we+-- used 'innerToStruct' and changed the 'structName' from "X" to "Y". Simply using 'Prelude.fmap'+-- (or equivalently 'Control.Applicative.<$>') will not work because the instance of 'fromDaoStruct'+-- for the @X@ data type will backtrack when it sees the 'structName' is "Y".+-- > instance 'FromDaoStructClass' Y where+-- >     'fromDaoStruct' = Y 'Control.Applicative.<$>' 'fromDaoStruct' -- /WRONG!/ This will always backtrack.+-- +-- The correct way to do it is to use 'innerFromStruct' like so:+-- > instance 'FromDaoStructClass' Y where+-- >     'fromDaoStruct' = Y 'Control.Applicative.<$> 'innerFromStruct' "X" -- CORRECT!+-- +innerFromStruct :: (UStrType name, FromDaoStructClass inner) => name -> FromDaoStruct inner+innerFromStruct tempName = do+  name     <- asks structName+  tempName <- mkStructName tempName+  let setname name = FromDaoStruct $ lift $ modify $ \struct -> struct{ structName=name }+  o <- setname tempName >> mplus fromDaoStruct (setname name >> mzero)+  setname name >> return o++-- | Succeeds if the current 'Struct' is a 'Nullary' where the 'structName' is equal to the name+-- given to this function.+nullary :: UStrType name => name -> FromDaoStruct ()+nullary name = ask >>= \struct -> case struct of+  Nullary{} -> constructor name+  _         -> mzero++-- | Use the instantiation of 'Prelude.Read' derived for a type @haskData@ to construct the+-- @haskData from the 'structName' stored in a 'Nullary' 'Struct'.+getNullaryWithRead :: Read haskData => FromDaoStruct haskData+getNullaryWithRead = ask >>= \struct -> case struct of+  Nullary{ structName=name } -> case readsPrec 0 (uchars name) of+    [(haskData, "")] -> return haskData+    _ -> mzero+  _ -> mzero++-- | If an error is thrown using 'Control.Monad.Error.throwError' or 'Control.Monad.fail' within the+-- given 'FromDaoStruct' function, the 'structErrField' will automatically be set to the provided+-- 'Name' value.+structCurrentField :: Name -> FromDaoStruct o -> FromDaoStruct o+structCurrentField name (FromDaoStruct f) = FromDaoStruct $ catchPredicate f >>= \o -> case o of+  PFail (err@(ExecError{execErrorSubtype=ExecStructError info})) -> throwError $ +    err{ execErrorSubtype = ExecStructError $ info{ structErrField = Just (toUStr name) } }+  PFail err -> throwError err+  OK      o -> return o+  Backtrack -> mzero++-- | Retrieves an arbitrary 'Object' by it's field name, and backtraks if no such field is defined.+-- The value of the field is copied, and can be copied again after this operation. It is best not to+-- use this function, rather use 'tryField' to make sure each field is retrieved exactly once, then+-- use 'checkEmpty' to make sure there is no hidden extraneous data in the struct.+tryCopyField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o+tryCopyField name f = (return M.lookup <*> mkFieldName name <*> asks fieldMap) >>=+  xmaybe >>= structCurrentField (fromUStr $ toUStr name) . f++-- | Like 'copyField', retrieves an arbitrary 'Object' by it's field name, and backtraks if no such+-- field is defined. However unlike 'tryCopyField', if the item is retrieved, it is deleted from the+-- inner 'Struct' so that it may not be used again. The reason for this is to use 'checkEmpty' and+-- 'requireEmpty', which can backtrack or fail if there are extraneous fields in the structure.+tryField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o+tryField name f = do+  name <- mkFieldName name+  o    <- tryCopyField name f+  FromDaoStruct $ lift $ modify $ \st ->+    case st of{ Struct{ fieldMap=m } -> st{ fieldMap=M.delete name m }; s -> s; }+  return o++_throwMissingFieldError :: Name -> FromDaoStruct o+_throwMissingFieldError name = throwError $+  newError{ execErrorSubtype = ExecStructError $ nullValue{ structErrField = Just $ toUStr name } }++-- | Like 'field' but evaluates 'Control.Monad.Error.throwError' if the 'FromDaoStruct' function+-- backtracks or throws it's own error. Internally, this function makes use of 'copyField' and /not/+-- 'tryField', so the field is preserved if it exists.+copyField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o+copyField name f = mkFieldName name >>= \name ->+  mplus (tryCopyField name f) (_throwMissingFieldError name)++-- | Like 'field' but evaluates 'Control.Monad.Error.throwError' if the 'FromDaoStruct' function+-- backtracks or throws it's own error. Internally, this function makes use of 'tryField' and /not/+-- 'tryCopyField', so the field is removed if it exists -- two consecutive calls to this function+-- with the same key absolutely will fail.+field :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o+field name f = mkFieldName name >>= \name -> mplus (tryField name f) (_throwMissingFieldError name)++-- As you make calls to 'field' and 'tryField', the items in these fields in the 'Struct' are+-- being removed. Once you have all of the nata neccessary to construct the data 'Object', you can+-- check to make sure there are no extraneous unused data fields. If the 'Struct' is empty, this+-- function evaluates to @return ()@. If there are extranous fields in the 'Struct', 'throwError' is+-- evaluated. It is highly recommended that this function always be used as the last function+-- evaluated in the 'FromDaoStruct' monadic function.+checkEmpty :: FromDaoStruct ()+checkEmpty = FromDaoStruct (lift get) >>= \st -> case st of+  Struct{ fieldMap=m } -> when (not $ M.null m) $+    execThrow "assigned to non-member fields of structure"+      (ExecStructError $ nullValue{ structErrExtras = M.keys m }) []+  Nullary{} -> return ()++-- | Takes a conversion as the first parameter. The second parameter will be provided by 'field' or+-- 'tryField' when you pass it as a partial function application. If the conversion function+-- backtracks, 'Control.Monad.Error.throwError' is evaluated with the appropriate error data set.+-- This function should usually not be required, as it is called by functions like 'opt', 'req', and+-- 'reqList'.+convertFieldData :: (Object -> FromDaoStruct o) -> Object -> FromDaoStruct o+convertFieldData f o = mplus (f o) $ throwError $+  newError{ execErrorSubtype = ExecStructError $ nullValue{ structErrValue=Just o } }++-- | A required 'Struct' 'field'. This function is defined as+req :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct o+req name = field name (convertFieldData (xmaybe . fromObj))++-- | Check if a 'Struct' field exists using 'tryField', if it exists, convert it to the necessary+-- data type using 'fromObj' (which fails if an unexpected type is stored in that field).+opt :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct (Maybe o)+opt name = Just <$> tryField name (convertFieldData (xmaybe . fromObj)) <|> return Nothing++-- | Like 'req' but internally uses 'listFromObj' instead of 'fromObj'. The field must exist, if it+-- does not this function evaluates to 'Control.Monad.Error.throwError'. Use 'optList' instead if+-- you can accept an empty list when the field is not defined.+reqList :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct [o]+reqList name = field name $ convertFieldData (xmaybe . listFromObj)++-- | Like 'opt' but internally uses 'listFromObj' instead of 'fromObj'. The field may not exist, and+-- if it does not this function returns an empty list. Use 'reqList' to evaluate to+-- 'Control.Monad.Error.throwError' in the case the field does not exist.+optList :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct [o]+optList name = tryField name $ convertFieldData (maybe (return []) return . listFromObj)++----------------------------------------------------------------------------------------------------++builtin_toStruct :: DaoFunc ()+builtin_toStruct =+  daoFunc+  { daoForeignFunc = \ () ox -> do+      let qref = reference UNQUAL (ustr "toStruct")+      let wrongTypeErr o = throwBadTypeError "cannot convert to a struct from object of the given type" o []+      case ox of+        [o] -> case o of+          OTree              _  -> return (Just o, ())+          OHaskell (Hata ifc d) -> case objToStruct ifc of+            Just to -> flip (,) () . Just . obj <$> toDaoStructExec to d+            Nothing -> wrongTypeErr o+          o                     -> wrongTypeErr o+        ox  -> throwArityError "" 1 ox [(errInFunc, obj qref)]+  }++builtin_fromStruct :: DaoFunc ()+builtin_fromStruct =+  daoFunc+  { daoForeignFunc = \ () ox -> do+      let qref = reference UNQUAL (ustr "fromStruct")+      case ox of+        [o] -> case o of+          OTree o -> flip (,) () . Just . OHaskell <$> fromDaoStructExec o+          o       -> throwBadTypeError "argument parameter is not a struct data type" o []+        ox -> throwArityError "" 1 ox [(errInFunc, obj qref)]+  }++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass Location where+  toDaoStruct = ask >>= \lo -> case lo of+    LocationUnknown -> makeNullary "NoLocation"+    Location{} -> renameConstructor "Location" $ do+      "startingLine"   .=@ startingLine+      "startingColumn" .=@ startingColumn+      "endingLine"     .=@ endingLine+      "endingColumn"   .=@ endingColumn++instance FromDaoStructClass Location where+  fromDaoStruct = msum $+    [ nullary "NoLocation" >> return LocationUnknown+    , do  constructor "Location"+          return Location+            <*> req "startingLine"+            <*> req "startingColumn"+            <*> req "endingLine"+            <*> req "endingColumn"+    ]++putLocation :: Location -> ToDaoStruct haskData ()+putLocation loc = case loc of+  LocationUnknown -> return ()+  Location{} -> void $ "location" .= loc++location :: FromDaoStruct Location+location = opt "location" >>= maybe (return LocationUnknown) return++putComments :: [Comment] -> ToDaoStruct haskData ()+putComments = void . defObjField "comments"++comments :: FromDaoStruct [Comment]+comments = req "comments"++optComments :: FromDaoStruct (Maybe [Comment])+optComments = opt "comments"++instance HasRandGen Object where+  randO = countNode $ recurse $ runRandChoice+  randChoice = mappend (fmap unlimitObject defaultChoice) $ randChoiceList $+    [ ORef  <$> randO+    , depthLimitedInt 24 >>= \x ->+        scramble $ OList <$> randList 0 x+    , depthLimitedInt 24 >>= \x ->+        scramble $ ODict . M.fromList <$> randListOf 0 x (return (,) <*> randO <*> randO)+    , OType <$> randO+    , OTree <$> randO+    , ORatio <$> randO+    , OComplex <$> randO+    ]+  defaultO = _randTrace "D.Object" runDefaultChoice+  defaultChoice = randChoiceList $+    [ do  i <- nextInt 10 -- OBytes+          fmap (OBytes . B.concat) $ replicateM i $+            fmap (encode . (\i -> fromIntegral i :: Word32)) randInt+    ]++-- | This is a newtype of 'Object' with a specially defined instance for 'HasRandGen' that+-- guarantees the 'Object' values generated randomly can be pretty-printed an re-parsed back to the+-- exact same value, unambiguously. For example, the instance of 'HasRandGen' for 'LimitedObject'+-- will not produce any values of:+-- > 'Dao.Interpreter.OList' ['Dao.Interpreter.OInt' 1, 'Dao.Interpreter.OInt' 2, 'Dao.Interpreter.OInt' 3]+-- because this will be pretty-printed to "list {1,2,3}" and parsing that pretty printed object will+-- yield the data type:+-- > ('Dao.Interpreter.AST_Init'+-- >     ('Dao.Interpreter.AST_DotLabel' ('Dao.String.Name' "list") [] 'Dao.Token.LocationUnknown')+-- >     ('Dao.Interpreter.AST_OptObjList' [] 'Prelude.Nothing')+-- >     ('Dao.Interpreter.AST_ObjList' []+-- >         [ 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 1 'Dao.Token.LocationUnknown')))))+-- >         , 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 2 'Dao.Token.LocationUnknown')))))+-- >         , 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 3 'Dao.Token.LocationUnknown')))))+-- >         ]+-- >     )+-- > )+-- Obviously this is a completely different data structure than the data originally randomly+-- generated. If one were to evaluate it using 'Dao.Interpreter.execute', it would evaluate to the+-- originally generated random object value. But for simplicity the test suit does not evaluate+-- anything, it only compares the original randomly generated test object value to the object value+-- that was constructed by parsing the pretty printed form.+--+-- Therefore, the only data structures that should be randomly generated for testing are the data+-- structures that pretty print to a form that can be parsed back to an identical value when+-- compared to the original. This limits the objects that can be generated to simple string and+-- integer literals, hence the name 'LimitedObject'.+newtype LimitedObject = LimitedObject { unlimitObject :: Object } deriving (Eq, Ord, Show)++instance HasNullValue LimitedObject where+  nullValue = LimitedObject nullValue+  testNull (LimitedObject o) = testNull o++instance HasRandGen LimitedObject where+  randO =  _randTrace "LimitedObject" $ countNode $ runRandChoice+  randChoice = fmap LimitedObject $ randChoiceList $+    [ return ONull, return OTrue+    , OInt     <$> defaultO+    , OWord    <$> defaultO+    , OLong    <$> defaultO+    , OFloat   <$> defaultO+    , OString  <$> defaultO+    , OAbsTime <$> defaultO+    , ORelTime <$> defaultO+    , OChar . chr . flip mod (ord(maxBound::Char)) <$> defaultO+    ]+  defaultO = randO++----------------------------------------------------------------------------------------------------++-- | The 'Object' type extends the 'Data.Dynamic.Dynamic' data type with a few more constructors for+-- data types that are fundamental to a programming language, like integers, strings, and lists.+data Object+  = ONull+  | OTrue+  | OChar      T_char+  | OInt       T_int+  | OWord      T_word+  | OLong      T_long+  | ORelTime   T_diffTime+  | OFloat     T_float+  | ORatio     T_ratio+  | OComplex   T_complex+  | OString    T_string+  | OBytes     T_bytes+  | OList      T_list+  | ODict      T_dict+  | ORef       T_ref+  | OType      T_type+  | OTree      T_struct+  | OAbsTime   T_time+  | OHaskell   Hata+  deriving (Eq, Ord, Typeable, Show)++type T_char     = Char+type T_int      = Int+type T_word     = Word64+type T_long     = Integer+type T_diffTime = NominalDiffTime+type T_float    = Double+type T_ratio    = Rational+type T_complex  = Complex+type T_string   = UStr+type T_bytes    = B.ByteString+type T_list     = [Object]+type T_dict     = M.Map Name Object+type T_ref      = Reference+type T_type     = ObjType+type T_struct   = Struct+type T_time     = UTCTime++instance NFData Object where+  rnf  ONull         = ()+  rnf  OTrue         = ()+  rnf (OChar      a) = deepseq a ()+  rnf (OInt       a) = deepseq a ()+  rnf (OWord      a) = deepseq a ()+  rnf (OLong      a) = deepseq a ()+  rnf (ORelTime   a) = deepseq a ()+  rnf (OFloat     a) = deepseq a ()+  rnf (ORatio     a) = deepseq a ()+  rnf (OComplex   a) = deepseq a ()+  rnf (OString    a) = deepseq a ()+  rnf (OBytes     a) = seq a ()+  rnf (OList      a) = deepseq a ()+  rnf (ODict      a) = deepseq a ()+  rnf (ORef       a) = deepseq a ()+  rnf (OType      a) = deepseq a ()+  rnf (OTree      a) = deepseq a ()+  rnf (OAbsTime   a) = deepseq a ()+  rnf (OHaskell   a) = deepseq a ()++instance Monoid (XPure Object) where+  mempty = return ONull+  mappend a b = a >>= \a -> b >>= \b -> case a of+    ONull     -> return b+    OTrue     -> case b of+      OTrue     -> return OTrue+      _         -> mzero+    a         -> case b of+      ONull     -> return a+      b         -> xpure a + xpure b++instance HasNullValue Object where+  nullValue = ONull+  testNull a = case a of+    ONull        -> True+    OChar     c  -> testNull c+    OInt      i  -> testNull i+    OWord     i  -> testNull i+    OLong     i  -> testNull i+    OFloat    f  -> testNull f+    ORelTime  s  -> testNull s+    ORatio    r  -> testNull r+    OComplex  c  -> testNull c+    OString   s  -> testNull s+    OBytes    o  -> testNull o+    OList     s  -> testNull s+    ODict     m  -> testNull m+    OTree     t  -> testNull t+    OHaskell  o  -> testNull o+    _            -> False++-- binary 0x08 0x1A Object-->CoreType+instance B.Binary Object MTab where+  put o = do+    let t   = B.put (typeOfObj o)+        p o = t >> B.put o+    case o of+      ONull      -> t+      OTrue      -> t+      OChar    o -> p o+      OInt     o -> p o+      OWord    o -> p o+      OLong    o -> p o+      ORelTime o -> p o+      OFloat   o -> p o+      ORatio   o -> p o+      OComplex o -> p o+      OString  o -> p o+      OBytes   o -> p o+      OList    o -> t >> B.putUnwrapped o+      ODict    o -> p o+      ORef     o -> p o+      OType    o -> p o+      OTree    o -> p o+      OAbsTime o -> p o+      OHaskell o -> B.put o+  get = B.word8PrefixTable <|> fail "expecting Object"++instance B.HasPrefixTable Object B.Byte MTab where+  prefixTable =+    let g f = fmap f B.get+    in  mappend (OTree <$> B.prefixTable) $ B.mkPrefixTableWord8 "Object" 0x08 0x1A $+          [ return ONull+          , return OTrue+          , g OChar+          , g OInt+          , g OWord+          , g OLong+          , g ORelTime+          , g OFloat+          , g ORatio+          , g OComplex+          , g OString+          , g OBytes+          , OList <$> B.getUnwrapped+          , g ODict+          , g ORef+          , g OType+          , g OTree+          , g OAbsTime+          , mplus (OHaskell <$> B.get)+                  (B.get >>= \ (B.BlockStream1M bs1m) -> return (OBytes bs1m))+          ]++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass RefQualifier where { toDaoStruct=putNullaryUsingShow; }++instance FromDaoStructClass RefQualifier where { fromDaoStruct=getNullaryWithRead; }++instance ObjectClass RefQualifier where { obj=new; fromObj=objFromHata; }++instance HataClass RefQualifier where+  haskellDataInterface = interface "RefQualifier" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++data Reference+  = Reference  RefQualifier Name RefSuffix+  | RefObject  Object RefSuffix+  | RefWrapper Reference+  deriving (Eq, Ord, Typeable, Show)++instance Monoid (XPure Reference) where+  mempty = mzero+  mappend a b = msum $+    [ a >>= \a -> b >>= \b -> case b of+        Reference UNQUAL name suf -> let suf2 = DotRef name suf in case a of+          Reference  q name suf1 -> return $ Reference q name (suf1 <> suf2)+          RefObject  o      suf1 -> return $ RefObject   o    (suf1 <> suf2)+          RefWrapper a           -> return a <> return b+        _  -> execThrow+                "only unqualified references can be appended to other references"+                  ExecErrorUntyped [(assertFailed, obj b)]+    , a, b+    ]++instance Read Reference where+  readsPrec _ str = loop [] (sp str) where+    sp = dropWhile isSpace+    loop rx str = do+      (a,  str) <- pure (span (\c -> isAlpha    c || c=='_') str)+      guard (not $ null a)+      (ax, str) <- pure (span (\c -> isAlphaNum c || c=='_') str)+      ax  <- pure (fromUStr $ toUStr $ a++ax)+      str <- pure (sp str)+      case str of+        '.':str            -> loop (rx++[ax]) (sp str)+        "" | not $ null rx -> [(Reference UNQUAL (head rx) $ refSuffixFromNames (tail $ rx++[ax]), "")]+        ""                 -> [(Reference UNQUAL ax NullRef, "")]+        _                  -> error $ concat ["a=", show a, "ax=", show ax, "str=", show str]++-- | Construct a 'Reference' with a 'RefQualifier' and a 'Name'.+reference :: RefQualifier -> Name -> Reference+reference q name = Reference q name NullRef++-- | Construct a 'Reference' with an object.+refObject :: Object -> Reference+refObject = flip RefObject NullRef++-- | Strip the 'RefSuffix' from the given 'Reference', changing it 'NullRef' and returning the+-- updated 'Referene' along with the 'RefSuffix' that was removed. If the 'Reference' is a+-- 'RefWrapper', nothing is changed.+referenceHead :: Reference -> (Reference, Maybe RefSuffix)+referenceHead qref = case qref of+  Reference q name suf -> (Reference q name NullRef, Just suf)+  RefObject   o    suf -> (RefObject   o    NullRef, Just suf)+  RefWrapper  r        -> (RefWrapper  r           , Nothing )++-- | The 'Reference' data type has a 'RefWrapper' constructor which wraps a 'Reference' value,+-- protecting it from being de-referenced. This function unwraps the inner 'Reference' if it is+-- within a 'RefWrapper', or else returns the 'Reference' unchanged.+refUnwrap :: Reference -> Reference+refUnwrap r = case r of { RefWrapper r -> r; r -> r; }++instance NFData Reference where+  rnf (Reference q n r) = deepseq q $! deepseq n $! deepseq r ()+  rnf (RefObject o r  ) = deepseq o $! deepseq r ()+  rnf (RefWrapper  r  ) = deepseq r ()++instance PPrintable Reference where+  pPrint qref = case qref of+    Reference q n r -> case q of+      UNQUAL -> pInline [pPrint n, pPrint r]+      q      -> pInline [pPrint q, pString " ", pPrint n, pPrint r]+    RefObject o r -> pInline [pString "(", pPrint o, pString ")", pPrint r]+    RefWrapper  r -> pInline [pString "$", pPrint r]++-- binary 0x48 0x4E+instance B.Binary Reference MTab where+  put qref = case qref of+    Reference q n r -> prefix q $ B.put n >> B.put r where+      prefix q = B.prefixByte $ case q of+        { UNQUAL -> 0x48; LOCAL -> 0x49; CONST -> 0x4A; STATIC -> 0x4B; GLOBAL -> 0x4C; GLODOT -> 0x4D; }+    RefObject o r -> B.prefixByte 0x4E $ B.put o >> B.put r+    RefWrapper  r -> B.prefixByte 0x4F $ B.put r+  get = B.word8PrefixTable <|> fail "expecting Reference"++instance B.HasPrefixTable Reference B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "Reference" 0x48 0x4F $+    [ f UNQUAL, f LOCAL, f CONST, f STATIC, f GLOBAL, f GLODOT+    , return RefObject  <*> B.get <*> B.get+    , return RefWrapper <*> B.get+    ] where { f q = return (Reference q) <*> B.get <*> B.get }++instance HasRandGen Reference where+  randO = _randTrace "Reference" $ recurse $ countNode $ runRandChoice+  randChoice = randChoiceList $+    [ return Reference <*> randO   <*> randO <*> randO+    , return RefObject <*> scrambO <*> randO+    , RefWrapper <$> scrambO+    ]+  defaultO = _randTrace "D.Reference" runDefaultChoice+  defaultChoice = randChoiceList $+    [ return Reference <*> defaultO <*> defaultO <*> defaultO+    , return RefObject <*> defaultO <*> defaultO+    ]++-- 'execute'-ing a 'Reference' will dereference it, essentially reading the value associated with+-- that reference from the 'ExecUnit'.+instance Executable Reference (Reference, Maybe Object) where { execute qref = referenceLookup qref }++refAppendSuffix :: Reference -> RefSuffix -> Reference+refAppendSuffix qref appref = case qref of+  Reference q name ref -> Reference q name (ref<>appref)+  RefObject   o    ref -> RefObject   o    (ref<>appref)+  RefWrapper      qref -> RefWrapper $ refAppendSuffix qref appref++-- | This is an important function used throughout most of the intepreter to lookup 'Object's+-- associated with 'Reference's. It returns a a pair containing updated copy of the given+-- 'Reference' and the 'Object' that was looked-up. The 'Reference' returned is a copy of the+-- 'Reference' parameter given but updated with information about where the reference was looked up.+-- For example, if you pass an 'UNQUAL' (unqualified) reference, it may be looked up in the local,+-- global, or const variable tables.  The reference returned will not be 'UNQUAL', it will be either+-- 'GLOBAL', 'LOCAL', or 'CONST', depending on where the 'Object' returned was found.+--+-- If the 'Reference' is a function call, the object returned will be the evaluation of the function+-- call, which may be void (a.k.a. 'Prelude.Nothing').+referenceLookup :: Reference -> Exec (Reference, Maybe Object)+referenceLookup qref = case qref of+  RefWrapper ref -> return $ (qref, Just (obj ref))+  qref           -> do+    (a, (qref, _, _)) <- runObjectFocus (updateIndex qref get) True qref ()+    return (qref, a)++refNames :: [Name] -> Maybe Reference+refNames nx = case nx of+  []   -> Nothing+  n:nx -> Just $ Reference UNQUAL n $ refSuffixFromNames nx++referenceFromUStr :: UStr -> Maybe Reference+referenceFromUStr s = breakup [] $ uchars s where+  breakup refs s = case break (=='.') s of+    (n, '.':s) -> breakup (refs++[ustr n]) s+    (n, ""   ) -> refNames $ refs++[ustr n]+    _          -> Nothing++fmapReference :: (RefSuffix -> RefSuffix) -> Reference -> Reference+fmapReference fn ref = case ref of+  Reference q nm ref -> Reference q nm (fn ref)+  RefObject   o  ref -> RefObject   o  (fn ref)+  RefWrapper    qref -> RefWrapper $ fmapReference fn qref++setQualifier :: RefQualifier -> Reference -> Reference+setQualifier q ref = case ref of+  Reference _ name ref -> Reference q name ref+  RefObject   o    ref -> RefObject   o    ref+  RefWrapper      qref -> RefWrapper $ setQualifier q qref++modRefObject :: (Object -> Object) -> Reference -> Reference+modRefObject mod ref = case ref of+  RefObject o ref -> RefObject (mod o) ref+  ref             -> ref++-- | This function performs an update on a 'Reference', it is the complement to the 'referenceLookup'+-- function. Evaluating 'referenceUpdate' on a 'Reference' will write/update the value associated with+-- it. If the boolean parameter is 'Prelude.True' it indicates that the value updated must already+-- exist, and an undefined reference error will be thrown if it does not exist.+referenceUpdate :: Reference -> Bool -> (Maybe Object -> Exec (Maybe Object)) -> Exec (Reference, Maybe Object)+referenceUpdate qref mustExist upd = do+  -- The 'ExecUnit' is not actually modified in any way by 'updateIndex'. It is only used to+  -- instruct Haskell's type system to select the class instance of 'updateIndex' for the data type:+  -- > 'ObjectLens' 'ExecUnit' 'Reference'+  (result, (qref, _, _)) <-+    runObjectFocus (updateIndex qref $ execToFocusUpdater upd) mustExist (fst $ referenceHead qref) ()+  return (qref, result)++----------------------------------------------------------------------------------------------------++-- $Object_types+-- Here we have a lambda calculus for describing types. Computationally, it is very similar to the+-- Prolog programming language, however an 'ObjType' is written using a subset the Dao scripting+-- langauge.++data CoreType+  = NullType+  | TrueType+  | CharType+  | IntType+  | WordType+  | LongType+  | DiffTimeType+  | FloatType+  | RatioType+  | ComplexType+  | StringType+  | BytesType+  | ListType+  | DictType+  | RefType+  | TypeType+  | TreeType+  | TimeType+  | HaskellType+  deriving (Eq, Ord, Typeable, Enum, Bounded)++instance Show CoreType where+  show t = case t of+    NullType     -> "Null"+    TrueType     -> "True"+    CharType     -> "Char"+    IntType      -> "Int"+    WordType     -> "Word"+    LongType     -> "Long"+    DiffTimeType -> "Diff"+    FloatType    -> "Float"+    RatioType    -> "Ratio"+    ComplexType  -> "Complex"+    StringType   -> "String"+    BytesType    -> "Bytes"+    ListType     -> "List"+    DictType     -> "Dict"+    RefType      -> "Ref"+    TypeType     -> "Type"+    TreeType     -> "Tree"+    TimeType     -> "Time"+    HaskellType  -> "Haskell"++instance Read CoreType where+  readsPrec _ str = map (\a -> (a, "")) $ case str of+    "Null"    -> [NullType]+    "True"    -> [TrueType]+    "Char"    -> [CharType]+    "Int"     -> [IntType]+    "Word"    -> [WordType]+    "Long"    -> [LongType]+    "Diff"    -> [DiffTimeType]+    "Float"   -> [FloatType]+    "Ratio"   -> [RatioType]+    "Complex" -> [ComplexType]+    "String"  -> [StringType]+    "Bytes"   -> [BytesType]+    "List"    -> [ListType]+    "Dict"    -> [DictType]+    "Ref"     -> [RefType]+    "Type"    -> [TypeType]+    "Tree"    -> [TreeType]+    "Time"    -> [TimeType]+    "Haskell" -> [HaskellType]+    _         -> []++instance NFData CoreType where { rnf a = seq a () }++instance UStrType CoreType where+  toUStr = derive_ustr+  maybeFromUStr a = case readsPrec 0 (uchars a) of+    [(o, "")] -> Just o+    _         -> Nothing+  fromUStr a = case maybeFromUStr a of+    Nothing -> error (show a++" is not a valid type identifier")+    Just  a -> a++instance Iv.InfBound CoreType where+  minBoundInf = Iv.Finite minBound+  maxBoundInf = Iv.Finite maxBound++instance PPrintable CoreType where { pPrint = pShow }++-- binary 0x08 0x1A CoreType+instance B.Binary CoreType mtab where+  put t = B.putWord8 $ case t of+    NullType     -> 0x08+    TrueType     -> 0x09+    CharType     -> 0x0A+    IntType      -> 0x0B+    WordType     -> 0x0C+    LongType     -> 0x0D+    DiffTimeType -> 0x0E+    FloatType    -> 0x0F+    RatioType    -> 0x10+    ComplexType  -> 0x11+    StringType   -> 0x12+    BytesType    -> 0x13+    ListType     -> 0x14+    DictType     -> 0x15+    RefType      -> 0x16+    TypeType     -> 0x17+    TreeType     -> 0x18+    TimeType     -> 0x19+    HaskellType  -> 0x1A+  get = B.word8PrefixTable <|> fail "expecting CoreType"++instance B.HasPrefixTable CoreType B.Byte mtab where+  prefixTable = B.mkPrefixTableWord8 "CoreType" 0x08 0x1A $ map return $+    [ NullType+    , TrueType+    , CharType+    , IntType+    , WordType+    , LongType+    , DiffTimeType+    , FloatType+    , RatioType+    , ComplexType+    , StringType+    , BytesType+    , ListType+    , DictType+    , RefType+    , TypeType+    , TreeType+    , TimeType+    , HaskellType+    ]++instance HasRandGen CoreType where+  randO = toEnum <$> nextInt (fromEnum (maxBound::CoreType))+  defaultO = randO++-- | Get the 'CoreType' o an 'Object'.+coreType :: Object -> CoreType+coreType o = case o of+  ONull      -> NullType+  OTrue      -> TrueType+  OChar    _ -> CharType+  OInt     _ -> IntType+  OWord    _ -> WordType+  OLong    _ -> LongType+  ORelTime _ -> DiffTimeType+  OFloat   _ -> FloatType+  ORatio   _ -> RatioType+  OComplex _ -> ComplexType+  OString  _ -> StringType+  OBytes   _ -> BytesType+  OList    _ -> ListType+  ODict    _ -> DictType+  ORef     _ -> RefType+  OType    _ -> TypeType+  OTree    _ -> TreeType+  OAbsTime _ -> TimeType+  OHaskell _ -> HaskellType++----------------------------------------------------------------------------------------------------++-- | A symbol in the type calculus.+data TypeSym+  = CoreType CoreType+    -- ^ used when the type of an object is equal to it's value, for example Null and True,+    -- or in situations where the type of an object has a value, for example the dimentions of a+    -- matrix.+  | TypeSym  Name+  | TypeVar  Name [ObjType]+    -- ^ a polymorphic type, like 'AnyType' but has a name.+  deriving (Eq, Ord, Show, Typeable)++instance NFData TypeSym where+  rnf (CoreType a  ) = deepseq a ()+  rnf (TypeSym  a  ) = deepseq a ()+  rnf (TypeVar  a b) = deepseq a $! deepseq b ()++instance HasRandGen TypeSym where+  randO = _randTrace "TypeSym" $ countNode $ runRandChoice+  randChoice = randChoiceList $+    [CoreType <$> randO, TypeSym <$> randO, scramble $ return TypeVar <*> randO <*> randList 1 4]+  defaultO = _randTrace "D.TypeSym" $ CoreType <$> defaultO++instance PPrintable TypeSym where+  pPrint t = case t of+    CoreType t     -> pPrint t+    TypeSym  t     -> pPrint t+    TypeVar  t ctx -> pInline $+      concat [[pPrint t], guard (not (null ctx)) >> [pList_ "[" ", " "]" (map pPrint ctx)]]++-- binary 0x2E 0x2F+instance B.Binary TypeSym mtab where+  put o = case o of+    CoreType o      -> B.prefixByte 0x2D $ B.put o+    TypeSym  o      -> B.prefixByte 0x2E $ B.put o+    TypeVar ref ctx -> B.prefixByte 0x2F $ B.put ref >> B.put ctx+  get = B.word8PrefixTable <|> fail "expecting TypeSym"++instance B.HasPrefixTable TypeSym B.Byte mtab where+  prefixTable =+    B.mkPrefixTableWord8 "TypeSym" 0x2D 0x2F [CoreType <$> B.get, return TypeVar <*> B.get <*> B.get]++----------------------------------------------------------------------------------------------------++-- | Complex type structures can be programmed by combining 'ObjSimpleType's. An empty 'TypeStruct'+-- is the "any-type", which matches anything.+newtype TypeStruct = TypeStruct [TypeSym] deriving (Eq, Ord, Show, Typeable)++instance NFData TypeStruct where { rnf (TypeStruct a) = deepseq a () }++instance HasNullValue TypeStruct where { nullValue = TypeStruct []; testNull (TypeStruct a) = null a; }++instance PPrintable TypeStruct where+  pPrint (TypeStruct tx) = case tx of+    [] -> pString "AnyType"+    tx -> pList (pString "type") "(" ", " ")" (map pPrint tx)++-- binary 0x33 +instance B.Binary TypeStruct mtab where+  put (TypeStruct o) = B.prefixByte 0x33 $ B.put o+  get = B.word8PrefixTable <|> fail "expecting TypeStruct"++instance B.HasPrefixTable TypeStruct B.Byte mtab where+  prefixTable = B.mkPrefixTableWord8 "TypeStruct" 0x33 0x33 [TypeStruct <$> B.get]++instance HasRandGen TypeStruct where+  randO    = _randTrace "TypeStruct" $ TypeStruct <$> randList 0 4+  defaultO = _randTrace "D.TypeStruct" $ TypeStruct <$> defaultList 0 4++----------------------------------------------------------------------------------------------------++-- | The fundamental 'Type' used to reason about whether an object is fit to be used for a+-- particular function. Any empty 'ObjType' is the "void-type" which matches nothing.+newtype ObjType = ObjType { typeChoices :: [TypeStruct] } deriving (Eq, Ord, Show, Typeable)++instance NFData ObjType where { rnf (ObjType a) = deepseq a () }++instance HasNullValue ObjType where { nullValue = ObjType []; testNull (ObjType a) = null a; }++instance PPrintable ObjType where+  pPrint t@(ObjType tx) = case fromObj (obj t) of+    Just  t -> pString $ show (t::CoreType)+    Nothing -> case tx of+      [] -> pString "VoidType"+      tx -> pList (pString "anyOf") "(" ", " ")" (map pPrint tx)++-- binary 0x37 +instance B.Binary ObjType mtab where+  put (ObjType o) = B.prefixByte 0x37 $ B.put o+  get = B.word8PrefixTable <|> fail "expecting ObjType"++instance B.HasPrefixTable ObjType B.Byte mtab where+  prefixTable = B.mkPrefixTableWord8 "ObjType" 0x37 0x37 [ObjType <$> B.get]++instance HasRandGen ObjType where+  randO = _randTrace "ObjType" $ recurse $ ObjType <$> randList 0 3+  defaultO = _randTrace "D.ObjType" $ ObjType <$> defaultList 1 4++typeOfObj :: Object -> ObjType+typeOfObj o = case o of+  OHaskell o -> hataType o+  o          -> ObjType [TypeStruct [CoreType $ coreType o]]++hataType :: Hata -> ObjType+hataType (Hata ifc _) = ObjType [TypeStruct [TypeSym $ objInterfaceName ifc]]++objTypeFromCoreType :: CoreType -> ObjType+objTypeFromCoreType = ObjType . return . TypeStruct . return . CoreType++objTypeFromName :: Name -> ObjType+objTypeFromName name = ObjType{ typeChoices = [TypeStruct [TypeSym name]] }++----------------------------------------------------------------------------------------------------++-- | This is actually a part of the 'Reference' constructor, and 'Reference' is one of the built-in+-- 'Object' data types.  There is a one-to-one mapping from this type to the 'RefSuffixExpr' and+-- 'AST_Ref' data types produced by the parser.+data RefSuffix+  = NullRef+  | DotRef     Name    RefSuffix+  | Subscript [Object] RefSuffix+  | FuncCall  [Object] RefSuffix+  deriving (Eq, Ord, Typeable, Show)++instance Monoid RefSuffix where+  mempty = NullRef+  mappend left right = case left of+    NullRef           -> right+    DotRef    nm left -> DotRef    nm $ left<>right+    Subscript ox left -> Subscript ox $ left<>right+    FuncCall  ox left -> FuncCall  ox $ left<>right++-- | If the 'RefSuffix' is 'DotRef', 'Subscript', or 'FuncCall', the second parameter to these+-- constructors is overwritten with 'NullRef' so only the first parameter remains.+refSuffixHead :: RefSuffix -> RefSuffix+refSuffixHead suf = let lst = refSuffixToList suf in if null lst then NullRef else head lst++-- | Evaluates to 'Prelude.True' if ay of the constructors within the 'RefSuffix' are 'FuncCall'.+refSuffixHasFuncCall :: RefSuffix -> Bool+refSuffixHasFuncCall suf = case suf of+  NullRef         -> False+  DotRef    _ suf -> refSuffixHasFuncCall suf+  Subscript _ suf -> refSuffixHasFuncCall suf+  FuncCall  _ _   -> True++-- | The 'RefSuffix' is a list-like data type, where most of the constructors may contain another+-- 'RefSuffix' structure as the "tail" of the list. This function "explodes" a 'RefSuffix' into a+-- list of 'RefSuffix's where "tail" is 'NullRef'. This is the inverse operation of+-- 'Data.Monoid.mconcat', so the following equality is always True:+-- > \r -> mconcat (refSuffixToList r) == r+refSuffixToList :: RefSuffix -> [RefSuffix]+refSuffixToList suf = case suf of+  NullRef         -> []+  DotRef    a suf -> DotRef    a NullRef : refSuffixToList suf+  Subscript a suf -> Subscript a NullRef : refSuffixToList suf+  FuncCall  a suf -> FuncCall  a NullRef : refSuffixToList suf++-- | Construct a 'DotRef' with a 'NullRef' suffix.+dotRef :: Name -> RefSuffix+dotRef = flip DotRef NullRef++-- | Construct a 'Subscript' with a 'NullRef' suffix.+subscript :: [Object] -> RefSuffix+subscript = flip Subscript NullRef++-- | Construct a 'FuncCall' with a 'NullRef' suffix.+funcCall :: [Object] -> RefSuffix+funcCall = flip FuncCall NullRef++instance HasNullValue RefSuffix where+  nullValue = NullRef+  testNull r = case r of { NullRef -> True; _ -> False }++refSuffixFromNames :: [Name] -> RefSuffix+refSuffixFromNames nx = case nx of { [] -> NullRef; n:nx -> DotRef n $ refSuffixFromNames nx; }++instance Read RefSuffix where+  readsPrec _ str = case str of+    '.':c:str  | isAlpha c ->+      case break (\c -> c=='.' || isAlphaNum c) (c:str) of+        (cx, str) ->+          maybe [] (return . (\ref -> (refSuffixFromNames ref, str))) $ sequence $+            fix (\loop str -> case break (=='.') str of+                    (cx, str) -> case cx of+                      [] -> []+                      cx -> maybeFromUStr (ustr (dropWhile (=='.') cx)) : loop str+                ) cx+    str -> [(NullRef, str)]++instance NFData RefSuffix where+  rnf  NullRef        = ()+  rnf (DotRef    a b) = deepseq a $! deepseq b ()+  rnf (Subscript a b) = deepseq a $! deepseq b ()+  rnf (FuncCall  a b) = deepseq a $! deepseq b ()++instance PPrintable RefSuffix where+  pPrint = pWrapIndent . loop where +    loop r = case r of+      NullRef       -> []+      DotRef    a b -> pString "." : pUStr (toUStr a) : loop b+      Subscript a b -> pList_ "[" ", " "]" (map pPrint a) : loop b+      FuncCall  a b -> pList_ "(" ", " ")" (map pPrint a) : loop b++instance HasRandGen RefSuffix where+  randO = _randTrace "RefSuffix" $ recurse $ countNode $ runRandChoice+  randChoice = randChoiceList $+    [ return NullRef+    , scramble $ return DotRef <*> randO <*> randO+    , depthLimitedInt 8 >>= \x -> return Subscript <*> randList 0 x <*> scrambO+    , depthLimitedInt 8 >>= \x -> return FuncCall  <*> randList 0 x <*> scrambO+    ]+  defaultO = _randTrace "D.RefSuffix" runDefaultChoice+  defaultChoice = randChoiceList $ +    [ return NullRef+    , return Subscript <*> defaultList 0 1 <*> pure NullRef+    , return FuncCall  <*> defaultList 0 1 <*> pure NullRef+    ]++-- binary 0x42 0x45+instance B.Binary RefSuffix MTab where+  put r = case r of+    NullRef       -> B.putWord8   0x42+    DotRef    a b -> B.prefixByte 0x43 $ B.put a >> B.put b+    Subscript a b -> B.prefixByte 0x44 $ B.put a >> B.put b+    FuncCall  a b -> B.prefixByte 0x45 $ B.put a >> B.put b+  get = B.word8PrefixTable <|> fail "expecting RefSuffix"++instance B.HasPrefixTable RefSuffix B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "RefSuffix" 0x42 0x45 $+    [ return NullRef+    , return DotRef    <*> B.get <*> B.get+    , return Subscript <*> B.get <*> B.get+    , return FuncCall  <*> B.get <*> B.get+    ]++----------------------------------------------------------------------------------------------------++newtype Complex = Complex (C.Complex Double)+  deriving (Eq, Typeable, Floating, Fractional, Num)++-- | Since 'Object' requires all of it's types instantiate 'Prelude.Ord', I have defined+-- 'Prelude.Ord' of 'Data.Complex.Complex' numbers to be the distance from 0, that is, the radius of+-- the polar form of the 'Data.Complex.Complex' number, ignoring the angle argument.+instance Ord Complex where+  compare (Complex a) (Complex b) = compare (C.polar a) (C.polar b)++instance Show Complex where+  show (Complex a) = "("++show re++(if im<0 then "-" else "+")++show im++"i)" where+    re = C.realPart a+    im = C.imagPart a++instance NFData Complex where { rnf (Complex a) = deepseq a $! () }++instance HasNullValue Complex where+  nullValue = Complex (0 C.:+ 0)+  testNull (Complex c) = C.realPart c == 0 && C.imagPart c == 0++instance B.Binary Complex mtab where+  put o = B.put (realPart o) >> B.put (imagPart o)+  get   = return complex <*> B.get <*> B.get++instance PPrintable Complex where+  pPrint (Complex (a C.:+ b))+    | a==0.0 && b==0.0 = pString "0i"+    | a==0.0           = pString (show b++"i")+    | b==0.0           = pShow a+    | otherwise        = pInline [pShow a, pString (if b<0 then "-" else "+"), pString (show b++"i")]++instance HasRandGen Complex where { randO = return mkPolar <*> randO <*> randO; defaultO = randO; }++realPart :: Complex -> Double+realPart (Complex o) = C.realPart o++imagPart :: Complex -> Double+imagPart (Complex o) = C.imagPart o++mkPolar :: Double -> Double -> Complex+mkPolar a b = Complex (C.mkPolar a b)++cis :: Double -> Complex+cis = Complex . C.cis++polar :: Complex -> (Double, Double)+polar (Complex o) = C.polar o++magnitude :: Complex -> Double+magnitude (Complex o) = C.magnitude o++phase :: Complex -> Double+phase (Complex o) = C.phase o++conjugate :: Complex -> Complex+conjugate (Complex o) = Complex (C.conjugate o)++complex :: Double -> Double -> Complex+complex a b = Complex (a C.:+ b)++----------------------------------------------------------------------------------------------------++-- | Create the minimum-sized array that can store all of the indices in the given list, setting the+-- 'Data.Array.IArray.bounds' of the array automatically. Evaluates to 'Prelude.Nothing' if the+-- given list of elements is empty.+minAccumArray :: Ix i => (e -> e' -> e) -> e -> [(i, e')] -> Maybe (Array i e)+minAccumArray accfn deflt elems =+  if null elems then Nothing else Just (accumArray accfn deflt bnds elems) where+    idxs = map fst elems+    i0   = head idxs+    bnds = foldl (\ (lo, hi) i -> (min lo i, max hi i)) (i0, i0) (tail idxs)++-- | Create the minimum-sized array that can store all of the indices in the given list, and setting+-- the 'Data.Array.IArray.bounds' of the array automatically. Evaluates to 'Prelude.Nothing' if the+-- given list of elements is empty.+minArray :: Ix i => e -> [(i, e)] -> Maybe (Array i e)+minArray deflt elems = minAccumArray (flip const) deflt elems++----------------------------------------------------------------------------------------------------++-- | An alternative to 'Glob' expressions containing ordinary 'Dao.String.UStr's is a 'Glob'+-- expression containing 'FuzzyStr's. These strings approximately match the input string, ignoring+-- minor spelling errors and transposed characters.+newtype FuzzyStr = FuzzyStr UStr deriving (Ord, Typeable)++instance Eq FuzzyStr where+  a==b = +    let ax = S.map toLower (S.fromList (uchars a))+        bx = S.map toLower (S.fromList (uchars b))+    in     a == b+        || ax == bx+        || S.size (S.difference (S.union ax bx) (if S.size ax < S.size bx then ax else bx)) <= 1++instance Show FuzzyStr where { show (FuzzyStr str) = show str }++instance Read FuzzyStr where+  readsPrec p input = readsPrec p input >>= \ (s, rem) -> return (FuzzyStr (ustr s), rem)++instance Monoid FuzzyStr where+  mempty = FuzzyStr mempty+  mappend (FuzzyStr a) (FuzzyStr b) = FuzzyStr (a<>b)++instance HasNullValue FuzzyStr where+  nullValue = FuzzyStr nullValue+  testNull (FuzzyStr s) = testNull s++instance UStrType FuzzyStr where { fromUStr = FuzzyStr; toUStr (FuzzyStr u) = u; }++instance PPrintable FuzzyStr where { pPrint (FuzzyStr str) = pShow str }++instance ObjectClass FuzzyStr where { obj=new; fromObj=objFromHata; }++instance HataClass FuzzyStr where+  haskellDataInterface = interface "FuzzyStr" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter ++--instance Show (Glob FuzzyStr) where { show = show . fmap toUStr }++--instance Read (Glob FuzzyStr) where+--  readsPrec prec str = readsPrec prec str >>= \ (glob, str) -> [(fmap fromUStr glob, str)]++instance Show (GlobUnit Object) where+  show o = case o of+    Single o -> show o+    globunit -> show (fmap (const "") globunit)++instance PPrintable (GlobUnit Object) where { pPrint = pShow }++instance Show (Glob Object) where+  show glob = (++"\"") $ ('"':) $ do+    o <- getPatUnits glob+    let other o = "$("++prettyShow o++")"+    case o of+      Single o -> case o of+        OString  o -> uchars o+        OHaskell (Hata _ifc dyn) -> case fromDynamic dyn of+          Nothing           -> other o+          Just (FuzzyStr o) -> uchars o+        _ -> other o+      globunit -> show (fmap (const "") globunit)++instance PPrintable (Glob Object) where { pPrint = pShow }++instance ToDaoStructClass (GlobUnit Object) where+  toDaoStruct = ask >>= \o -> case o of+    Wildcard a t -> renameConstructor "Wildcard" $ "name" .= reference UNQUAL a >> "type" .=? t+    AnyOne   a t -> renameConstructor "AnyOne"   $ "name" .= reference UNQUAL a >> "type" .=? t+    Single   a   -> renameConstructor "Single"   $ "item" .= a++instance FromDaoStructClass (GlobUnit Object) where+  fromDaoStruct = msum $+    [ constructor "Wildcard" >> return Wildcard <*> req "name" <*> opt "type"+    , constructor "AnyOne"   >> return AnyOne   <*> req "name" <*> opt "type"+    , constructor "Single"   >>        Single   <$> req "item"+    ]++instance ObjectClass (GlobUnit Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (GlobUnit Object) where+  haskellDataInterface = interface "GlobUnit" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefFromStruct >> autoDefToStruct++instance ToDaoStructClass (Glob Object) where+  toDaoStruct = renameConstructor "GlobPattern" $ "items" .=@ obj . map obj . getPatUnits++instance FromDaoStructClass (Glob Object) where+  fromDaoStruct = do+    constructor "GlobPattern"+    items <- reqList "items"+    return (Glob{ getPatUnits=items, getGlobLength=length items })++instance ObjectClass (Glob Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (Glob Object) where+  haskellDataInterface = interface "GlobPattern" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct+    defMethod "match" $+      daoFunc+      { daoForeignFunc = \glob ox -> fmap (flip (,) glob . Just . obj) $+          forM (matchPattern False glob ox) $ \match -> fmap (obj . M.fromList . concat) $+            forM (M.assocs match) $ \ (name, (vartyp, ox)) -> case vartyp of+              Nothing     -> return [(name, obj ox)]+              Just vartyp -> do+                match <- catchPredicate $ referenceLookup $ Reference UNQUAL vartyp $ FuncCall ox NullRef+                case match of+                  Backtrack       -> return []+                  OK (_, Nothing) -> return [(name, obj ox)]+                  OK (_, Just  o) -> return [(name, obj o)]+                  PFail err       -> throwError err+      }++----------------------------------------------------------------------------------------------------++newtype Pair = Pair (Object, Object) deriving (Eq, Ord, Show, Typeable)++instance PPrintable Pair where+  pPrint (Pair (a,b)) = pList (pString "Pair") "(" ", " ")" [pPrint a, pPrint b]++instance ToDaoStructClass Pair where+  toDaoStruct = renameConstructor "Pair" $ ask >>= \ (Pair (a, b)) -> "fst" .= a >> "snd" .= b++instance FromDaoStructClass Pair where+  fromDaoStruct = constructor "Pair" >> Pair <$> (return (,) <*> req "fst" <*> req "snd")++instance ObjectClass Pair where { obj=new; fromObj=objFromHata; }++instance HataClass Pair where+  haskellDataInterface = interface "Pair" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct+    defIndexUpdater $ \ix upd -> do+      (Pair (a,b)) <- get+      let casti = extractXPure . castToCoreType IntType >=> fromObj+      let badindex = execThrow "index for Pair data type must be a either 0 or 1" ExecErrorUntyped+      let qref = reference UNQUAL (ustr "Pair")+      case ix of+        [i] -> do+          i <- focusLiftExec (derefObject i) >>=+            maybe (badindex [(actualType, obj (typeOfObj i))]) return . casti+          (o, setter) <- case i of+            0 -> pure (a, \a -> (a, b))+            1 -> pure (b, \b -> (a, b))+            i -> badindex [(assertFailed, OInt i)]+          (result, (changed, o)) <- withInnerLens (Just o) upd+          if changed+          then+            case o of+              Nothing ->+                execThrow "item in Pair object updated with void" ExecErrorUntyped [(ustr "index", obj i)]+              Just  o -> put (Pair $ setter o) >> return result+          else  return result+        ix  -> throwArityError "for subscript to Pair data type" 1 ix [(errInConstr, obj qref)]++builtin_assocs :: DaoFunc ()+builtin_assocs =+  daoFunc+  { daoForeignFunc = \ () ox -> do+      let qref = reference UNQUAL (ustr "assocs")+      case ox of+        [o] -> do+          let fromDict o = return $+                (Just $ obj $ fmap (\ (a,b) -> obj $ Pair (obj a, obj b)) $ M.assocs o, ())+          let badtype = throwBadTypeError "object does not contain association Pairs" o []+          case o of+            ODict                  d   -> fromDict d+            OTree (Struct{fieldMap=d}) -> fromDict d+            OHaskell               _   -> maybe badtype (return . flip (,) () . Just) $ msum $+              [ fromObj o >>= return . obj . fmap (\ (ix, o) -> obj $ Pair (H.indexKey ix, o)) . H.assocs+              ]+            _ -> badtype+        ox -> throwArityError "" 1 ox [(errInFunc, obj qref)]+  }++builtin_Pair :: DaoFunc ()+builtin_Pair =+  daoFunc+  { daoForeignFunc = \ () ox -> case ox of+      [a, b] -> return $ (Just $ obj $ Pair(a, b), ())+      ox -> throwArityError "Pair() constructor requires exactly two arguments" 2 ox []+  }++----------------------------------------------------------------------------------------------------++-- | This is a newtype wrapper around a function that tokenizes a 'UStr' into smaller 'UStr's used+-- for constructing rule patterns, and also for tokenizing input strings into objects that can be+-- matched against rule patterns.+newtype ExecTokenizer = ExecTokenizer { runExecTokenizer :: UStr -> Exec [Object] }+  deriving Typeable++----------------------------------------------------------------------------------------------------++-- | This is the state that is used to run the evaluation algorithm. Every Dao program file that has+-- been loaded will have a single 'ExecUnit' assigned to it. Parameters that are stored in+-- 'Dao.Debug.DMVar's or 'Dao.Type.Resource's will be shared across all rules which are executed in+-- parallel, so for example 'execHeap' contains the variables global to all rules in a given+-- program. The remainder of the parameters, those not stored in 'Dao.Debug.DMVar's or+-- 'Dao.Type.Resource's, will have a unique copy of those values assigned to each rule as it+-- executes.+data ExecUnit+  = ExecUnit+    { globalMethodTable  :: MethodTable+      -- ^ In this slot will be stored a read-only @'Data.Map.Lazy.Map' 'Dao.String.UStr'+      -- 'Interface'@ object that will allow any method with access to this+      -- 'GenRuntime' to retrieve a 'Interface' by it's name string. Specifically,+      -- this will be used by objects stored in the 'OHaskell' constructor.+    , importGraph        :: M.Map UPath ExecUnit+      -- ^ every file opened, whether it is a data file or a program file, is registered here under+      -- it's file path (file paths map to 'File's).+    , defaultTimeout     :: Maybe Int+      -- ^ the default time-out value to use when evaluating 'execInputString'+    , currentWithRef     :: Maybe Object+      -- ^ the current document is set by the @with@ statement during execution of a Dao script.+    , taskForExecUnits   :: Task+    , currentQuery       :: Maybe [Object]+    , currentPattern     :: Maybe (Glob Object)+    , currentCodeBlock   :: Maybe Subroutine+      -- ^ when evaluating a 'Subroutine' selected by a string query, the action resulting from+      -- that query is defnied here. It is only 'Data.Maybe.Nothing' when the module is first being+      -- loaded from source code.+    , currentBranch      :: [Name]+      -- ^ set by the @with@ statement during execution of a Dao script. It is used to prefix this+      -- to all global-dot references before reading from or writing to those references.+    , execStack          :: Stack Name Object+      -- ^ stack of local variables used during evaluation+    , globalData         :: T_dict+    , providedAttributes :: M.Map UStr ()+    , builtinConstants   :: T_dict+    , execOpenFiles      :: M.Map UPath ExecUnit+    , programModuleName  :: Maybe UPath+    , preExec            :: [Subroutine]+      -- ^ the "guard scripts" that are executed before every string execution.+    , postExec           :: [Subroutine]+      -- ^ the "guard scripts" that are executed after every string execution.+    , quittingTime       :: [Subroutine]+    , programTokenizer   :: ExecTokenizer+    , ruleSet            :: PatternTree Object [Subroutine]+    , lambdaSet          :: [CallableCode]+    , uncaughtErrors     :: [ExecControl]+    , runtimeRefTable    :: RefTable Object Dynamic+    }++-- Initializes a completely empty 'ExecUnit'+_initExecUnit :: IO ExecUnit+_initExecUnit = do+  execTask <- initTask+  reftable <- newRefTable+  return $+    ExecUnit+    { globalMethodTable  = mempty+    , defaultTimeout     = Nothing+    , importGraph        = mempty+    , currentWithRef     = Nothing+    , currentQuery       = Nothing+    , currentPattern     = Nothing+    , currentCodeBlock   = Nothing+    , currentBranch      = []+    , globalData         = mempty+    , providedAttributes = mempty+    , builtinConstants   = mempty+    , taskForExecUnits   = execTask+    , execStack          = emptyStack+    , execOpenFiles      = mempty+    , programModuleName  = Nothing+    , preExec            = []+    , quittingTime       = mempty+    , programTokenizer   = defaultTokenizer+    , postExec           = []+    , ruleSet            = T.Void+    , lambdaSet          = []+    , uncaughtErrors     = []+    , runtimeRefTable    = reftable+    }++-- | Creates a new 'ExecUnit'. This is the only way to create a new 'ExecUnit', and it must be run+-- within the 'Exec' monad. The 'ExecUnit' produced by this function will have it's parent+-- 'ExecUnit' set to the value returned by the 'Control.Monad.Reader.Class.ask' instance of the+-- 'Exec' monad.+--+-- The parent of all other 'ExecUnit's, the root of the family tree, is initalized internally by the+-- 'startDao' function.+newExecUnit :: Maybe UPath -> Exec ExecUnit+newExecUnit modName = get >>= \parent -> liftIO _initExecUnit >>= \child -> return $+  child+  { programModuleName = modName+  , builtinConstants  = builtinConstants  parent+  , defaultTimeout    = defaultTimeout    parent+  , globalMethodTable = globalMethodTable parent+  , runtimeRefTable   = runtimeRefTable   parent+  }++-- | Execute an 'Exec' monadic function within a different 'ExecUnit' module. The result of the+-- 'Exec' monadic function is the first value in the tuple returned, any modifications to the given+-- 'ExecUnit' module are stored as the second value of the tuple returned.+inModule :: ExecUnit -> Exec a -> Exec (a, ExecUnit)+inModule subxunit exe = do+  xunit    <- get+  result   <- put subxunit >> catchPredicate exe+  subxunit <- get+  put    xunit+  result   <- predicate result+  return (result, subxunit)++----------------------------------------------------------------------------------------------------++-- | A 'Task' is simply a group of threads executing in parallel, but evaluating a task is still+-- synchronous, i.e. evaluating 'taskLoop' on a 'Task' will block until every thread in the task has+-- completed.+data Task+  = Task+    { taskWaitChan       :: Chan (ThreadId, Int)+    , taskRunningThreads :: MVar (S.Set ThreadId)+    }++-- | Create a new 'Task'.+initTask :: IO Task+initTask = do+  wait    <- newChan+  running <- newMVar S.empty+  return $ Task{ taskWaitChan=wait, taskRunningThreads=running }++-- | To halt a single thread in a 'Task', simply signal it with 'Control.Concurrent.killThread'. But+-- to halt everything the task is doing, use this function. Use of this function will never result in+-- deadlocks (I hope).+throwToTask :: Exception e => Task -> e -> IO ()+throwToTask task e = do+  let mvar = taskRunningThreads task+  ((S.elems <$> readMVar mvar) >>= mapM_ (flip throwTo e))+    `finally` getChanContents (taskWaitChan task) >> return ()++-- | Like 'throwToTask', but throws 'Control.Exception.ThreadKilled'.+killTask :: Task -> IO ()+killTask = flip throwToTask ThreadKilled++-- | This is a better way to manage a 'Task' because all tasks evaluated are waited for+-- synchronously, but you can provide a callback that is evaluated after each task completes. This+-- prevents exceptions from occurring, for example:+-- > "thread blocked indefinitely in an MVar operation"+-- +-- Provide a list of IO functions to be evaluated in parallel. Also provide a callback function+-- that will be evaluated after each thread completes. This function should take two parameters and+-- return a bool: the 'Control.Concurrent.ThreadId' of the thread that completed and a positive+-- integer value indicating the number of threads that are still running, and the bool returned+-- should indicate whether or not the loop should continue. If you should halt the loop by returning+-- 'Prelude.False', the threads in the task that are still running will continue running, and you+-- should call 'killTask' after 'taskLoop' to halt them if halting them should be necessary.+-- +-- This function is also exception safe. All tasks evaluated in parallel will not fail to singal the+-- callback, even if the thread halts with an exception or asynchronous signal from a function like+-- 'Control.Concurrent.killThread'. If the thread evaluating this function is halted by an+-- exception, all threads in the 'Task' are also killed.+taskLoop :: Task -> [IO ()] -> (ThreadId -> Int -> IO Bool) -> IO ()+taskLoop task parallelIO threadHaltedEvent = unless (null parallelIO) $+  (do mapM_ (forkInTask task) parallelIO+      fix $ \loop -> waitFirst task >>= \ (thread, remain) ->+        threadHaltedEvent thread remain >>= \contin -> unless (not contin || remain==0) loop+  ) `onException` killTask task+  where+    waitFirst :: Task -> IO (ThreadId, Int)+    waitFirst task = readChan (taskWaitChan task)+    forkInTask :: Task -> IO () -> IO ThreadId+    forkInTask task run = forkIO $ do+      self <- myThreadId+      bracket+        (modifyMVar (taskRunningThreads task) $ \s' -> do+            let s = S.delete self s'+            return (s, S.size s)+        )+        (\i -> writeChan (taskWaitChan task) (self, i))+        (\ _i -> run)++-- | Works exactly like 'taskLoop', except you do not need to provide a callback function to be+-- evaluated after every task completes. Essentially, every IO function is evaluated in the 'Task'+-- in parallel, and this function blocks until all tasks have completed.+taskLoop_ :: Task -> [IO ()] -> IO ()+taskLoop_ task inits = taskLoop task inits (\ _ _ -> return True)++----------------------------------------------------------------------------------------------------++-- | This simple, humble little class is one of the most important in the Dao program because it+-- defines the 'execute' function. Any data type that can result in procedural execution in the+-- 'Exec' monad can instantiate this class. This will allow the instnatiated data type to be used as+-- a kind of executable code that can be passed around and evaluated at arbitrary points in your Dao+-- program.+-- +-- Note that there the @result@ type parameter is functionally dependent on the @exec@ type+-- parameter. This guarantees there is a one-to-one mapping from independent @exec@ types to+-- dependent @result@ types, i.e. if you data type @MyDat@ maps to a data type @Rzlt@, then @Rzlt@+-- is the only possible data type that could ever be evaluated by 'execute'-ing the @MyDat@+-- function.+--+-- As a reminder, functional dependencies do not necessitate a one-to-one mapping from the+-- dependent type to the independent type, so the @result@ parameter may be the same for many+-- different @exec@ types. But once the compiler infers that the @exec@ parameter of the 'Executable'+-- class is @MyDat@, the @result@ type /must/ be @Rzlt@ and nothing else.+-- > instance Executable MyDat Rzlt+-- > instance Executable A     () -- OK (different @exec@ parameters, same @result@ parameters)+-- > instance Executable B     () -- OK+-- > instance Executable C     () -- OK+-- > +-- > instance Executable D     ()   -- COMPILER ERROR (same @exec@ parameters, different @result@ parameters)+-- > instance Executable D     Int  -- COMPILER ERROR+-- > instance Executable D     Char -- COMPILER ERROR+-- In this example, should D instantiate () or Int or Char as it's result? You must choose only one.+class Executable exec result | exec -> result where { execute :: exec -> Exec result }++----------------------------------------------------------------------------------------------------++-- | Since the 'ExecUnit' deals with a few different kinds of pointer values, namely+-- 'Data.IORef.IORef' and 'MVar', which all have similar functions for reading and updating, I have+-- defined this class to provide a consistent set of functions for working with the various pointers+-- data types.+class ExecRef var where+  execReadRef    :: var a -> Exec a+  execTakeRef    :: var a -> Exec a+  execPutRef     :: var a -> a -> Exec ()+  execSwapRef    :: var a -> a -> Exec a+  execModifyRef  :: var a -> (a -> Exec (a, b)) -> Exec b+  execModifyRef_ :: var a -> (a -> Exec  a    ) -> Exec ()+  execModifyRef_ var upd = execModifyRef var (\a -> upd a >>= \a -> return (a, ()))++instance ExecRef MVar where+  execModifyRef mvar upd =+    Exec $ PredicateT $ StateT $ \xunit -> modifyMVar mvar $ \var -> do+      (result, xunit) <- flip ioExec xunit $ execCatchIO (upd var) $+        [ newExecIOHandler $ flip (execThrow "") [] . ExecHaskellError+        , newExecIOHandler $ flip (execThrow "") [] . ExecIOException+        ]+      let x var p = return (var, (p, xunit))+      case result of+        Backtrack   -> x var $ Backtrack+        OK (var, o) -> x var $ OK      o+        PFail   err -> x var $ PFail err+  execModifyRef_ mvar upd = execModifyRef mvar (\var -> upd var >>= \var -> return (var, ()))+  execReadRef      = liftIO . readMVar+  execTakeRef      = liftIO . takeMVar+  execPutRef  mvar = liftIO . putMVar  mvar+  execSwapRef mvar = liftIO . swapMVar mvar++instance ExecRef IORef where+  execModifyRef  ref upd = liftIO (readIORef ref) >>= upd >>= \ (var, b) -> liftIO (writeIORef ref var) >> return b+  execModifyRef_ ref upd = liftIO (readIORef ref) >>= upd >>= liftIO . writeIORef ref+  execReadRef            = liftIO . readIORef+  execTakeRef            = execReadRef+  execPutRef     ref     = liftIO . writeIORef ref+  execSwapRef    ref obj = liftIO (readIORef ref >>= \sw -> writeIORef ref obj >> return sw)++----------------------------------------------------------------------------------------------------++data ObjFocusState o+  = ObjFocusState+    { targetReference      :: Reference+      -- ^ the whole reference we intend to use+    , focalReference       :: Reference+      -- ^ the reference that is constructed piecewise as each part of the 'targetReference' is resolved.+    , objectInFocus        :: o+    , objectInFocusChanged :: Bool+      -- ^ this value is automatically set whenever the 'Control.Monad.State.put' function, or+      -- 'Control.Monad.State.modify' functions are evaluated. This value is returned by functions+      -- like 'withInnerFocus' and 'runObjectFocus' to indicate when the item being modified was+      -- actually modified.+    , focusLookup          :: Bool+      -- ^ when true, indicates that the current focus operation is a lookup. Lookups are different+      -- from updates in that an update can continue recursive searching through an object tree even+      -- if the reference to be updated is void. Assignment operations, for example, update void+      -- references by writing to the reference. Lookup operations, on the other hand, will always+      -- fail as soon as a void is encountered.+    }++-- Although the 'ObjectFocus' monad is a wrapper around a 'Dao.Predicate.PredicateT' monad+-- transformer that lifts the 'Exec' monad, backtracking (the instantiation  of+-- 'Control.Monad.mzero') has a very different semantical meaning from the 'Exec' monad's semantical+-- meaning of backtracking. In the case of 'ObjectFocus', evaluating 'Control.Monad.mzero' indicates+-- a refernece being looked-up is undefined. To allow for 'Exec' to be lifted into 'ObjectFocus' and+-- also possibly evaluate to 'Control.Monad.mzero' without triggering a backtracking in the+-- 'ObjectFocus' monad, backtracking in the 'Exec' monad needs to be "caught" and re-thrown as an+-- error using 'Control.Monad.Error.throwError' wrapped up in the 'ObjFocusError' data type. However+-- this is all done "under the hood," the public API of the 'ObjectFocus' monad still has+-- 'Control.Monad.Error.throwError' instantiated to throw 'ExecControl' just like the 'Exec' monad:+-- > 'Control.Monad.Error.Class.MonadError' 'ExecControl' 'ObjectFocus'+-- and when evaluting the 'ObjectFocus' monad in the 'Exec' monad using 'runObjectFocus', this+-- error type is automatically caught again and converted back to 'Control.Monad.mzero', initiating+-- ordinary backtracking in the 'Exec' monad.+data ObjFocusError+  = InnerExecBacktrack -- ^ a lifted 'Exec' monad evaluated to 'Control.Monad.mzero'+  | InnerExecPFail ExecControl+    -- ^ a lifted 'Exec' monad evaluated to 'Control.Monad.Error.throwError'++-- | This is the stateful monad used by the 'ObjectLens' and 'ObjectFunctor' classes. It is called a+-- "focus" because the object we are focused on (on which we are looking up indicies or modifying+-- indicies) is stored in the state of the monad. The 'Control.Monad.State.modify' function modifies+-- the object in the focus.+newtype ObjectFocus o a+  = ObjectFocus{ mapObjectLensToPredicate :: PredicateT ObjFocusError (StateT (ObjFocusState o) Exec) a }+  deriving (Functor, Applicative, Alternative, MonadPlus)++instance Monad (ObjectFocus o) where+  return = ObjectFocus . return+  (ObjectFocus m) >>= f = ObjectFocus $ m >>= mapObjectLensToPredicate . f+  fail msg = _mapStructState (gets focalReference) >>= flip (execThrow msg) []++instance MonadError ExecControl (ObjectFocus o) where+  throwError = ObjectFocus . throwError . InnerExecPFail+  catchError (ObjectFocus f) catch = ObjectFocus $ catchError f $ \err -> case err of+    InnerExecPFail err -> mapObjectLensToPredicate (catch err)+    InnerExecBacktrack -> throwError InnerExecBacktrack++instance MonadPlusError ExecControl (ObjectFocus o) where+  catchPredicate (ObjectFocus f) = ObjectFocus $ catchPredicate f >>= \p -> case p of+    OK                    o  -> return $ OK o+    PFail (InnerExecPFail e) -> return $ PFail e+    PFail InnerExecBacktrack -> throwError InnerExecBacktrack+    Backtrack                -> return Backtrack+  predicate = ObjectFocus . predicate . fmapPFail InnerExecPFail++instance MonadIO (ObjectFocus o) where { liftIO = ObjectFocus . liftIO }++instance MonadState o (ObjectFocus o) where+  get   = _mapStructState $ gets objectInFocus+  put o = _mapStructState $ modify $ \st -> st{objectInFocus=o, objectInFocusChanged=True}++-- | An 'ObjectFocus' function that updates a value within the data of type @o@ in focus at a given+-- @index@ using an inner 'ObjectFocus' function that focuses on the 'Object' value at the index if+-- it exists. The type of the inner 'ObjectFocus' is @('Prelude.Maybe' 'Object')@ because there may+-- be no value defined at the given index.+type ObjectUpdate o index = index -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus o (Maybe Object)++-- | An 'ObjectFocus' that traverses the 'Object' in the focus by calling the provided traversal+-- function for every @index -> 'Object'@ relation defined within the data of type @o@. The+-- traversal function is an inner focus of type @[(index, 'Object')]@. The list in focus should+-- initially be empty when the inner traversal function is called. When the inner traversal function+-- is completed, it should contain every @(index, 'Object')@ that is intended to be stored back into+-- the data of type @o@. The outer 'ObjectFocus' should retrieve this list of pairs and determine+-- how to update the data of type @o@ accordingly.+type ObjectTraverse o index = (index -> Object -> ObjectFocus [(index, Object)] ()) -> ObjectFocus o ()++-- | This class provides functions that can be used to establish 'ObjectFocus' for various data+-- types. The class allows you to define an association between an index and and object type o, and+-- how the index is used to read and update the object o.+-- There are no functional dependencies between the object type and the index type, so using these+-- function may require type annotation.+class ObjectLens o index where { updateIndex :: ObjectUpdate o index }++-- | This class provides the 'objectFMap' function for evaluating a functor over every item in an+-- 'bject in the focus of an 'ObjectFocus'. The function that maps to the functor object takes a+-- polymorphic index type and the 'Object' associated with that index. For example, in the case of a+-- 'T_dict' type, the index would be a 'Dao.String.Name', in the case of a 'T_list' type, the index+-- would be a 'Prelude.Integer'.+class ObjectFunctor o index where { objectFMap :: ObjectTraverse o index }++_mapStructState :: StateT (ObjFocusState o) Exec a -> ObjectFocus o a+_mapStructState = ObjectFocus . lift++_getTargetRefInfo :: ObjectFocus o Reference+_getTargetRefInfo = _mapStructState $ gets targetReference++_setTargetRefInfo :: Reference -> ObjectFocus o ()+_setTargetRefInfo qref = _mapStructState $ modify $ \st -> st{targetReference=qref}++-- | This function will check if the 'focusLookup' boolean is set. If it is set, it checks if the+-- current 'objectInFocus' is 'Prelude.Nothing' and backtracks if it is. Otherwise it evaluates the+-- given function.+focusNext :: ObjectFocus (Maybe o) a -> ObjectFocus (Maybe o) a+focusNext f = do+  isLookup <- _mapStructState (gets focusLookup)+  if isLookup then get >>= maybe mzero (const f) else f++-- | When instantiating the 'ObjectLens' class with a 'RefSuffix' index type, it is useful to+-- record the head of the 'RefSuffix' that is being used to resolve the index. When an+-- 'Control.Monad.fail' is evaluated, the current path (the 'RefSuffix') to the part of the object+-- where the failure occurred will be used in the error report. Bracketing your 'ObjectFocus'+-- evaluation in this function will help create better error reports.+focalPathSuffix :: RefSuffix -> ObjectFocus o a -> ObjectFocus o a+focalPathSuffix suf f = do+  r <- _mapStructState $ get >>= \st -> do+    let r = focalReference st+    put (st{ focalReference=refAppendSuffix r suf }) >> return r+  f >>= \a -> _mapStructState (modify $ \st -> st{ focalReference=r }) >> return a++focusLiftExec :: Exec a -> ObjectFocus o a+focusLiftExec exec = ObjectFocus $ do+  p <- lift $ lift $ catchPredicate exec+  case p of+    Backtrack -> throwError InnerExecBacktrack+    PFail err -> throwError $ InnerExecPFail err+    OK    o   -> return o++execToFocusUpdater :: (Maybe Object -> Exec (Maybe Object)) -> ObjectFocus (Maybe Object) (Maybe Object)+execToFocusUpdater f = get >>= focusLiftExec . f >>= \o -> put o >> return o++getFocalReference :: ObjectFocus o Reference+getFocalReference = _mapStructState (gets focalReference)++-- | This is a kind of entry-point to the 'ObjectFocus' group of functions. First provide a boolean+-- value indicating whether this operation is a ('Prelude.True') lookup and should fail as soon as a+-- void address is encountered, or ('Prelude.False') an update that may insert a value at a void+-- address rather than failing. Second, provide a 'Reference' value for error reporting, to indicate+-- where a 'lookupIndex' or 'updateIndex' function failed. Note that using 'lookupIndex' and+-- 'updateIndex' functions instantiated for 'RefSuffix' indicies will append these indicies to the+-- 'Reference', so it might be better to pass the 'referenceHead' of the 'Reference'. Then supply an+-- object upon which the 'lookupIndex', 'updateIndex', or 'objectFMap' functions will be evaluating.+runObjectFocus :: ObjectFocus o a -> Bool -> Reference -> o -> Exec (a, (Reference, Bool, o))+runObjectFocus f isLookup qref o = _runObjectFocus f st >>= \p -> case p of+  OK                    o  -> return o+  PFail (InnerExecPFail e) -> throwError e+  PFail InnerExecBacktrack -> mzero+  Backtrack                -> execThrow "undefined reference" qref []+  where+    st= ObjFocusState+        { targetReference      = qref+        , focalReference       = fst (referenceHead qref)+        , objectInFocus        = o+        , objectInFocusChanged = False+        , focusLookup          = isLookup+        }++_runObjectFocus :: ObjectFocus o a -> ObjFocusState o -> Exec (Predicate ObjFocusError (a, (Reference, Bool, o)))+_runObjectFocus (ObjectFocus f) st = flip evalStateT st $ runPredicateT $ f >>= \a -> do+  o <- lift $ return (,,) <*> gets targetReference <*> gets objectInFocusChanged <*> gets objectInFocus+  return (a, o)++-- | This is a very important function because it allows you to evaluate an inner 'ObjectFocus'+-- monad that is focused on a different type from the type focus of the monad in the context in+-- which this function is evaluated. It allows you to select a sub-field of the current focus (for+-- example using 'Control.Monad.State.gets') and evaluate an updating function or lookup function+-- that uses value of the sub-field. This function returns the result of the evaluation, and the+-- updated value which can then be placed back into the sub-field if necessary. By composing+-- 'withInnerLens' functions, it is possible to construct a lens that can read and update any value+-- in arbitrarily complex data types.+withInnerLens :: sub -> ObjectFocus sub a -> ObjectFocus o (a, (Bool, sub))+withInnerLens sub f = do+  st <- _mapStructState get+  o  <- focusLiftExec $ _runObjectFocus f $ st{objectInFocus=sub}+  ObjectFocus $ predicate $ o >>= \ (a, (_ref, changed, o)) -> return (a, (changed, o))++-- Used in the 'Interface' table to convert between a @typ@ and 'Data.Dynamic.Dynamic' value.+convertFocus :: (a -> b) -> (b -> a) -> ObjectFocus a x -> ObjectFocus b x+convertFocus a2b b2a f = get >>= flip withInnerLens f . b2a >>= \ (x, (changed, a)) ->+  when changed (put $ a2b a) >> return x++focusObjectClass :: ObjectClass o => ObjectFocus o a -> ObjectFocus Object a+focusObjectClass f = do+  (a, (changed, o)) <- get >>= xmaybe . fromObj >>= flip withInnerLens f+  when changed (put $ obj o) >> return a++instance ObjectLens T_dict Name where+  updateIndex name f = do+    (result, (changed, o)) <- get >>= flip withInnerLens (focusNext f) . (M.lookup name)+    when changed (modify $ M.alter (const o) name)+    return result++instance ObjectFunctor T_dict Name where+  objectFMap f = get >>=+     mapM (\ (name, o) -> focalPathSuffix (DotRef name NullRef) $ withInnerLens [] $ f name o+          ) . M.assocs >>= put . M.fromList . concatMap (snd . snd)++focusGuardStructName :: Name -> ObjectFocus T_struct ()+focusGuardStructName name = get >>= guard . (==name) . structName++focusStructAsDict :: ObjectFocus T_dict a -> ObjectFocus T_struct a+focusStructAsDict f = get >>= \struct -> case struct of+  Nullary{ structName=name } -> do+    (a, (changed, sub)) <- withInnerLens M.empty f+    if M.null sub+    then return ()+    else when changed (put $ Struct{ structName=name, fieldMap=sub })+    return a+  Struct{ structName=name, fieldMap=sub } -> do+    (a, (changed, sub)) <- withInnerLens sub f+    when changed $ do+      if M.null sub+      then put (Nullary{ structName=name })+      else put (struct{ fieldMap=sub })+    return a++instance ObjectLens T_struct Name where+  updateIndex name f = focusStructAsDict $ updateIndex name f++instance ObjectFunctor T_struct Name where+  objectFMap f = focusStructAsDict $ objectFMap f++updateHataAsStruct :: ObjectFocus T_struct a -> ObjectFocus Hata a+updateHataAsStruct f = do+  (Hata ifc o) <- get+  (fromStruct, toStruct) <- xmaybe (return (,) <*> objFromStruct ifc <*> objToStruct ifc)+    -- here ^ evaluation backtracks if the field cannot be accessed+  struct <- predicate $ fromData toStruct o+  (a, (changed, struct)) <- withInnerLens struct f+  when changed (predicate (toData fromStruct struct) >>= put . Hata ifc)+  return a++lookupHataAsStruct :: ObjectFocus T_struct a -> ObjectFocus Hata a+lookupHataAsStruct f = do+  (Hata ifc o) <- get+  toStruct <- xmaybe (objToStruct ifc)+  struct <- predicate $ fromData toStruct o+  fst <$> withInnerLens struct f++instance ObjectLens Hata Name where+  updateIndex name f = updateHataAsStruct $ updateIndex name f++instance ObjectFunctor Hata Name where+  objectFMap = flip mplus (return ()) . updateHataAsStruct . focusStructAsDict . objectFMap++instance ObjectLens [Object] Integer where+  updateIndex idx f = get >>= \ox ->+    if idx == negate 1+    then do+      (result, (changed, o)) <- withInnerLens Nothing f+      when changed (put $ maybe ox (:ox) o)+      return result+    else do+      let splitlen i rx ox = case ox of+            []   -> (i, rx, [])+            o:ox -> if i<idx then splitlen (i+1) (rx++[o]) ox else (i, rx, o:ox)+      let (len, lo, hi) = splitlen 0 [] ox+      if 0<=idx && idx<=len+      then+        if null hi+        then do+          (result, (changed, o)) <- withInnerLens Nothing f+          when changed (put $ maybe ox ((ox++) . return) o)+          return result+        else do+          (result, (changed, o)) <- withInnerLens (Just $ head hi) f+          when changed (put $ lo ++ maybe [] return o ++ tail hi)+          return result+      else execThrow "index ouf of bounds" ExecErrorUntyped [(assertFailed, OLong idx)]++instance ObjectFunctor [Object] Integer where+  objectFMap f = get >>=+     mapM (\ (idx, o) -> focalPathSuffix (Subscript [obj idx] NullRef) $ withInnerLens [] $ f idx o+          ) . zip [0..] >>= put . map snd . sortBy (\a b -> compare (fst a) (fst b)) . concatMap (snd . snd)++_dictSubscriptUpdate+  :: ObjectLens o Name+  => String -> [Object]+  -> ObjectFocus (Maybe Object) (Maybe Object)+  -> ObjectFocus o (Maybe Object)+_dictSubscriptUpdate msg ix f = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of+  []  -> fail $ "void subscript used to index "++msg+  [ORef (Reference UNQUAL name suf)] -> updateIndex name $ updateIndex suf f+  [_] -> fail $ "non-reference subscript used to update index of "++msg+  _   -> fail $ "multi-dimensional subscript used to update index of "++msg++-- Converts the function @f@ that is passed to an 'objectFMap' which takes an index value of type+-- @i@ to a value suitable for invoking an 'objectFMap' function instantiated for a different type+-- @fi@.+objectFMapConvert+  :: (i -> ObjectFocus [(fi, Object)] fi) -> (fi -> ObjectFocus [(i, Object)] i)+  -> (fi -> Object -> ObjectFocus [(fi, Object)] ())+  -> i -> Object+  -> ObjectFocus [(i, Object)] ()+objectFMapConvert i2fi fi2i f i o = getFocalReference >>= \qref -> do+  (_, (_, changed, o)) <- focusLiftExec (runObjectFocus (i2fi i >>= flip f o) False qref [])+  o <- forM o (\ (fi, o) -> fi2i fi >>= \i -> return (i, o))+  _mapStructState $ modify $ \st -> st{objectInFocusChanged=changed, objectInFocus=o}++_dictSubscriptFMap+  :: ObjectFunctor o Name+  => String -> ([Object] -> Object -> ObjectFocus [([Object], Object)] ()) -> ObjectFocus o ()+_dictSubscriptFMap msg f = objectFMap $ objectFMapConvert i2fi fi2i f where+  i2fi :: Name -> ObjectFocus [([Object], Object)] [Object]+  i2fi name = return [ORef $ Reference UNQUAL name NullRef]+  fi2i :: [Object] -> ObjectFocus [(Name, Object)] Name+  fi2i ix = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of+    [ORef (Reference UNQUAL name NullRef)] -> return name+    _ -> fail $ "improper index value used to update field while traversing "++msg++_index1DIntegral :: Show a => String -> String -> [Object] -> (Integer -> ObjectFocus o a) -> ObjectFocus o a+_index1DIntegral msg1 msg2 ix f = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of+  []  -> fail $ "void subscript used to "++msg1++" list"++msg2+  [i] -> case extractXPure (castToCoreType LongType i) >>= fromObj of+    Nothing -> fail $ "non-integer subscript used to "++msg1++" list"++msg2+    Just  i -> f i+  _   -> fail $ "multi-dimensional subscript used to "++msg1++" list"++msg2++instance ObjectLens [Object] [Object] where+  updateIndex ix f = _index1DIntegral "update" "" ix $ flip updateIndex f++instance ObjectFunctor [Object] [Object] where+  objectFMap = objectFMap .+    objectFMapConvert (\i -> return [OLong i]) (\ix -> _index1DIntegral "traverse" "" ix return)++instance ObjectLens T_dict [Object] where+  updateIndex = _dictSubscriptUpdate "dictionary"++instance ObjectFunctor T_dict [Object] where+  objectFMap = _dictSubscriptFMap   "dictionary"++instance ObjectLens T_struct [Object] where+  updateIndex = _dictSubscriptUpdate "struct"++instance ObjectFunctor T_struct [Object] where+  objectFMap = _dictSubscriptFMap "struct"++_hataUpdateSubscript+  :: (String -> ObjectFocus T_struct (Maybe Object))+  -> ObjectFocus Hata (Maybe Object)+_hataUpdateSubscript f = do+  (Hata ifc _) <- get+  updateHataAsStruct (f $ show $ objHaskellType ifc) <|> fail "cannot update field"++_hataLookupSubscript :: (String -> ObjectFocus T_struct Object) -> ObjectFocus Hata Object+_hataLookupSubscript f = do+  (Hata ifc _) <- get+  lookupHataAsStruct $ f $ show $ objHaskellType ifc++instance ObjectLens Hata [Object] where+  updateIndex ix f = get >>= \ (Hata ifc o) -> case objIndexUpdater ifc of+    Nothing     -> _hataUpdateSubscript $ \msg -> _dictSubscriptUpdate msg ix f+    Just update -> do+      (result, (changed, o)) <- withInnerLens o $ update ix f+      when changed (put $ Hata ifc o) >> return result++instance ObjectFunctor Hata [Object] where+  objectFMap f = get >>= \ (Hata ifc o) -> case objTraverse ifc of+    Nothing       -> updateHataAsStruct (_dictSubscriptFMap (show $ objHaskellType ifc) f) <|>+      fail "cannot update field"+    Just traverse -> do+      ((), (changed, o)) <- withInnerLens o (traverse f)+      when changed (put $ Hata ifc o)++_tryFuncCall+  :: Maybe Object -> [Object] -> RefSuffix+  -> ObjectFocus (Maybe Object) (Maybe Object)+  -> ObjectFocus (Maybe Object) (Maybe Object)+  -> ObjectFocus (Maybe Object) (Maybe Object)+_tryFuncCall func args suf f els = maybe els id $ do+  (Hata ifc d) <- func >>= fromObj+  calls <- objCallable ifc+  return $ do+    -- Get the result of the function call, the result of the operation will become the focus.+    this <- get+    (result, this) <- focusLiftExec (calls d >>= flip (callCallables this) args)+    put this+    -- Focus on the result of the function call and evaluate an update on it.+    -- The updated function result is ignored, any changes made to it are lost.+    (result, _) <- case suf of+      NullRef -> withInnerLens result f+      _       -> withInnerLens result (updateIndex suf f)+    -- The function call may have updated the "this" value, place this updated value back into the focus.+    return result++_refSuffixUpdate+  :: (ObjectClass o, ObjectLens o i)+  => o -> i -> RefSuffix+  -> ObjectFocus (Maybe Object) (Maybe Object)+  -> ObjectFocus (Maybe Object) (Maybe Object)+_refSuffixUpdate o i suf f = do+  (result, (changed, o)) <- withInnerLens o $ updateIndex i $ updateIndex suf f+  when changed (put $ Just $ obj o) >> return result++-- | This is an 'ObjectUpdate' function which operates in the monad+-- > 'ObjectFocus' (Maybe 'Object') (Maybe 'Object')+-- If the object in the focus is an object constructed with 'ODict', 'OTree', or 'OHaskell', then+-- the 'Name' parameter passed to this function is used to lookup a function stored in the object in+-- focus. This function sets the object in focus to the "this" variable in the Dao runtime and then+-- calls the function with the given @['Object']@ arguments. The object in focus is updated by the+-- function call and the result of the function call is placed in the focus and updated by the next+-- update function with the next 'RefSuffix' provided (as the arguments to the 'ObjectUpdate'). This+-- is the semantics for Dao language expressions of the kind:+-- a.b(c).d(e)+-- that is, an objet stored in the variable "a" has a method "b" called with a parameter "(c)" and+-- the result of this call is an object with a method "d" that is called with the parameter "(e)".+-- Of course if the 'RefSuffix' is 'NullRef', the result of the method call is simply returned.  The+-- result of "a.b(c)" is stored on the stack and used to select and evaluate the method "d(e)",+-- however if "d(e)" modified the value on the stack, this modified value is lost when it is popped+-- off of the stack after evaluation completes. There is currently no way to update objects in this+-- way, as the Dao runtime does not have a way to update arbitrary points in it's working memory.+-- This will hopefully be improved in future versions.+callMethod :: Name -> [Object] -> ObjectUpdate (Maybe Object) RefSuffix+callMethod name args suf f = do+  qref <- _getTargetRefInfo+  let err msg = execThrow msg qref []+  o <- get+  case o of+    Nothing -> err "method call on undefined reference"+    Just  o -> case o of+      ODict    d -> _tryFuncCall (M.lookup     name d) args suf f (_refSuffixUpdate d name suf f)+      OTree    d -> _tryFuncCall (structLookup name d) args suf f (_refSuffixUpdate d name suf f)+      OHaskell (Hata ifc d) -> case M.lookup name (objMethodTable ifc) of+        Just func -> do+          (result, d) <- focusLiftExec $ executeDaoFunc func d args+          put (Just $ OHaskell $ Hata ifc d)+          -- Next we take the result of this method call and let any 'RefSuffix's that may exist to+          -- operate on it. Like _tryFuncCall, this will ignore changes made to the result of the+          -- function call.+          (result, _) <- case suf of+            NullRef -> withInnerLens result f+            _       -> withInnerLens result (updateIndex suf f)+          return result+        Nothing   -> case objToStruct ifc of+          Just toStruct -> do+            struct <- predicate (fromData toStruct d)+            _tryFuncCall (structLookup name struct) args suf f (_refSuffixUpdate (Hata ifc d) name suf f)+          Nothing       -> err "not a callable method function"+      _ -> err "method call on atomic object"+            -- TODO: provide a set of built-in methods available to every object.++instance ObjectLens (Maybe Object) RefSuffix where+  updateIndex suf f = _getTargetRefInfo >>= \qref -> focalPathSuffix suf $ get >>= \o -> case suf of+    NullRef         -> focusNext $ get >>= flip withInnerLens f >>= \ (result, (changed, o)) ->+      when changed (put o) >> return result+    DotRef name (FuncCall args suf) -> focusNext $ callMethod name args suf f+    DotRef name suf -> case o of+      Nothing -> mzero+      Just  o -> case o of+        ODict    o -> _refSuffixUpdate o name suf f+        OTree    o -> _refSuffixUpdate o name suf f+        OHaskell o -> _refSuffixUpdate o name suf f+        _          -> throwBadTypeError "referenced element of non-container object" o []+    Subscript ix suf -> focusNext $ case o of+      Nothing -> mzero+      Just  o -> case o of+        OList    o -> _refSuffixUpdate o ix suf f+        ODict    o -> _refSuffixUpdate o ix suf f+        OTree    o -> _refSuffixUpdate o ix suf f+        OHaskell o -> _refSuffixUpdate o ix suf f+        _          -> throwBadTypeError "cannot subscript of non-indexed object" o []+    FuncCall  args suf -> focusNext $ case o of+      Nothing -> mzero+      Just  o -> do+        (result, o) <- focusLiftExec (callObject qref o args)+        _mapStructState $ modify $ \st -> st{ objectInFocus=o }+        -- -^ Here we put the updated function back (it may have had it's static var table updated),+        -- but we use '_mapStructState' to do it. This is because using 'modify' or 'put' will+        -- automatically set the 'objectInFocusChanged' flag. Since many functions 'CONST' and we+        -- would like to update the function's static table without modifying the function itself+        -- without also triggering the exception thrown when a const variable is modified, we must+        -- make sure we update it in a way that would not indicate that the function object itself+        -- has been modified.+        (result, _) <- case suf of+          NullRef -> withInnerLens result f+          suf     -> withInnerLens result (updateIndex suf f)+        return result++instance ObjectFunctor Object RefSuffix where+  objectFMap f = get >>= \o -> case o of+    OList    o -> travers o int2subs subs2int OList+    ODict    o -> travers o ref2subs subs2ref ODict+    OTree    o -> travers o ref2subs subs2ref OTree+    OHaskell o -> travers o ref2subs subs2ref OHaskell+    _          -> return ()+    where+      int2subs i = return $ Subscript [OLong i] NullRef+      subs2int i = case i of+        Subscript [o] NullRef -> case extractXPure (castToCoreType LongType o) >>= fromObj of+          Nothing -> fail "while traversing list, updating function returned non-integer index value"+          Just  i -> return i+        _ -> fail "while traversing list, updating function returned non-subscript reference as index"+      ref2subs i = return $ DotRef i NullRef+      subs2ref i = case i of+        DotRef name NullRef -> return name+        _ -> fail "while traversing structure, updating function returned invalid reference"+      travers o to from constr = do+        (_, (changed, o)) <- withInnerLens o (objectFMap $ objectFMapConvert to from f)+        when changed (put $ constr o)++instance ObjectFunctor (Maybe Object) RefSuffix where+  objectFMap f = get >>= maybe (return ()) (fmap fst . flip withInnerLens (objectFMap f))++-- | If you have a data type @o@ instantiating @'ObjectLens' o index@ with a given index type, and+-- this data type @o@ is a field of another @data@ type, you can instantiate 'updateIndex' for this+-- data type by providing functions to unwrap and wrap the data type @o@ inside of it. For+-- @newtype@s, the wrapper function can be given as @('Prelude.const' MyNewtype)@ where+-- @MyNewtype@ is the newtype constructor.+innerDataUpdateIndex+  :: (Show o, ObjectLens o index)+  => (dt -> o) -> (dt -> o -> dt)+  -> index -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus dt (Maybe Object)+innerDataUpdateIndex unwrap wrap i upd = get >>= \dt -> do+  (result, (changed, o)) <- withInnerLens (unwrap dt) (updateIndex i upd)+  when changed (modify $ flip wrap o) >> return result++----------------------------------------------------------------------------------------------------++instance ObjectLens (Stack Name Object) Name where+  updateIndex name upd = do+    ((result, changed), stack) <- get >>=+      stackUpdateM (flip withInnerLens upd >=> \ (result, (changed, o)) -> return ((result, changed), o)) name+    when changed (put stack) >> return result++-- | This function can be used to automatically instantiate 'updateIndex' for any type @o@ that also+-- instantiates @'ObjectLens' o 'Dao.String.Name'@.+referenceUpdateName :: ObjectLens o Name => Reference -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus o (Maybe Object)+referenceUpdateName qref f = case qref of+  Reference _ name suf -> updateIndex name $ updateIndex suf f+  RefObject o suf -> case o of+    ORef o -> referenceUpdateName (refAppendSuffix o suf) f+    _      -> fail "cannot update reference"+  RefWrapper _ -> fail "cannot update reference"++-- | This function can be used to automatically instantiate 'lookupIndex' for any type @o@ that also+-- instantiates @'ObjectLens' o 'Dao.String.Name'@. This function may also performs updates on variables+-- in place if the variable contains an object and the reference is a method call which updates the+-- object.+referenceLookupName :: ObjectLens o Name => Reference -> ObjectFocus o Object+referenceLookupName qref = case qref of+  Reference _ name suf -> updateIndex name get >>=+    fmap fst . flip withInnerLens (updateIndex suf get) >>= maybe (execThrow "" qref []) return+  RefObject o      suf -> case o of+    ORef o -> referenceLookupName (refAppendSuffix o suf)+    _      -> fail "cannot update reference"+  RefWrapper _ -> fail "cannot update reference"++instance ObjectLens (Stack Name Object) Reference where { updateIndex = referenceUpdateName }++----------------------------------------------------------------------------------------------------++updateLocal :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)+updateLocal name suf f = do+  stack <- focusLiftExec (gets execStack)+  (result, (changed, o)) <- withInnerLens (stackLookup name stack) (updateIndex suf f)+  -- The updateIndex function may have performed a function call that updated the local stack so we+  -- need to get the (possibly) updated stack from the 'ExecUnit' once again and operate on that.+  when changed $ focusLiftExec (gets execStack) >>= \stack -> focusLiftExec $ modify $ \xunit ->+    xunit{ execStack = snd $ stackUpdate (const ((), o)) name stack }+  return (Reference LOCAL name suf, result)++updateConst :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)+updateConst name suf f = do+  let qref = Reference CONST name suf+  consts <- focusLiftExec (gets builtinConstants)+  (result, (changed, _)) <- withInnerLens (M.lookup name consts) (updateIndex suf f)+  when changed $ case suf of -- Modifying a const variable directly fails.+    NullRef -> execThrow "attempted modification of immutable value" ExecErrorUntyped [(modifiedConst, obj qref)]+    _       -> return () -- modifying a member of a const value is OK but the updated value is disgarded.+  return (qref, result)++updateStatic :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)+updateStatic name suf f = do+  let qref = Reference STATIC name suf+  store <- focusLiftExec (gets currentCodeBlock) >>= maybe mzero return+  (result, (changed, o)) <- withInnerLens (M.lookup name $ staticVars store) (updateIndex suf f)+  when changed $ focusLiftExec (gets currentCodeBlock) >>= \store -> case store of+    Nothing    -> return ()+    Just store -> focusLiftExec $ modify $ \xunit ->+      xunit+      { currentCodeBlock = Just $+          store{ staticVars = M.alter (const o) name (staticVars store) }+      }+  return (qref, result)++updateGlobal :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)+updateGlobal name suf f = do+  let qref = Reference GLOBAL name suf+  store <- focusLiftExec (gets globalData)+  (result, (changed, o)) <- withInnerLens (M.lookup name store) (updateIndex suf f)+  when changed $ focusLiftExec (gets globalData) >>= \store -> focusLiftExec $ modify $ \xunit ->+    xunit{ globalData = M.alter (const o) name store }+  return (qref, result)++updateWithRef :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object)+updateWithRef name suf f = do+  let qref = Reference GLODOT name suf+  store <- focusLiftExec (gets currentWithRef)+  case store of+    Nothing -> updateGlobal name suf f+    Just  o -> do+      (result, (changed, o)) <- withInnerLens (Just o) (updateIndex suf f)+      when changed $ focusLiftExec $ modify $ \xunit -> xunit{ currentWithRef=o }+      return (qref, result)++instance ObjectLens () Name where+  updateIndex name = updateIndex (Reference UNQUAL name NullRef)++instance ObjectLens () Reference where+  updateIndex qref f = do+    (qref, result) <- case qref of+      Reference q name suf -> case q of+        UNQUAL -> fmap fst $ withInnerLens () $ msum $+          [ updateLocal   name suf f+          , updateConst   name suf f+          , updateStatic  name suf f+          , updateGlobal  name suf f+          , updateWithRef name suf f+          ]+        LOCAL  -> updateLocal   name suf f+        CONST  -> updateConst   name suf f+        STATIC -> updateStatic  name suf f+        GLOBAL -> updateGlobal  name suf f+        GLODOT -> updateWithRef name suf f+      _ -> execThrow "cannot update reference" qref []+    _setTargetRefInfo qref >> return result++----------------------------------------------------------------------------------------------------++-- | Error report indicating which function was being evaluated when the error occurred.+errInFunc :: Name+errInFunc = ustr "errInFunc"++-- | Error report indicating which function was being evaluated when the error occurred.+errInConstr :: Name+errInConstr = ustr "errInConstr"++-- | Error report indicating which function was being evaluated when the error occurred.+errInInitzr :: Name+errInInitzr = ustr "errInInitzr"++-- | Error report indicating which function was being evaluated when the error occurred.+errOfReference :: Name+errOfReference = ustr "errOfReference"++-- | Error report for function calls indicating which argument to the function was incorrect.+argNum :: Name+argNum = ustr "argNum"++-- | Error report for function calls indicating the number of arguments passed to the function.+numArgsPassed :: Name+numArgsPassed = ustr "numArgsPassed"++-- | Error report for subscript expressions indicating the number of dimensions expected+expectNumArgs :: Name+expectNumArgs = ustr "expectNumArgs"++-- | Error report for subscript expressions indicating the number of dimensions expected+exectDimension :: Name+exectDimension = ustr "expectDimension"++-- | Error report used any place an object value of an incorrect data type was given.+expectType :: Name+expectType = ustr "expectType"++-- | Error report indicating that the data type of the 'Object' given was incorrect.+actualType :: Name+actualType = ustr "actualType"++-- | Error report indicating the data type of the right-hand side of an infix operator.+leftSideType :: Name+leftSideType = ustr "leftSideType"++-- | Error report indicating the data type of the right-hand side of an infix operator.+rightSideType :: Name+rightSideType = ustr "rightSideType"++-- | Error report indicating an attempt to modify a 'CONST' 'Reference'.+modifiedConst :: Name+modifiedConst = ustr "modifiedConst"++-- | Error report indicating an object value was of the correct type but was out of bounds or was+-- otherwise not correct.+assertFailed :: Name+assertFailed = ustr "assertFailed"++-- | Error report indicating a function call evalauted to void.+returnedVoid :: Name+returnedVoid = ustr "returnedVoid"++-- | This is a simple dictionary of strings that can translate the keys of the 'execErrorInfo'+-- dictionary to more meaningful explanatory strings when reporting error messages.+errorDict :: M.Map Name UStr+errorDict = M.fromList $ fmap (fmap ustr) $+  [(errInFunc     , "in function call")+  ,(errInConstr   , "in constructor")+  ,(errInInitzr   , "in initializer list")+  ,(errOfReference, "of reference")+  ,(argNum        , "argument number")+  ,(expectNumArgs , "number of arguments expected")+  ,(exectDimension, "dimensional data type")+  ,(numArgsPassed , "number of arguments given")+  ,(expectType    , "expecting type")+  ,(actualType    , "actual type used")+  ,(leftSideType  , "data type of the left-hand operand")+  ,(rightSideType , "data type of the right-hand operand")+  ,(modifiedConst , "modification on constant reference")+  ,(assertFailed  , "object value fails assertion test")+  ,(returnedVoid  , "expression evaluated to void")+  ]++----------------------------------------------------------------------------------------------------++-- | This data type is use to halt normal evaluation and force the result of evaluating the code to+-- be a particular value of this type. The 'Exec' monad instantiates+-- 'Control.Monad.Error.Class.MonadError' such that 'Control.Monad.Error.Class.throwError' throws a+-- value of this type. However, it is not only used for exceptions. The Dao scripting language's+-- "return" statement throws an 'ExecReturn' value which is caught using+-- 'Control.Monad.Error.Class.catchError' when evaluating function calls.+data ExecControl+  = ExecReturn { execReturnValue :: Maybe Object }+  | ExecError+    { execErrorMessage  :: UStr+    , execErrorInModule :: Maybe UStr+    , execErrorLocation :: Location+    , execErrorSubtype  :: ExecErrorSubtype+    , execErrorInfo     :: T_dict+    }+  deriving Typeable++instance Show ExecControl where { show=prettyShow }++instance HasNullValue ExecControl where+  nullValue = ExecReturn Nothing+  testNull (ExecReturn Nothing) = True+  testNull  _                   = False++instance PPrintable ExecControl where+  pPrint err = case err of +    ExecError{ execErrorMessage=msg, execErrorLocation=loc } -> do+      maybe (return ()) (pString . (++":") . uchars) (execErrorInModule err)+      pShow loc >> pString (if testNull loc then " " else ": ")+      when (not $ msg==nil) (pUStr msg)+      pIndent $ do+        pEndLine >> pPrint (execErrorSubtype err)+        forM_ (M.assocs $ execErrorInfo err) $ \ (key, val) -> do+          pEndLine+          maybe (pPrint key >> pString ": ") (pString . (++" ") . uchars) (M.lookup key errorDict)+          pPrint val+    ExecReturn{ execReturnValue=o } -> maybe (return ()) pPrint o++instance ToDaoStructClass ExecControl where+  toDaoStruct = ask >>= \o -> case o of+    ExecReturn{} -> renameConstructor "ExecReturn" $ asks execReturnValue >>= ("value" .=?)+    ExecError {} -> renameConstructor "ExecError" $ do+      asks execErrorInModule >>= ("inModule" .=?)+      "message"  .=@ execErrorMessage+      "location" .=@ execErrorLocation+      "subtype"  .=@ execErrorSubtype+      "info"     .=@ execErrorInfo++instance HataClass ExecControl where+  haskellDataInterface = interface "ExecControl" $ do+    autoDefPPrinter >> autoDefNullTest >> autoDefToStruct++instance HasNullValue ExecErrorSubtype where+  nullValue = ExecErrorUntyped+  testNull ExecErrorUntyped = True+  testNull _               = False++newError :: ExecControl+newError =+  ExecError+  { execErrorMessage  = nil+  , execErrorInModule = Nothing+  , execErrorLocation = LocationUnknown+  , execErrorSubtype  = ExecErrorUntyped+  , execErrorInfo     = mempty+  }++throwArityError :: MonadError ExecControl m => String -> Int -> [o] -> [(Name, Object)] -> m ig+throwArityError msg i ox info = execThrow fullmsg ExecErrorUntyped moreInfo where+  (before, after) = splitAt 100 ox+  fullmsg = (++(if null msg then "" else ", "++msg)) $+    if null after then "incorrect number of arguments given" else "over 100 arguments given"+  moreInfo = concat $+    [ if null after then [(numArgsPassed, OInt $ length before)] else []+    , [(expectNumArgs, OInt i)], info+    ]++throwBadTypeError :: MonadError ExecControl m => String -> Object -> [(Name, Object)] -> m ig+throwBadTypeError msg o info = execThrow msg (ExecTypeError $ typeOfObj o) info++throwParseError :: MonadError ExecControl m => String -> Maybe UPath -> ParseError () DaoTT -> [(Name, Object)] -> m ig+throwParseError msg mod err info = throwError $+  newError+  { execErrorMessage  = ustr msg+  , execErrorInfo     = M.fromList info+  , execErrorLocation = parseErrLoc err+      -- -^ set the error location in the 'ExecControl' structure+  , execErrorSubtype  = ExecParseError $ err{ parseErrLoc = LocationUnknown }+      -- -^ delete the location to prevent it from being displayed twice+  , execErrorInModule = mod+  }++-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate+-- value. If the monadic function does fail, the 'Doa.Predicate.PFail' value will be updated with+-- the 'Dao.Token.Location' value retrieved by evaluating 'Dao.Token.getLocation' on the object+-- provided. If the evaluation failed and has already set an error location, the location is not+-- modified by this function, which guarantees the inner-most call to 'errLocation' will set the+-- location of the error.+errLocation :: (MonadError ExecControl m, HasLocation o) => o -> m a -> m a+errLocation o f = catchError f $ \err -> case err of+  ExecError{execErrorLocation=LocationUnknown} ->+    throwError $ err{execErrorLocation=getLocation o}+  err -> throwError err++-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate+-- value. If the monadic function does fail, the 'Doa.Predicate.PFail' value will be updated with+-- the given module name. If the evaluation failed and has already set an error module, the module+-- is not modified by this function, which guarantees the inner-most call to 'errModule' will set+-- the module of the error.+errModule :: MonadError ExecControl m => UPath -> m a -> m a+errModule path f = catchError f $ \err -> case err of+  ExecError{execErrorInModule=mod} -> throwError $ err{execErrorInModule=mplus mod (Just path)}+  err -> throwError err++-- | Like 'errModule' but sets the module reported by the error to be the current module of the+-- 'ExecUnit' if it is defined. If it is not defined, this function is equivalent to 'Prelude.id'.+errCurrentModule :: Exec a -> Exec a+errCurrentModule f = gets programModuleName >>= \mod -> maybe id errModule mod $ f++-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate+-- value. If the monadic function does fail, the 'execErrorInfo' field of the 'ExecError' value in+-- the 'Dao.Predicate.PFail' predicate will be updated with the field 'Name' and 'Object' value+-- provided here.+errInfo :: MonadError ExecControl m => Name -> Object -> m a -> m a+errInfo name o f = catchError f $ \err -> case err of+  ExecError{execErrorInfo=info} -> throwError $ err{execErrorInfo=M.insert name o info}+  err -> throwError err++-- | Evaluate an 'Exec', but if it throws an exception, set record an 'ObjectExpr' where+-- the exception occurred in the exception information.+updateExecErrorInfo :: Name -> Object -> Exec a -> Exec a+updateExecErrorInfo name o fn = catchError fn $ \err -> case err of+  ExecReturn{}                  -> throwError err+  ExecError{execErrorInfo=info} -> throwError $ err{ execErrorInfo = M.insert name o info }++-- | If an error has not been caught, log it in the module where it can be retrieved later. This+-- function only stores errors constructed with 'ExecError', the 'ExecReturn' constructed objects+-- are ignored.+logUncaughtErrors :: [ExecControl] -> Exec ()+logUncaughtErrors errs = modify $ \xunit ->+  xunit{ uncaughtErrors = uncaughtErrors xunit +++    (errs >>= \e -> case e of { ExecReturn{} -> []; ExecError{} -> [e]; }) }++-- | Clear the log of uncaught 'ExecError' values stored by 'logUncaughtErrors'.+clearUncaughtErrorLog :: Exec [ExecControl]+clearUncaughtErrorLog = do+  errs <- gets uncaughtErrors+  modify $ \xunit -> xunit{ uncaughtErrors = [] }+  return errs++----------------------------------------------------------------------------------------------------++data ExecErrorSubtype+  = ExecErrorUntyped+  | ExecThrow         Object+    -- ^ thrown when evaluating a "throw" statement, that is 'Dao.Interpreter.AST.ReturnExpr'+  | ExecStructError   StructError -- ^ thrown by 'toDaoStruct' or 'fromDaoStruct'+  | ExecUndefinedRef  Reference   -- ^ signals reference lookup failed+  | ExecTypeError     ObjType     -- ^ catch-all exception thrown when wrong data type is used.+  | ExecUpdateOpError UpdateOp    -- ^ thrown when an update operator fails+  | ExecIOException   IOException -- ^ re-thrown when caught from the IO monad+  | ExecHaskellError  ErrorCall   -- ^ re-thrown when caught from the IO monad+  | ExecParseError    (ParseError () DaoTT)+  | ExecInfixOpError  ObjType InfixOp ObjType -- ^ thrown when an infix operator fails+  | ExecLoopCtrl      LoopCtrl+    -- ^ inspired by the Python language, break and continue loop control statements are exceptions.+  deriving (Eq, Typeable)++instance Show ExecErrorSubtype where { show=prettyShow }++instance ToDaoStructClass ExecErrorSubtype where+  toDaoStruct = ask >>= \o -> case o of+    ExecErrorUntyped    -> makeNullary "Error"+    ExecThrow         o -> renameConstructor "Exception"          $ "threw"     .= o+    ExecStructError   o -> innerToStruct o+    ExecUndefinedRef  o -> renameConstructor "UndefinedRef"       $ "reference" .= o+    ExecTypeError     o -> renameConstructor "TypeMismatch"       $ "usedType"  .= o+    ExecUpdateOpError o -> renameConstructor "UpdateOpError"      $ "operator"  .= o+    ExecIOException   o -> renameConstructor "HaskellIOException" $ "message"   .= obj (show o)+    ExecHaskellError  o -> renameConstructor "HaskellError"       $ "message"   .= obj (show o)+    ExecParseError    o -> innerToStruct o+    ExecInfixOpError  a o b -> renameConstructor "InfixOpError" $+      "operator" .= o >> "left" .= a >> "right" .= b+    ExecLoopCtrl      o -> innerToStruct o++instance PPrintable ExecErrorSubtype where+  pPrint o = case o of+    ExecErrorUntyped    -> return ()+    ExecThrow         o -> pString "threw exception " >> pPrint o+    ExecStructError   o -> pPrint o+    ExecUndefinedRef  o -> pString "undefined reference " >> pPrint o+    ExecTypeError     o -> pString "cannot use value of type " >> pPrint o+    ExecUpdateOpError o -> pString "cannot apply update with operator " >> pPrint o+    ExecIOException   o -> pString (show o)+    ExecHaskellError  o -> pString (show o)+    ExecParseError    o -> pPrint o+    ExecInfixOpError  a o b -> do+      pString "incompatible types on either side of operator " >> pPrint o+      pIndent $ do+        pEndLine >> pString "left-hand side of operator is value of type: "  >> pPrint a+        pEndLine >> pString "right-hand side of operator is value of type: " >> pPrint b+    ExecLoopCtrl      o -> pPrint o++instance ObjectClass ExecErrorSubtype where { obj=new; fromObj=objFromHata; }++instance HataClass ExecErrorSubtype where+  haskellDataInterface = interface "ErrorSubtype" $ do+    autoDefEquality >> autoDefPPrinter >> autoDefToStruct++----------------------------------------------------------------------------------------------------++data LoopCtrl+  = LoopCtrl+    { loopCtrlEscaped  :: Bool+      -- ^ Has this exception gone past a function call context boundary?+    , loopCtrlContinue :: Bool+      -- ^ Is this control expression a continue statement? (if not it is a break statement)+    }+  deriving (Eq, Typeable)++loopCtrl :: Bool -> LoopCtrl+loopCtrl contin = LoopCtrl{ loopCtrlEscaped=False, loopCtrlContinue=contin }++instance PPrintable LoopCtrl where  +  pPrint ctrl = pString $ concat $+    [ if loopCtrlContinue ctrl then "continue" else "break"+    , " statement evaluated is not within a loop"+    ]++instance ToDaoStructClass LoopCtrl where+  toDaoStruct = renameConstructor "LoopCtrl" $ "isContinue" .=@ loopCtrlContinue++catchLoopCtrl :: Exec a -> (Bool -> Exec a) -> Exec a+catchLoopCtrl try catch = catchError try $ \err -> case err of+  ExecError{ execErrorSubtype =+    ExecLoopCtrl (LoopCtrl{ loopCtrlEscaped=False, loopCtrlContinue=contin }) } -> catch contin+  _ -> throwError err++-- | When defining an iterator, you should catch break and continue statements. This function is a+-- replacement for 'Control.Monad.forM' that handles break and continue statements correctly.+execForM :: [o] -> (o -> Exec a) -> Exec [a]+execForM ox f = loop ox [] where+  loop ox rev = case ox of+    []   -> return rev+    o:ox -> do+      (contin, r) <- catchLoopCtrl ((,) True . return <$> f o) (return . flip (,) [])+      (if contin then loop ox else return) (rev++r)++-- | Like 'execForM' but ignores the values returned by the iterating function.+execForM_ :: [o] -> (o -> Exec a) -> Exec ()+execForM_ ox f = loop ox where+  loop ox = case ox of+    []   -> return ()+    o:ox -> catchLoopCtrl (void $ f o) (flip when (loop ox))++----------------------------------------------------------------------------------------------------++-- | All evaluation of the Dao language takes place in the 'Exec' monad. It instantiates+-- 'Control.Monad.MonadIO.MonadIO' to allow @IO@ functions to be lifeted into it. It instantiates+-- 'Control.Monad.Error.MonadError' and provides it's own exception handling mechanism completely+-- different from the Haskell runtime, so as to allow for more control over exception handling in+-- the Dao runtime.+newtype Exec a  = Exec{ execToPredicate :: PredicateT ExecControl (StateT ExecUnit IO) a }+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO)++instance MonadState ExecUnit Exec where { state = Exec . lift . state }++instance MonadError ExecControl Exec where+  throwError = Exec . throwError+  catchError (Exec try) catch = Exec (catchError try (execToPredicate . catch))++instance MonadPlusError ExecControl Exec where+  catchPredicate (Exec f) = Exec (catchPredicate f)+  predicate = Exec . predicate++----------------------------------------------------------------------------------------------------++-- | The 'XPure' type is like 'Exec' but does not lift IO or contain any reference to any+-- 'ExecUnit', so it is guaranteed to work without side-effects, but it also instantiates the+-- 'Control.Monad.MonadPlus', 'Control.Applicative.Alternative', 'Control.Monad.Error.MonadError'+-- and 'Dao.Predicate.MonadPlusError' classes so you can do computation with backtracking and+-- exceptions. Although this monad evaluates to a pure function, it does have stateful data: a+-- 'Dao.String.UStr' that will call a "print stream", which is provided for general purpose; a place+-- to print information throughout evaluation like a "print()" statement.  The 'xnote' function+-- serves as the "print()" function for this monad. Use the ordinary 'Control.Monad.State.get' and+-- 'Control.Monad.State.modify' APIs for working with the print stream data.+-- +-- You can also evaluate an 'XPure' monad within an 'Exec' monad by simply using the 'execute'+-- function. This will automatically convert the internal 'Dao.Predicate.Predicate' of the 'XPure'+-- monad to the 'Dao.Predicate.Predicate' of the 'Exec' monad, meaning if you 'execute' an 'XPure'+-- monad that backtracks or throws an error, the 'Exec' monad will backtrack or throw the same+-- error.+newtype XPure a = XPure { xpureToState :: PredicateT ExecControl (State UStr) a }+  deriving (Functor, Applicative, Alternative, MonadPlus)++instance Show a => Show (XPure a) where+  show (XPure p) = case evalState (runPredicateT p) nil of+    Backtrack -> "(BACKTRACK)"+    PFail err -> "(PFAIL "++prettyShow err++")"+    OK     o  -> "(OK "++show o++")"++instance Monad XPure where+  return = XPure . return+  (XPure a) >>= f = XPure $ a >>= xpureToState . f+  fail msg = execThrow msg ExecErrorUntyped []++-- | Convert a value wrapped in an XPure monad to a pair containing the internal state 'Dao.String.UStr' and+-- 'Dao.Predicate.Predicate' value.+runXPure :: XPure a -> (Predicate ExecControl a, UStr)+runXPure = flip runState nil . runPredicateT . xpureToState++-- | Like 'Control.Monad.State.evalState', but works on the 'XPure' monad, i.e. it is defined as+-- > 'Prelude.fst' . 'runXPure'+evalXPure :: XPure a -> Predicate ExecControl a+evalXPure = fst . runXPure++-- | Like 'evalXPure' but evaluates to 'Prelude.Maybe' instead of a 'Dao.Predicate.Predicate'.+-- 'Dao.Predicate.Backtrack' and 'Dao.Predicate.PFail' both map to 'Prelude.Nothing',+-- 'Dao.Predicate.OK' maps to 'Prelude.Just'.+extractXPure :: XPure a -> Maybe a+extractXPure = okToJust . evalXPure++instance MonadError ExecControl XPure where+  throwError = XPure . throwError+  catchError (XPure f) catch = XPure $ catchError f (xpureToState . catch)++instance MonadPlusError ExecControl XPure where+  predicate = XPure . predicate+  catchPredicate (XPure f) = XPure $ catchPredicate f++instance MonadState UStr XPure where { state = XPure . lift . state }++instance Executable (XPure a) a where+  execute (XPure f) = predicate $ evalState (runPredicateT f) mempty++-- | Like 'Control.Applicative.pure' or 'Control.Monad.return' but the type is not polymorphic so+-- there is no need to annotate the monad to which you are 'Control.Monad.return'ing, which is+-- helpful when using functions like 'exceute' to convert the 'XPure' monad to the 'Exec' monad.+xpure :: a -> XPure a+xpure = pure++-- | Like 'xpure' but wraps any data type that instantiates the 'ObjectClass' class.+xobj :: ObjectClass a => a -> XPure Object+xobj = xpure . obj++-- | Append a string of any 'UStrType' to the general-purpose print stream contained within the+-- 'XPure' monad.+xnote :: UStrType s => s -> XPure ()+xnote = modify . flip mappend . toUStr++-- | Like 'xnote' but lets you operate on the 'Data.ByteString.Lazy.UTF8.ByteString'.+xonUTF8 :: (U.ByteString -> U.ByteString) -> XPure ()+xonUTF8 = modify . fmapUTF8String++-- | Works on any 'Control.Monad.MonadPlus' type, including 'Prelude.Maybe', 'Exec' and 'XPure', is+-- defined as: > 'Prelude.maybe' 'Control.Monad.mzero' 'Control.Monad.return' which is useful+-- shorthand for converting a value wrapped in a 'Prelude.Maybe' data type to a value wrapped in the+-- 'Control.Monad.MonadPlus' type.+xmaybe :: MonadPlus m => Maybe a -> m a+xmaybe = maybe mzero return++----------------------------------------------------------------------------------------------------++class ExecThrowable o where+  toExecErrorInfo :: o -> ExecErrorSubtype+  -- | Like 'Prelude.error' but works for the 'Exec' monad, throws an 'ExecControl' using+  -- 'Control.Monad.Error.throwError' constructed using the given 'Object' value as the+  -- 'execReturnValue'.+  execThrow+    :: (Monad m, MonadError ExecControl m, ExecThrowable o, UStrType msg)+    => msg -> o -> [(Name, Object)] -> m ig+  execThrow msg o info = throwError $+    newError+    { execErrorMessage  = toUStr msg+    , execErrorSubtype  = toExecErrorInfo o+    , execErrorInfo     = M.fromList info+    }++instance ExecThrowable ExecErrorSubtype      where { toExecErrorInfo = id                }+instance ExecThrowable Object                where { toExecErrorInfo = ExecThrow         }+instance ExecThrowable StructError           where { toExecErrorInfo = ExecStructError   }+instance ExecThrowable Reference             where { toExecErrorInfo = ExecUndefinedRef  }+instance ExecThrowable IOException           where { toExecErrorInfo = ExecIOException   }+instance ExecThrowable ErrorCall             where { toExecErrorInfo = ExecHaskellError  }+instance ExecThrowable UpdateOp              where { toExecErrorInfo = ExecUpdateOpError }+instance ExecThrowable (ParseError () DaoTT) where { toExecErrorInfo = ExecParseError    }+instance ExecThrowable LoopCtrl              where { toExecErrorInfo = ExecLoopCtrl      }++ioExec :: Exec a -> ExecUnit -> IO (Predicate ExecControl a, ExecUnit)+ioExec func xunit = runStateT (runPredicateT (execToPredicate func)) xunit++----------------------------------------------------------------------------------------------------++-- | This is the data type analogous to the 'Exec' monad what 'Control.Exception.Handler' is to the+-- @IO@ monad.+newtype ExecHandler a =+  ExecHandler { execHandler :: ExecUnit -> Handler (Predicate ExecControl a, ExecUnit) }++instance Functor ExecHandler where+  fmap f (ExecHandler h) = ExecHandler (fmap (fmap (\ (p, xunit) -> (fmap f p, xunit))) h)++-- | Create an 'ExecHandler'.+newExecIOHandler :: Exception e => (e -> Exec a) -> ExecHandler a+newExecIOHandler h = ExecHandler (\xunit -> Handler (\e -> ioExec (h e) xunit))++-- | Using an 'ExecHandler' like 'execIOHandler', catch any exceptions thrown by the Haskell+-- language runtime and wrap them up in the 'Exec' monad.+execCatchIO :: Exec a -> [ExecHandler a] -> Exec a+execCatchIO tryFunc handlers = Exec $ PredicateT $ StateT $ \xunit ->+  liftIO $ catches (ioExec tryFunc xunit) (fmap (\h -> execHandler h xunit) handlers)++-- | Like 'execCatchIO' but with the arguments 'Prelude.flip'ped.+execHandleIO :: [ExecHandler a] -> Exec a -> Exec a+execHandleIO = flip execCatchIO++-- | An 'ExecHandler' for catching 'Control.Exception.ErrorCall's and re-throwing them to the+-- 'Procedural' monad using 'Control.Monad.Error.throwError', allowing the exception to be caught+-- and handled by Dao script code.+execIOHandler :: ExecHandler ()+execIOHandler = newExecIOHandler $ flip (execThrow "") [] . ExecIOException++-- | An 'ExecHandler' for catching 'Control.Exception.ErrorCall's and re-throwing them to the+-- 'Procedural' monad using 'Control.Monad.Error.throwError', allowing the exception to be caught+-- and handled by Dao script code.+execErrorHandler :: ExecHandler ()+execErrorHandler = newExecIOHandler $ flip (execThrow "") [] . ExecHaskellError++-- | This will catch an 'ExecControl' thrown by 'Control.Monad.Error.throwError', but re-throw+-- 'ExecError's.+catchReturn :: (Maybe Object -> Exec a) -> Exec a -> Exec a+catchReturn catch f = catchPredicate f >>= \pval -> case pval of+  PFail (ExecReturn a) -> catch a+  pval                 -> predicate pval++----------------------------------------------------------------------------------------------------+-- $StackOperations+-- Operating on the local stack.++-- | Push a new empty local-variable context onto the stack. Does NOT 'catchReturnObj', so it can be+-- used to push a new context for every level of nested if/else/for/try/catch statement, or to+-- evaluate a macro, but not a function call. Use 'execFuncPushStack' to perform a function call within+-- a function call. The stack is always poped when this function is done evaluating, even if the+-- given 'Exec' function evaluates to 'Control.Monad.mzero' or 'Control.Monad.Error.throwError'.+execNested :: T_dict -> Exec a -> Exec (a, T_dict)+execNested init exe = do+  store <- gets execStack+  modify $ \xunit -> xunit{ execStack = stackPush init store }+  result <- catchPredicate exe+  store <- gets execStack+  (store, dict) <- pure (stackPop store)+  modify $ \xunit -> xunit{ execStack = store }+  result <- predicate result+  return (result, dict)++-- | Like 'execNested' but immediately disgards the local variables when the inner 'Exec' function+-- has completed evaluation.+execNested_ :: T_dict -> Exec a -> Exec a+execNested_ init = fmap fst . execNested init++-- | Keep the current 'execStack', but replace it with a new empty stack before executing the given+-- function. This function is different from 'nestedExecStak' in that it acually removes the current+-- execution stack so a function call cannot modify the local variables of the function which called+-- it. Furthermore it catches evaluation of a "return" statement allowing the function which called+-- it to procede with execution after this call has returned.+execFuncPushStack :: T_dict -> Exec (Maybe Object) -> Exec (Maybe Object, T_dict)+execFuncPushStack dict exe = execNested dict (catchPredicate exe) >>= \ (pval, dict) -> case pval of+  OK     o  -> return (o, dict)+  Backtrack -> mzero+  PFail err -> case err of+    ExecReturn o -> return (o, dict)+    ExecError{execErrorSubtype=ExecLoopCtrl ctrl} -> throwError $+      err{execErrorSubtype=ExecLoopCtrl $ ctrl{loopCtrlEscaped=False}}+    err          -> throwError err++execFuncPushStack_ :: T_dict -> Exec (Maybe Object) -> Exec (Maybe Object)+execFuncPushStack_ dict = fmap fst . execFuncPushStack dict++execWithStaticStore :: Subroutine -> Exec a -> Exec a+execWithStaticStore sub exe = do+  store <- gets currentCodeBlock+  modify (\st -> st{ currentCodeBlock=Just sub })+  result <- catchPredicate exe+  modify (\st -> st{ currentCodeBlock=store })+  predicate result++execWithWithRefStore :: Object -> Exec a -> Exec a+execWithWithRefStore o exe = do+  store <- gets currentWithRef+  modify (\st -> st{ currentWithRef=Just o })+  result <- catchPredicate exe+  modify (\st -> st{ currentWithRef=store })+  predicate result++withExecTokenizer :: ExecTokenizer -> Exec a -> Exec a+withExecTokenizer newtokzer f = do+  oldtokzer <- gets programTokenizer+  modify $ \xunit -> xunit{ programTokenizer=newtokzer }+  p <- catchPredicate f+  modify $ \xunit -> xunit{ programTokenizer=oldtokzer }+  predicate p++----------------------------------------------------------------------------------------------------++instance (Typeable a, ObjectClass a) => ToDaoStructClass (Com a) where+  toDaoStruct = renameConstructor "Com" $ do+    co <- ask+    let put o = "com" .= obj o+    case co of+      Com          o    ->                   put o >> return ()+      ComBefore c1 o    -> "before" .= c1 >> put o >> return ()+      ComAfter     o c2 ->                   put o >> "after" .= c2 >> return ()+      ComAround c1 o c2 -> "before" .= c1 >> put o >> "after" .= c2 >> return ()++instance (Typeable a, ObjectClass a) => FromDaoStructClass (Com a) where+  fromDaoStruct = do+    constructor "Com"+    let f name = tryField name (maybe (fail name) return . fromObj)+    before <- optional $ f "before"+    after  <- optional $ f "after"+    o      <- req "com"+    return $ maybe (Com o) id $ msum $+      [ return ComAround <*> before <*> pure o <*> after+      , return ComBefore <*> before <*> pure o+      , return ComAfter  <*> pure o <*> after+      ]++instance (Typeable a, ObjectClass a) =>+  ObjectClass (Com a) where { obj=new; fromObj=objFromHata; }+instance (Typeable a, ObjectClass a) => HataClass (Com a) where+  haskellDataInterface = interface "Com" $ do+    autoDefToStruct >> autoDefFromStruct++instance (Typeable a, ObjectClass a) =>+  ObjectClass [Com a] where { obj=listToObj; fromObj=listFromObj; }++----------------------------------------------------------------------------------------------------++setupCodeBlock :: CodeBlock Object -> Subroutine+setupCodeBlock scrp =+  Subroutine+  { origSourceCode = scrp+  , staticVars     = mempty+  , staticRules    = mempty+  , staticLambdas  = []+  , executable     = execute scrp >> return Nothing+  }++-- binary 0xDD +instance B.Binary (CodeBlock Object) MTab where+  put (CodeBlock o) = B.prefixByte 0xDD $ B.put o+  get = B.tryWord8 0xDD $ CodeBlock <$> B.get++instance Executable (CodeBlock Object) () where { execute (CodeBlock ox) = mapM_ execute ox }++instance ObjectClass (CodeBlock Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (CodeBlock Object) where+  haskellDataInterface = interface "CodeBlock" $ do+    autoDefNullTest >> autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter+    defDeref $ \o -> catchError (execute o >> return Nothing) $ \e -> case e of+      ExecReturn o -> return o+      ExecError{}  -> throwError e+    -- TODO: define autoDefIterator, defIndexer, autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- | A subroutine is contains a 'CodeBlock' and an 'Data.IORef.IORef' to it's own static data. It+-- also has a reference to the last evaluation of 'execute' over it's 'CodeBlock', which provides a+-- hint to the Haskell runtime system that this code can be cached rather than evaluating the+-- 'CodeBlock' fresh every time. In a sense, it is a "live" 'CodeBlock' that can actually be+-- executed.+data Subroutine+  = Subroutine+    { origSourceCode :: CodeBlock Object+    , staticVars     :: T_dict+    , staticRules    :: PatternTree Object [Subroutine]+    , staticLambdas  :: [CallableCode]+    , executable     :: Exec (Maybe Object)+    }+  deriving Typeable++instance Eq Subroutine where { a==b = origSourceCode a == origSourceCode b }++instance Ord Subroutine where { compare a b = compare (origSourceCode a) (origSourceCode b) }++instance Show Subroutine where { show o = "Subroutine "++show (codeBlock (origSourceCode o)) }++instance NFData Subroutine where { rnf (Subroutine a _ _ _ _) = deepseq a () }++instance HasNullValue Subroutine where+  nullValue =+    Subroutine+    { origSourceCode = nullValue+    , staticVars     = mempty+    , staticRules    = mempty+    , staticLambdas  = []+    , executable     = return Nothing+    }+  testNull (Subroutine a _ _ _ _) = testNull a++instance PPrintable Subroutine where+  pPrint = pPrint . flip MetaEvalExpr LocationUnknown . origSourceCode++instance ToDaoStructClass Subroutine where+  toDaoStruct = renameConstructor "Subroutine" $ do+    "code"    .=@ origSourceCode+    "vars"    .=@ staticVars+    "rules"   .=@ (\rs -> RuleSet{ ruleSetRules=rs, ruleSetTokenizer=Nothing }) . staticRules+    "lambdas" .=@ staticLambdas++instance FromDaoStructClass Subroutine where+  fromDaoStruct = do+    constructor "Subroutine"+    sub <- setupCodeBlock <$> req "code"+    vars <- req "vars"+    (RuleSet{ ruleSetRules=rules }) <- req "rules"+    lambdas <- req "lambdas"+    return $ sub{ staticVars=vars, staticRules=rules, staticLambdas=lambdas }++instance Executable Subroutine (Maybe Object) where+  execute sub = execWithStaticStore sub $+    catchReturn return ((execute (origSourceCode sub) :: Exec ()) >> return Nothing) :: Exec (Maybe Object)++instance ObjectClass Subroutine where { obj=new; fromObj=objFromHata; }++instance HataClass Subroutine where+  haskellDataInterface = interface "Subroutine" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++-- | Although 'Subroutine' instantiates 'Executable', this function allows you to easily place a+-- group of defined local variables onto the call stack before and the have the 'Subroutine'+-- executed.+runCodeBlock :: T_dict -> Subroutine -> Exec (Maybe Object, T_dict)+runCodeBlock initStack sub = execWithStaticStore sub $+  execFuncPushStack initStack (executable sub >>= liftIO . evaluate)++runCodeBlock_ :: T_dict -> Subroutine -> Exec (Maybe Object)+runCodeBlock_ initStack = fmap fst . runCodeBlock initStack++----------------------------------------------------------------------------------------------------++data RuleSet+  = RuleSet+    { ruleSetRules     :: PatternTree Object [Subroutine]+    , ruleSetTokenizer :: Maybe ExecTokenizer+    }+  deriving Typeable++instance HasNullValue RuleSet where+  nullValue = RuleSet{ ruleSetRules=nullValue, ruleSetTokenizer=Nothing }+  testNull (RuleSet{ruleSetRules=r, ruleSetTokenizer=tok}) =+    testNull r && maybe True (const False) tok++instance Monoid RuleSet where+  mempty = nullValue+  mappend (RuleSet{ruleSetRules=a, ruleSetTokenizer=tokA}) (RuleSet{ruleSetRules=b, ruleSetTokenizer=tokB}) =+    RuleSet{ ruleSetRules=mappend a b, ruleSetTokenizer=mplus tokA tokB }++instance Sizeable RuleSet where { getSizeOf = return . obj . T.size . ruleSetRules }++instance PPrintable RuleSet where+  pPrint (RuleSet{ ruleSetRules=tree }) = pList (pString "RuleSet") "{ " ", " "}" $+    T.assocs tree >>= \ (ix, subs) -> do+      let rule ix = case ix of+            []                      -> ""+            Single (OString s) : ix -> uchars s ++ rule ix+            Single o           : ix -> prettyShow o ++ rule ix+            i                  : ix -> show i ++ rule ix+      sub <- subs+      [ pClosure (pString "rule " >> pShow (rule ix)) "{" "}" $+          map pPrint $ codeBlock $ origSourceCode sub ]++instance ObjectClass RuleSet where { obj=new ; fromObj=objFromHata; }++instance HataClass RuleSet where+  haskellDataInterface = interface "RuleSet" $ do+    autoDefNullTest >> autoDefSizeable >> autoDefPPrinter+    let qrefRuleSet = reference UNQUAL (ustr "RuleSet")+    let initParams ox = case ox of+          []  -> return $ RuleSet{ ruleSetRules=mempty, ruleSetTokenizer=Nothing }+          [o] -> do+            let err :: Exec RuleSet+                err = throwBadTypeError "" o [(errInConstr, obj qrefRuleSet)]+            maybe err return $ do+              fromObj o >>= \ (Hata ifc _) -> objCallable ifc+              let tok = ExecTokenizer $ \ox -> do+                    toks <- fst <$> callObject (RefObject o NullRef) o [obj ox]+                    mplus (xmaybe $ toks >>= fromObj) $+                      execThrow "tokenizer for rule function did not return a list of objects" ExecErrorUntyped []+              return $ RuleSet{ ruleSetRules=mempty, ruleSetTokenizer=Just tok }+          _  -> throwArityError "" 1 ox [(errInInitzr, obj qrefRuleSet)]+          -- TODO: ^ the constructor for a 'PatternTree' should take tokenizer function.+    let listParams tree =+          foldM (\ rs@(RuleSet{ruleSetRules=tree, ruleSetTokenizer=maybeTok}) (i, o) -> case o of+            InitSingle o -> case fromObj o >>= \ (Hata _ d) -> fromDynamic d of+              Nothing -> throwBadTypeError "expecting rule or RuleSet" o $+                [(errInFunc, obj qrefRuleSet), (errInConstr, OInt i)]+              Just  p -> do+                newtree <- maybe id withExecTokenizer maybeTok $ execute (p::PatternRule)+                return $ rs{ ruleSetRules=T.unionWith (++) tree newtree }+            InitAssign{} -> fail "cannot use assignment expression in initializer of RuleSet"+                ) tree . zip [1..]+    defInitializer initParams listParams+    defInfixOp ORB $ \ _ rs o -> fmap (obj . mappend rs) $ mplus (xmaybe $ fromObj o) $+      (throwBadTypeError "when uninioning RuleSet values" o [])+    let run f =+          daoFunc+          { daoForeignFunc = \rs ->+              runTokenizer >=> makeActionsForQuery [ruleSetRules rs] >=> fmap (flip (,) rs) . f+          }+    defMethod "query" $ run $ return . Just . obj . fmap obj+    defMethod "do"    $ run $ msum . fmap execute+    defMethod "doAll" $ run $ fmap (Just . obj . fmap obj) . execute+    defMethod "tokenize" $+      daoFunc+      { daoForeignFunc = \rs -> fmap (flip (,) rs . Just . obj) .+          maybe runTokenizer runTokenizerWith (ruleSetTokenizer rs)+      }++----------------------------------------------------------------------------------------------------++-- | A subroutine is specifically a callable function (but we don't use the name Function to avoid+-- confusion with Haskell's "Data.Function"). +data CallableCode+  = CallableCode+    { argsPattern    :: ParamListExpr Object+    , returnType     :: ObjType+    , codeSubroutine :: Subroutine+    }+  deriving (Show, Typeable)++-- Used by the instantiation of CallableCode and PatternRule into the PPrintable class.+ppCallableAction :: String -> PPrint -> ObjType -> Subroutine -> PPrint+ppCallableAction what pats typ exe =+  pClosure (pString what >> pats >> pPrint typ) "{" "}" (map pPrint (codeBlock (origSourceCode exe)))++-- | Interface used during evaluation of Dao scripts to determine whether or not an if or while+-- statement should continue. Also, turns out to be handy for plenty of other reasons.+instance HasNullValue CallableCode where+  nullValue =+    CallableCode{argsPattern=nullValue, returnType=nullValue, codeSubroutine=nullValue}+  testNull (CallableCode a b c) = testNull a && testNull b && testNull c++instance NFData CallableCode  where { rnf (CallableCode  a b _) = deepseq a $! deepseq b () }++instance PPrintable [CallableCode] where +  pPrint = sequence_ . intersperse (pString " ^ ") .+    fmap (\ (CallableCode pats ty exe) -> ppCallableAction "function" (pPrint pats) ty exe >> pEndLine)++instance ObjectClass [CallableCode] where { obj=new; fromObj=objFromHata; }++instance HataClass [CallableCode] where+  haskellDataInterface = interface "Function" $ do+    autoDefNullTest >> autoDefPPrinter+    defCallable return+    defInfixOp XORB $ \ _ a o -> case fromObj o of+      Just  b -> return $ obj (a++b)+      Nothing -> fail "left-hand side of bitwise-XOR operator (^) is a Function, right hand side is not"++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_CodeBlock Object) where+  toDaoStruct = renameConstructor "CodeBlock" $ "list" .=@ getAST_CodeBlock++instance FromDaoStructClass (AST_CodeBlock Object) where+  fromDaoStruct = constructor "CodeBlock" >> AST_CodeBlock <$> req "list"++instance ObjectClass (AST_CodeBlock Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_CodeBlock Object) where+  haskellDataInterface = interface "CodeBlockExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0xC5 0xC7+instance B.Binary a MTab => B.Binary (TyChkExpr a Object) MTab where+  put o = case o of+    NotTypeChecked a       -> B.prefixByte 0xC5 $ B.put a+    TypeChecked    a b c   -> B.prefixByte 0xC6 $ B.put a >> B.put b >> B.put c+    DisableCheck   a b c d -> B.prefixByte 0xC7 $ B.put a >> B.put b >> B.put c >> B.put d+  get = B.word8PrefixTable <|> fail "expecting TyChkExpr"++instance B.Binary a MTab => B.HasPrefixTable (TyChkExpr a Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "TyChkExpr" 0xC5 0xC7 $+    [ NotTypeChecked <$> B.get+    , return TypeChecked  <*> B.get <*> B.get <*> B.get+    , return DisableCheck <*> B.get <*> B.get <*> B.get <*> B.get+    ]++instance (Eq a, Ord a, Typeable a, ObjectClass a) =>+  ObjectClass (TyChkExpr Object a) where { obj=new; fromObj=objFromHata; }++instance (Eq a, Ord a, Typeable a, ObjectClass a) =>+  HataClass (TyChkExpr Object a) where+    haskellDataInterface = interface "TypedExec" $ do+      autoDefEquality >> autoDefOrdering++----------------------------------------------------------------------------------------------------++instance ObjectClass a => ToDaoStructClass (AST_TyChk a Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_NotChecked o              -> renameConstructor "UntypedExpression" $ "expr" .= obj o+    AST_Checked    o coms typ loc -> renameConstructor "TypedExpression" $ do+      "expr"     .= obj o+      "colon"    .= coms+      "typeExpr" .= typ+      putLocation loc++instance (Typeable a, ObjectClass a) => FromDaoStructClass (AST_TyChk a Object) where+  fromDaoStruct = msum $+    [do constructor "UntypedExpression"+        AST_NotChecked <$> req "expr"+    ,do constructor "TypedExpression"+        return AST_Checked <*> req "expr" <*> req "colon" <*> req "typeExpr" <*> location+    ]++instance (Eq a, Ord a, PPrintable a, Typeable a, ObjectClass a) =>+  ObjectClass (AST_TyChk a Object) where { obj=new; fromObj=objFromHata; }++instance (Eq a, Ord a, PPrintable a, Typeable a) => HataClass (AST_TyChk a Object) where+  haskellDataInterface = interface "TypedExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    -- autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0xCF 0xD0+instance B.Binary (ParamExpr Object) MTab where+  put (ParamExpr True  a b) = B.prefixByte 0xCF $ B.put a >> B.put b+  put (ParamExpr False a b) = B.prefixByte 0xD0 $ B.put a >> B.put b+  get = B.word8PrefixTable <|> fail "expecting ParamExpr"++instance B.HasPrefixTable (ParamExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "ParamExpr" 0xCF 0xD0 $+    [ return (ParamExpr True ) <*> B.get <*> B.get+    , return (ParamExpr False) <*> B.get <*> B.get+    ]++instance ObjectClass (ParamExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ParamExpr Object) where+  haskellDataInterface = interface "ParamExpr" $ do+    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Param Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_NoParams             -> makeNullary "NoParameters"+    AST_Param coms tychk loc -> renameConstructor "Parameter" $ do+      maybe (return ()) putComments coms+      "typeCheck" .= tychk+      putLocation loc++instance FromDaoStructClass (AST_Param Object) where+  fromDaoStruct = msum $+    [ nullary "NoParameters" >> return AST_NoParams+    , constructor "Parameter" >> return AST_Param <*> optComments <*> req "typeCheck" <*> location+    ]++instance ObjectClass (AST_Param Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Param Object) where+  haskellDataInterface = interface "ParameterExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0xD6 +instance B.Binary (ParamListExpr Object) MTab where+  put (ParamListExpr tyChk loc) = B.prefixByte 0xD6 $ B.put tyChk >> B.put loc+  get = B.word8PrefixTable <|> fail "expecting ParamListExpr"++instance B.HasPrefixTable (ParamListExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "ParamListExpr" 0xD6 0xD6 $+    [return ParamListExpr <*> B.get <*> B.get]++instance ObjectClass (ParamListExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ParamListExpr Object) where+  haskellDataInterface = interface "ParameterList" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_ParamList Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_ParamList tychk loc -> renameConstructor "ParamList" $ do+      "typeCheck" .= tychk+      putLocation loc++instance FromDaoStructClass (AST_ParamList Object) where+  fromDaoStruct = constructor "ParamList" >> return AST_ParamList <*> req "typeCheck" <*> location++instance ObjectClass (AST_ParamList Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_ParamList Object) where+  haskellDataInterface = interface "ParameterListExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x7A 0x7B+instance B.Binary (RuleHeadExpr Object) MTab where+  put o = case o of+    RuleStringExpr a b -> B.prefixByte 0x7A $ B.put a >> B.put b+    RuleHeadExpr   a b -> B.prefixByte 0x7B $ B.put a >> B.put b+  get = B.word8PrefixTable <|> fail "expecting RuleHeadExpr"++instance B.HasPrefixTable (RuleHeadExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "RuleHeadExpr" 0x7A 0x7B+    [ return RuleStringExpr <*> B.get <*> B.get+    , return RuleHeadExpr   <*> B.get <*> B.get+    ]++instance Executable (RuleHeadExpr Object) [Object] where+  execute o = case o of+    RuleStringExpr r _ -> return [obj r]+    RuleHeadExpr   r _ -> forM r $+      execute . DerefAssignExpr >=> checkVoid (getLocation o) "item in rule header"++instance ObjectClass (RuleHeadExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (RuleHeadExpr Object) where+  haskellDataInterface = interface "RuleHeader" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_RuleHeader Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_NullRules coms loc -> renameConstructor "NoStrings" $ do+      putComments coms >> putLocation loc+    AST_RuleString itm loc -> renameConstructor "StringItem" $ do+      "items" .= itm >> putLocation loc+    AST_RuleHeader lst loc -> renameConstructor "ValuesList" $ do+      "items" .= lst >> putLocation loc++instance FromDaoStructClass (AST_RuleHeader Object) where+  fromDaoStruct = msum $+    [ constructor "NoStrings"  >> return AST_NullRules  <*> comments <*> location+    , constructor "StringItem" >> return AST_RuleString <*> req "items" <*> location+    , constructor "ValuesList" >> return AST_RuleHeader <*> reqList "items" <*> location+    ]++instance ObjectClass (AST_RuleHeader Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_RuleHeader Object) where+  haskellDataInterface = interface "RuleHeaderExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- $Exec_helpers+-- Functions for working with object values when building built-in functions callable from within a+-- dao script.++asReference :: Object -> XPure Reference+asReference = xmaybe . fromObj++_getRuleSetParam :: [Object] -> Exec (Maybe RuleSet, [Object])+_getRuleSetParam ox = return $ case ox of+  []   -> (Nothing, [])+  o:ox -> maybe ((Nothing, o:ox)) (\o -> (Just o, ox)) (fromObj o)++-- Checks the list of parameters, and if there are more than one, checks if the first parameter is+-- an 'OHaskell' object which can be converted to 'CallableCode' using 'objToCallable'. If so, the+-- callables are returned and the results of pattern matching can be used as parameters to these+-- functions.+_getFuncStringParams :: [Object] -> Exec (Maybe [CallableCode], [UStr])+_getFuncStringParams ox = case ox of+  []   -> fail "no parameters passed to function"+  [o]  -> (,) Nothing <$> oneOrMoreStrings [o]+  o:lst -> do+    calls <- (Just <$> objToCallable o) <|> return Nothing+    (,) calls <$> oneOrMoreStrings lst+  where+    oneOrMoreStrings ox = case concatMap extractStringElems ox of+      [] -> fail "parameter arguments contain no string values"+      ox -> return ox++asInteger :: Object -> XPure Integer+asInteger o = case o of+  OWord    o -> return (toInteger o)+  OInt     o -> return (toInteger o)+  OLong    o -> return o+  OFloat   o -> return (round o)+  ORatio   o -> return (round o)+  ORelTime o -> return (round (toRational o))+  _          -> mzero++asRational :: Object -> XPure Rational+asRational o = case o of+  OInt     o -> return (toRational o)+  OWord    o -> return (toRational o)+  OLong    o -> return (toRational o)+  OFloat   o -> return (toRational o)+  ORelTime o -> return (toRational o)+  ORatio   o -> return o+  OComplex o | imagPart o == 0 -> return (toRational (realPart o))+  _          -> mzero++asComplex :: Object -> XPure T_complex+asComplex o = case o of+  OComplex o -> return o+  o          -> asRational o >>= return . flip complex 0 . fromRational++-- | A function which is basically the absolute value function, except it also works on 'Complex'+-- numbers, returning the magnitude of the number if it is 'Complex'.+asPositive :: Object -> XPure Object+asPositive o = case o of+  OInt     o -> return (OInt     $ abs       o)+  OWord    o -> return (OWord                o)+  OLong    o -> return (OLong    $ abs       o)+  OFloat   o -> return (OFloat   $ abs       o)+  ORelTime o -> return (ORelTime $ abs       o)+  OComplex o -> return (OFloat   $ magnitude o)+  _          -> mzero++-- | Remove one layer of 'OList' objects, i.e. any objects in the list that are 'OList' constructors+-- will have the contents of those lists concatenated, and all non-'OList' constructors are treated+-- as lists of single objects. Also returns the number of concatenations.+objConcat :: [Object] -> (Int, [Object])+objConcat ox = (sum a, concat b) where+  (a, b) = unzip (ox >>= \o -> maybe [(0, [o])] (return . (,) 1) (fromObj o))++-- | Checks if an 'Object' is a numerical type, returns the numeric 'CoreType' if so, evaluates to+-- 'Control.Monad.mzero' if not.+isNumeric :: Object -> XPure CoreType+isNumeric o = do+  let t = coreType o+  guard (CharType <= t && t <= ComplexType)+  return t++eval_Prefix_op :: ArithPfxOp -> Object -> XPure Object+eval_Prefix_op op o = join $ xmaybe $+  fromObj o >>= \ (Hata ifc o) -> objArithPfxOpTable ifc >>= (! op) >>= \f -> return (f op o)++-- Pass the 'InfixOp' associated with the 'Prelude.Num' function so it can check whether the+-- 'defInfixOp' for that operator has been defined for objects of 'HaskellType'.+eval_Infix_op :: InfixOp -> Object -> Object -> XPure Object+eval_Infix_op op a b = join $ xmaybe $ onhask a b <|> (guard isCommut >> onhask b a) where+  isCommut = infixOpCommutativity op+  onhask a b = fromObj a >>= \ (Hata ifc a) ->+    (\f -> f op a b) <$> (objInfixOpTable ifc >>= (! op))++_evalNumOp1 :: (forall a . Num a => a -> a) -> Object -> XPure Object+_evalNumOp1 f o = case o of+  OChar    o -> return $ OChar    $ chr $ mod (f $ ord o) (ord maxBound)+  OInt     o -> return $ OInt     $ f o+  OWord    o -> return $ OWord    $ f o+  OLong    o -> return $ OLong    $ f o+  ORelTime o -> return $ ORelTime $ f o+  OFloat   o -> return $ OFloat   $ f o+  ORatio   o -> return $ ORatio   $ f o+  OComplex o -> return $ OComplex $ f o+  _          -> mzero++-- Evaluate a 2-ary function for any core type that instantiates the 'Prelude.Num' class.+_evalNumOp2 :: (forall a . Num a => a -> a -> a) -> Object -> Object -> XPure Object+_evalNumOp2 f a b = do+  let t = max (coreType a) (coreType b)+  a <- castToCoreType t a+  b <- castToCoreType t b+  case (a, b) of+    (OChar     a, OChar     b) -> return $ OChar    $ chr $ mod (f (ord a) (ord b)) (ord maxBound)+    (OInt      a, OInt      b) -> return $ OInt     $ f a b+    (OWord     a, OWord     b) -> return $ OWord    $ f a b+    (OLong     a, OLong     b) -> return $ OLong    $ f a b+    (ORelTime  a, ORelTime  b) -> return $ ORelTime $ f a b+    (OFloat    a, OFloat    b) -> return $ OFloat   $ f a b+    (ORatio    a, ORatio    b) -> return $ ORatio   $ f a b+    (OComplex  a, OComplex  b) -> return $ OComplex $ f a b+    _ -> mzero++instance Num (XPure Object) where+  a + b = a >>= \a -> b >>= \b -> case (a, b) of+    (OString a, OString b) -> return $ OString $ a<>b+    (OBytes  a, OBytes  b) -> return $ OBytes  $ a<>b+    (OList   a, OList   b) -> return $ OList   $ a++b+    (ODict   a, ODict   b) -> return $ ODict   $ M.union b a+    (a, b) -> _evalNumOp2 (+) a b <|> eval_Infix_op ADD a b+  a * b = a >>= \a -> case a of+    OList ax -> OList <$> mapM ((* b) . xpure) ax+    ODict ax -> (ODict . M.fromList) <$>+      mapM (\ (key, a) -> fmap ((,) key) (xpure a * b)) (M.assocs ax)+    a        -> b >>= \b -> case b of+      OList bx -> OList <$> mapM (((xpure a) *) . xpure) bx+      ODict bx -> (ODict . M.fromList) <$>+        mapM (\ (key, b) -> fmap ((,) key) (xpure a * xpure b)) (M.assocs bx)+      b        -> _evalNumOp2 (*) a b <|> eval_Infix_op MULT a b+  a - b = a >>= \a -> b >>= \b -> case a of+    -- on strings, the inverse operation of "join(b, a)", every occurence of b from a.+    OString a -> case b of+      OString b -> return $ OString $ mconcat $ splitString a b+      _         -> mzero+    -- on lists, removes the item b from the list a+    OList   a -> return $ OList $ filter (/= b) a+    ODict   a -> case b of+      ODict b -> return $ ODict $ M.difference a b+      ORef (Reference UNQUAL b NullRef) -> return $ ODict $ M.delete b a+      ORef _                            ->+        execThrow "dictionary key must be a single unqualified name" ExecErrorUntyped [(assertFailed, b)]+      _ -> mzero+    a         -> _evalNumOp2 (-) a b <|> eval_Infix_op SUB a b+  negate a = (a >>= _evalNumOp1 negate) <|> (a >>= eval_Prefix_op NEGTIV)+  abs    a = (a >>= _evalNumOp1 abs   ) <|> (a >>= eval_Prefix_op NEGTIV)+  signum a =  a >>= _evalNumOp1 signum+  fromInteger = return . obj++_xpureApplyError :: String -> String -> a+_xpureApplyError name msg = error $ concat $ concat $+  [["cannot evaluate ", name], guard (not $ null msg) >> [": ", msg]]++_xpureApply2 :: String -> (Object -> Object -> a) -> XPure Object -> XPure Object -> a+_xpureApply2 name f a b = case evalXPure ab of+  PFail   e -> _xpureApplyError name (prettyShow e)+  Backtrack -> _xpureApplyError name ""+  OK      o -> o+  where+    ab = do+      ta <- coreType <$> a+      tb <- coreType <$> b+      let t = max ta tb+      a <- a >>= castToCoreType t+      b <- b >>= castToCoreType t+      return (f a b)++_xpureApply1 :: String -> (Object -> XPure a) -> XPure Object -> a+_xpureApply1 name f o = case evalXPure $ o >>= f of+  PFail   e -> _xpureApplyError name (prettyShow e)+  Backtrack -> _xpureApplyError name ""+  OK      o -> o++_xpureMaybeApply1 :: (Object -> XPure a) -> XPure Object -> Maybe a+_xpureMaybeApply1 f o = case evalXPure $ o >>= f of+  PFail   _ -> Nothing+  Backtrack -> Nothing+  OK      o -> Just o++instance Eq (XPure Object) where+  (==) = _xpureApply2 "(==)" (==)+  (/=) = _xpureApply2 "(/=)" (/=)++instance Ord (XPure Object) where+  compare = _xpureApply2 "compare" compare+  (<)     = _xpureApply2 "(<)"  (<)+  (<=)    = _xpureApply2 "(<=)" (<=)+  (>)     = _xpureApply2 "(>)"  (>)+  (>=)    = _xpureApply2 "(>=)" (>=)++instance Real (XPure Object) where+  toRational = _xpureApply1 "toRational" $ castToCoreType LongType >=> xmaybe . fromObj++eval_Int_op1 :: String -> (forall a . Integral a => a -> a) -> XPure Object -> XPure Object+eval_Int_op1 name f o = o >>= \o -> case o of+  OChar o -> return $ OChar (chr $ flip mod (ord maxBound) $ f $ ord o)+  OInt  o -> return $ OInt  (f o)+  OWord o -> return $ OWord (f o)+  OLong o -> return $ OLong (f o)+  _       -> throwBadTypeError "wrong data type for object passed to function" o $+                [(errInFunc, obj (ustr name :: Name))]++_xpureCastTo :: XPure CoreType -> XPure Object -> XPure Object+_xpureCastTo typ a = join $ xpure castToCoreType <*> typ <*> a++-- In order for @('XPure' 'Object')@ to be used with the 'Prelude.Div' and 'Prelude.mod' functions,+-- it must instantiate 'Integral', which means it must instantiate 'Prelude.Enum'. This+-- instantiation is an attempt at making the functions behave as they would for ordinary enumerated+-- data types; it is /NOT/ pretty, but it basically works.+instance Enum (XPure Object) where+  succ = eval_Int_op1 "succ" succ+  pred = eval_Int_op1 "pred" pred+  toEnum = return . obj+  fromEnum = _xpureApply1 "fromEnum" $ castToCoreType IntType >=> xmaybe . fromObj+  enumFrom = fix (\loop o -> o : loop (succ o))+  enumFromThen lo hi = fix (\loop o -> o : loop (hi-lo+o)) lo+  enumFromTo a b =+    if maybe False (const True) (extractXPure typ)+    then  case compare aa bb of+            EQ -> repeat aa+            LT -> loop (<bb)         inc  aa+            GT -> loop (>bb) (negate inc) aa+    else  []+    where+      loop ok inc a = a : let b = a+inc in if ok b then loop ok inc b else []+      typ   = a >>= \a -> b >>= \b -> do+        let t = max (coreType a) (coreType b)+        guard (CharType <= t && t <= ComplexType) >> xpure t+      inc = typ >>= flip castToCoreType (OChar '\x01')+      aa  = _xpureCastTo typ a+      bb  = _xpureCastTo typ b+  enumFromThenTo a b c =+    if maybe False (const True) $ extractXPure typ+    then  case compare aa bb of+            EQ -> repeat aa+            LT -> if aa<cc then loop (<cc) aa else []+            GT -> if aa>cc then loop (>cc) aa else []+    else  []+    where+      loop ok a = a : let b = a+inc in if ok b then loop ok b else []+      typ = a >>= \a -> b >>= \b -> c >>= \c -> do+        let t = max (coreType a) $ max (coreType b) $ (coreType c)+        guard (CharType <= t && t <= RatioType) >> xpure t+      inc = bb-aa+      aa  = _xpureCastTo typ a+      bb  = _xpureCastTo typ b+      cc  = _xpureCastTo typ c++_xpureDivFunc+  :: String+  -> (forall a . Integral a => a -> a -> (a, a))+  -> XPure Object -> XPure Object -> (XPure Object, XPure Object)+_xpureDivFunc name div a b = _xpureApply2 name f aa bb where+    f a b = case (a, b) of+      (OChar a, OChar b) -> pair (ord a) (ord b) (OChar . chr)+      (OInt  a, OInt  b) -> pair a b OInt+      (OWord a, OWord b) -> pair a b OWord+      (OLong a, OLong b) -> pair a b OLong+      _                  -> (mzero, mzero)+    pair a b constr = let (c, d) = div a b in (xpure $ constr c, xpure $ constr d)+    typ = a >>= \a -> b >>= \b -> do+      let t = max (coreType a) (coreType b)+      guard (CharType <= t && t <= LongType) >> xpure t+    aa = _xpureCastTo typ a+    bb = _xpureCastTo typ b++instance Integral (XPure Object) where+  toInteger = _xpureApply1 "toInteger" (castToCoreType LongType >=> xmaybe . fromObj)+  quotRem a b = _xpureDivFunc "quoteRem" quotRem a b+  divMod  a b = _xpureDivFunc "divMod"   divMod  a b+  div     a b = a >>= \a -> b >>= \b -> case (a, b) of+    (OString a, OString b) -> return $ OWord $ fromIntegral $ length $ splitString a b+    _ -> fst (_xpureDivFunc "(/)" divMod (xpure a) (xpure b)) <|> eval_Infix_op DIV a b+  mod     a b = a >>= \a -> b >>= \b -> case (a, b) of+    (OString a, OString b) -> return $ OList $ map OString $ splitString a b+    _ -> snd (_xpureDivFunc "(%)" divMod (xpure a) (xpure b)) <|> eval_Infix_op MOD a b++_xpureFrac :: (forall a . Floating a => a -> a) -> XPure Object -> XPure Object+_xpureFrac f a = a >>= \a -> case a of+  ORelTime a -> xpure $ ORelTime $ fromRational $ toRational $+    f (fromRational (toRational a) :: Double)+  OFloat   a -> xpure $ OFloat   $ f a+  ORatio   a -> xpure $ ORatio   $ toRational $ f $ (fromRational a :: Double)+  OComplex a -> xpure $ OComplex $ f a+  _          -> mzero++_xpureFrac2 :: (forall a . Floating a => a -> a -> a) -> XPure Object -> XPure Object -> XPure Object+_xpureFrac2 f a b = a >>= \a -> b >>= \b -> do+  let t = max (coreType a) (coreType b)+  a <- castToCoreType t a+  b <- castToCoreType t b+  case (a, b) of+    (ORelTime a, ORelTime b) -> xpure $ ORelTime $ fromRational $ toRational $+      f (fromRational (toRational a) :: Double) (fromRational (toRational b) :: Double)+    (OFloat   a, OFloat   b) -> xpure $ OFloat   $ f a b+    (ORatio   a, ORatio   b) -> xpure $ ORatio   $ toRational $+      f (fromRational a :: Double) (fromRational b :: Double)+    (OComplex a, OComplex b) -> xpure $ OComplex $ f a b+    _                        -> mzero++instance Fractional (XPure Object) where+  a / b  = _xpureFrac2 (/) a b+  recip = _xpureFrac recip+  fromRational = xpure . ORatio++instance Floating (XPure Object) where+  pi      = xpure $ OFloat pi+  logBase = _xpureFrac2 logBase+  (**)    a b = _xpureFrac2 (**) a b+  exp     = _xpureFrac exp+  sqrt    = _xpureFrac sqrt+  log     = _xpureFrac log+  sin     = _xpureFrac sin+  tan     = _xpureFrac tan+  cos     = _xpureFrac cos+  asin    = _xpureFrac asin+  atan    = _xpureFrac atan+  acos    = _xpureFrac acos+  sinh    = _xpureFrac sinh+  tanh    = _xpureFrac tanh+  cosh    = _xpureFrac cosh+  asinh   = _xpureFrac asinh+  atanh   = _xpureFrac atanh+  acosh   = _xpureFrac acosh++_xpureRealFrac :: Integral b => String -> (forall a . RealFrac a => a -> b) -> XPure Object -> b+_xpureRealFrac name f = _xpureApply1 name $ \o -> case o of+  ORelTime a -> xpure $ f a+  OFloat   a -> xpure $ f a+  ORatio   a -> xpure $ f a+  _          -> mzero++instance RealFrac (XPure Object) where+  properFraction = let name = "properFraction" in _xpureApply1 name $ \o -> case o of+    ORelTime o -> f ORelTime o+    OFloat   o -> f OFloat   o+    ORatio   o -> f ORatio   o+    _          -> xpure (error $ "cannot evaluate properFraction on object "++prettyShow o, mzero)+    where { f constr o = let (i, b) = properFraction o in xpure (i, xpure $ constr b) }+  truncate = _xpureRealFrac "truncate" truncate+  round    = _xpureRealFrac "round"    round+  ceiling  = _xpureRealFrac "ceiling"  ceiling+  floor    = _xpureRealFrac "floor"    floor++_xpureBits :: (forall a . Bits a => a -> a) -> (B.ByteString -> B.ByteString) -> XPure Object -> XPure Object+_xpureBits f g o = o >>= \o -> case o of+  OChar  o -> return $ OChar  $ chr $ mod (f $ ord o) (ord maxBound)+  OInt   o -> return $ OInt   $ f o+  OWord  o -> return $ OWord  $ f o+  OLong  o -> return $ OLong  $ f o+  OBytes o -> return $ OBytes $ g o+  _        -> mzero++_xpureBits2 :: InfixOp -> (forall a . Bits a => a -> a -> a) -> (T_dict -> T_dict -> T_dict) -> (B.ByteString -> B.ByteString -> B.ByteString) -> XPure Object -> XPure Object -> XPure Object+_xpureBits2 op bits dict bytes a b = a >>= \a -> b >>= \b -> do+  let t = max (coreType a) (coreType b)+  a <- castToCoreType t a+  b <- castToCoreType t b+  case (a, b) of+    (OChar  a, OChar  b) -> return $ OChar  $ chr $ mod (bits (ord a) (ord b)) (ord maxBound)+    (OInt   a, OInt   b) -> return $ OInt   $ bits a b+    (OWord  a, OWord  b) -> return $ OWord  $ bits a b+    (OLong  a, OLong  b) -> return $ OLong  $ bits a b+    (ODict  a, ODict  b) -> return $ ODict  $ dict a b+    (OTree  a, OTree  b) -> case (a, b) of+      (Struct{ structName=na, fieldMap=ma }, Struct{ structName=nb, fieldMap=mb }) | na==nb ->+        xpure $ OTree $ a{ fieldMap = dict ma mb }+      _ -> throwBadTypeError "cannot operate on dissimilar struct types" (OTree b) $+              [(expectType, obj (typeOfObj (OTree a)))]+    (OBytes a, OBytes b) -> return $ OBytes $ bytes a b+    _                    -> eval_Infix_op op a b++_dict_XOR :: (Object -> Object -> Object) -> T_dict -> T_dict -> T_dict+_dict_XOR f a b = M.difference (M.unionWith f a b) (M.intersectionWith f a b)++instance Bits (XPure Object) where+  a .&. b = _xpureBits2 AND (.&.) (M.intersectionWith (flip const)) (bytesBitArith (.&.)) a b <|>+    (a >>= \a -> b >>= \b -> eval_Infix_op ANDB a b)+  a .|. b = _xpureBits2 ORB (.|.) (M.unionWith (flip const))        (bytesBitArith (.|.)) a b <|>+    (a >>= \a -> b >>= \b -> eval_Infix_op ORB  a b)+  xor a b = _xpureBits2 XORB xor  (_dict_XOR (flip const))          (bytesBitArith  xor ) a b <|>+    (a >>= \a -> b >>= \b -> eval_Infix_op XORB a b)+  complement  = _xpureBits complement (B.map complement)+  shift   o i = o >>= \o -> case o of+    OList o -> xpure $ OList $ case compare i 0 of+      EQ -> o+      LT -> reverse $ drop (negate i) $ reverse o+      GT -> drop i o+    _ -> _xpureBits (flip shift i) (flip bytesShift (fromIntegral i)) (xpure o)+  rotate  o i = _xpureBits (flip shift i) (flip bytesRotate (fromIntegral i)) o+  bit       i = xpure $ if i<64 then OWord (bit i) else OBytes (bytesBit (fromIntegral i))+  testBit o i = _xpureApply1 "testBit" testbit o where+    testbit o = case o of+      OChar  o -> xpure $ testBit (ord o) i+      OInt   o -> xpure $ testBit o i+      OWord  o -> xpure $ testBit o i+      OLong  o -> xpure $ testBit o i+      OBytes o -> xpure $ bytesTestBit o (fromIntegral i)+      _        -> mzero+  bitSize = _xpureApply1 "bitSize" $ \o -> case o of+    OInt   o -> xmaybe $ bitSizeMaybe o+    OWord  o -> xmaybe $ bitSizeMaybe o+    OBytes o -> xpure $ fromIntegral $ bytesBitSize o+    _        -> mzero+  bitSizeMaybe = _xpureMaybeApply1 $ \o -> case o of+    OInt   o -> xmaybe $ bitSizeMaybe o+    OWord  o -> xmaybe $ bitSizeMaybe o+    OBytes o -> xpure $ fromIntegral $ bytesBitSize o+    _        -> mzero+  isSigned = _xpureApply1 "isSigned" $ \o -> case o of+    OChar  _ -> xpure False+    OInt   _ -> xpure True+    OWord  _ -> xpure False+    OLong  _ -> xpure True+    OBytes _ -> xpure False+    _        -> mzero+  popCount = _xpureApply1 "popCount" $ \o -> case o of+    OChar  o -> xpure $ popCount (ord o)+    OInt   o -> xpure $ popCount o+    OWord  o -> xpure $ popCount o+    OLong  o -> xpure $ popCount o+    OBytes o -> xpure $ fromIntegral $ bytesPopCount o+    _        -> mzero++_shiftOp :: (Int -> Int) -> Object -> Object -> XPure Object+_shiftOp neg a b = case b of+  OInt  b -> shift (xpure a) (neg b)+  OWord b -> shift (xpure a) (neg $ fromIntegral b)+  OLong b -> shift (xpure a) (neg $ fromIntegral b)+  _       -> mzero++-- | Evaluate the shift-left operator in the 'XPure' monad.+shiftLeft :: Object -> Object -> XPure Object+shiftLeft a b = _shiftOp id a b <|> eval_Infix_op SHL a b++-- | Evaluate the shift-right operator in the 'XPure' monad.+shiftRight :: Object -> Object -> XPure Object+shiftRight a b = _shiftOp negate a b <|> eval_Infix_op SHR a b++-- | Throw an error declaring that the two types cannot be used together because their types are+-- incompatible. Provide the a string describing the /what/ could not be done as a result of the+-- type mismatch, it will be placed in the message string:+-- > "could not <WHAT> the item <A> of type <A-TYPE> with the item <B> of type <B-TYPE>"+typeMismatchError :: InfixOp -> Object -> Object -> XPure ig+typeMismatchError op a b = throwError $+  newError{ execErrorSubtype = ExecInfixOpError (typeOfObj a) op (typeOfObj b) }++eval_ADD :: Object -> Object -> XPure Object+eval_ADD a b = (xpure a + xpure b) <|> typeMismatchError ADD a b++eval_SUB :: Object -> Object -> XPure Object+eval_SUB a b = (xpure a - xpure b) <|> typeMismatchError SUB a b++eval_MULT :: Object -> Object -> XPure Object+eval_MULT a b = (xpure a * xpure b) <|> typeMismatchError MULT a b++eval_DIV :: Object -> Object -> XPure Object+eval_DIV a b = do+  let { xa = xpure a; xb = xpure b; }+  (div xa xb <|> xa/xb) <|> typeMismatchError DIV a b++eval_MOD :: Object -> Object -> XPure Object+eval_MOD a b = do+  let { xa = xpure a; xb = xpure b; }+  (mod xa xb) <|> typeMismatchError MOD a b++eval_POW :: Object -> Object -> XPure Object+eval_POW a b = do+  let { xa = xpure a; xb = xpure b; }+  xa^^xb <|> xa**xb <|> typeMismatchError POW a b++eval_ORB :: Object -> Object -> XPure Object+eval_ORB a b = do+  let { xa = xpure a; xb = xpure b; }+  (xa.|.xb) <|> typeMismatchError ORB a b++eval_ANDB :: Object -> Object -> XPure Object+eval_ANDB a b = do+  let { xa = xpure a; xb = xpure b; }+  (xa.&.xb) <|> typeMismatchError ANDB a b++eval_XORB :: Object -> Object -> XPure Object+eval_XORB a b = do+  let { xa = xpure a; xb = xpure b; }+  (xor xa xb) <|> typeMismatchError XORB a b++eval_EQUL :: Object -> Object -> XPure Object+eval_EQUL a b = return $ obj $ xpure a == xpure b++eval_NEQUL :: Object -> Object -> XPure Object+eval_NEQUL a b = return $ obj $ xpure a /= xpure b++eval_GTN :: Object -> Object -> XPure Object+eval_GTN a b = return $ obj $ xpure a > xpure b++eval_LTN :: Object -> Object -> XPure Object+eval_LTN a b = return $ obj $ xpure a < xpure b++eval_GTEQ :: Object -> Object -> XPure Object+eval_GTEQ a b = return $ obj $ xpure a >= xpure b++eval_LTEQ :: Object -> Object -> XPure Object+eval_LTEQ a b = return $ obj $ xpure a <= xpure b++eval_SHR :: Object -> Object -> XPure Object+eval_SHR a b = shiftRight a b++eval_SHL :: Object -> Object -> XPure Object+eval_SHL a b = shiftLeft a b++eval_NEG :: Object -> XPure Object+eval_NEG = _evalNumOp1 negate++eval_INVB :: Object -> XPure Object+eval_INVB = complement . xpure++eval_NOT :: Object -> XPure Object+eval_NOT = fmap (obj . not) . objToBool++objToBool :: Object -> XPure Bool+objToBool o = case o of+  OHaskell (Hata ifc d) -> case objNullTest ifc of+    Nothing   -> throwBadTypeError "cannot be used as a boolean value" o [(assertFailed, o)]+    Just test -> return (test d)+  o -> return $ not $ testNull o++-- | Traverse the entire object, returning a list of all 'OString' elements.+extractStringElems :: Object -> [UStr]+extractStringElems o = case o of+  OString  o   -> [o]+  OList    o   -> concatMap extractStringElems o+  _            -> []++-- | Useful for building 'DaoFunc' objects, checks every parameter in a list of 'Object's to be a+-- string, and throws an exception if one of the 'Object's is not a string.+requireAllStringArgs :: String -> [Object] -> Exec [UStr]+requireAllStringArgs msg ox = case mapM check (zip [1..] ox) of+  OK      obj -> return obj+  Backtrack   -> fail msg+  PFail   err -> throwError err+  where+    check (i, o) = case o of+      OString o -> return o+      _         -> throwBadTypeError msg o [(argNum, OInt i)]++----------------------------------------------------------------------------------------------------++_updateToInfixOp :: UpdateOp -> InfixOp+_updateToInfixOp = (arr!) where+  arr :: Array UpdateOp InfixOp+  arr = array (UADD, maxBound) $+    [ (UADD  , ADD )+    , (USUB  , SUB )+    , (UMULT , MULT)+    , (UDIV  , DIV )+    , (UMOD  , MOD )+    , (UPOW  , POW )+    , (UORB  , ORB )+    , (UANDB , ANDB)+    , (UXORB , XORB)+    , (USHL  , SHL )+    , (USHR  , SHR )+    ]++instance ToDaoStructClass UpdateOp where { toDaoStruct = putNullaryUsingShow }++instance FromDaoStructClass UpdateOp where { fromDaoStruct = getNullaryWithRead }++instance ObjectClass UpdateOp where { obj=new; fromObj=objFromHata; }++instance HataClass UpdateOp where+  haskellDataInterface = interface "UpdateOperator" $ do+    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass RefPfxOp where { toDaoStruct = putNullaryUsingShow }++instance FromDaoStructClass RefPfxOp where { fromDaoStruct = getNullaryWithRead }++instance ObjectClass RefPfxOp where { obj=new; fromObj=objFromHata; }++instance HataClass RefPfxOp where+  haskellDataInterface = interface "ReferenceOperator" $ do+    autoDefEquality >> autoDefOrdering+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass ArithPfxOp where { toDaoStruct = putNullaryUsingShow }++instance FromDaoStructClass ArithPfxOp where { fromDaoStruct = getNullaryWithRead }++instance ObjectClass ArithPfxOp where { obj=new; fromObj=objFromHata; }++instance HataClass ArithPfxOp where+  haskellDataInterface = interface "ArithmeticPrefixOperator" $ do+    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass InfixOp where { toDaoStruct=putNullaryUsingShow; }++instance FromDaoStructClass InfixOp where { fromDaoStruct = getNullaryWithRead }++instance ObjectClass InfixOp where { obj=new; fromObj=objFromHata; }++instance HataClass InfixOp where+  haskellDataInterface = interface "ArithmeticInfixOperator" $ do+    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass TopLevelEventType where { toDaoStruct = putNullaryUsingShow }++instance FromDaoStructClass TopLevelEventType where { fromDaoStruct = getNullaryWithRead }++instance ObjectClass TopLevelEventType where { obj=new; fromObj=objFromHata; }++instance HataClass TopLevelEventType where+  haskellDataInterface = interface "TopLevelEventType" $ do+    autoDefEquality >> autoDefOrdering+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++evalArithPrefixOp :: ArithPfxOp -> Object -> XPure Object+evalArithPrefixOp = (_arithPrefixOps!)++_arithPrefixOps :: Array ArithPfxOp (Object -> XPure Object)+_arithPrefixOps = array (minBound, maxBound) $ defaults +++  [ o NEGTIV eval_NEG+  , o POSTIV return+  , o INVB   eval_INVB+  , o NOT    eval_NOT+  ]+  where+    o = (,)+    defaults = flip map [minBound..maxBound] $ \op ->+      (op, \_ -> error $ "no builtin function for prefix "++show op++" operator")++evalInfixOp :: InfixOp -> Object -> Object -> XPure Object+evalInfixOp op a b = msum $ f a ++ f b ++ [(_infixOps!op) a b] where+  f = maybe [] return . (fromObj >=> getOp)+  getOp (Hata ifc a) = (\f -> f op a b) <$> (objInfixOpTable ifc >>= (! op))++_infixOps :: Array InfixOp (Object -> Object -> XPure Object)+_infixOps = array (minBound, maxBound) $ defaults +++  [ o ADD   eval_ADD+  , o SUB   eval_SUB+  , o MULT  eval_MULT+  , o DIV   eval_DIV+  , o MOD   eval_MOD+  , o POW   eval_POW+  , o SHL   eval_SHL+  , o SHR   eval_SHR+  , o ORB   eval_ORB+  , o ANDB  eval_ANDB+  , o XORB  eval_XORB+  , o OR    (error (e "logical-OR" )) -- These probably wont be evaluated. Locgical and/or is a+  , o AND   (error (e "logical-AND")) -- special case to be evaluated in 'evalObjectExprWithLoc'.+  , o EQUL  eval_EQUL+  , o NEQUL eval_NEQUL+  , o GTN   eval_GTN+  , o LTN   eval_LTN+  , o GTEQ  eval_GTEQ+  , o LTEQ  eval_LTEQ+  , o ARROW (error (e "ARROW"))+  ]+  where+    o = (,)+    defaults = flip map [minBound..maxBound] $ \op ->+      (op, \_ _ -> error $ "no builtin function for infix "++show op++" operator")+    e msg = msg +++      " operator should have been evaluated within the 'execute' function."++-- | Evaluate an 'UpdateOp' operator. Provide an optional 'Reference' indicating the reference+-- location of the value being updated, then the 'UpdateOp' operator, the right-hand side 'Object'+-- value, and finally the current value stored at the 'Reference' location that needs to be updated.+-- If the 'UpdateOp' is 'UCONST', the current value may be 'Prelude.Nothing' as any current value+-- will be overwritten. If the 'UpdateOp' is not 'UCONST' and the current value is+-- 'Prelude.Nothing', this is an error. Otherwise the current value is removed from the+-- 'Prelude.Just' constructor and used as the left-hand operand with the right-hand operand of the+-- appropriate arithmetic function associated with the 'UpdateOp'.+evalUpdateOp :: Maybe Reference -> UpdateOp -> Object -> Maybe Object -> Exec (Maybe Object)+evalUpdateOp qref op newObj oldObj = case op of+  UCONST -> return $ Just newObj+  op     -> case oldObj of+    Nothing     ->+      execThrow "performed update on void value" (ExecUpdateOpError op)+        (maybe [] (\qref -> [(errOfReference, obj qref)]) qref)+    Just oldObj -> Just <$> execute (evalInfixOp (_updateToInfixOp op) oldObj newObj)++_updatingOps :: Array UpdateOp (Object -> Object -> XPure Object)+_updatingOps = let o = (,) in array (minBound, maxBound) $ defaults +++  [ o UCONST (\_ b -> return b)+  , o UADD   eval_ADD+  , o USUB   eval_SUB+  , o UMULT  eval_MULT+  , o UDIV   eval_DIV+  , o UMOD   eval_MOD+  , o UORB   eval_ORB+  , o UANDB  eval_ANDB+  , o UXORB  eval_XORB+  , o USHL   eval_SHL+  , o USHR   eval_SHR+  ]+  where+    defaults = flip map [minBound..maxBound] $ \op ->+      (op, \_ _ -> error $ "no builtin function for update operator "++show op)++----------------------------------------------------------------------------------------------------++_strObjConcat :: [Object] -> String+_strObjConcat ox = ox >>= \o -> maybe [toUStr $ prettyShow o] return (fromObj o) >>= uchars++makePrintFunc :: (typ -> String -> Exec ()) -> DaoFunc typ+makePrintFunc print =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \typ ox -> print typ (_strObjConcat ox) >> return (Nothing, typ)+  }++builtin_print :: DaoFunc ()+builtin_print   = makePrintFunc (\ () -> liftIO . (putStr >=> evaluate))++builtin_println :: DaoFunc ()+builtin_println = makePrintFunc (\ () -> liftIO . (putStrLn >=> evaluate))++-- join string elements of a container, pretty prints non-strings and joins those as well.+builtin_join :: DaoFunc ()+builtin_join =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () ox -> return $ flip (,) () $ Just $ obj $ case ox of+      OString j : ox -> (>>=uchars) $+        intersperse j $ snd (objConcat ox) >>= \o ->+          [maybe (ustr $ prettyShow o) id (fromObj o :: Maybe UStr)]+      ox -> _strObjConcat ox+  }++builtin_str :: DaoFunc ()+builtin_str =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . _strObjConcat+  }++builtin_quote :: DaoFunc ()+builtin_quote =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . show . _strObjConcat+  }++builtin_concat :: DaoFunc ()+builtin_concat =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . fix (\loop ox -> ox >>= \o -> maybe [o] loop (fromObj o))+  }++builtin_concat1 :: DaoFunc ()+builtin_concat1 =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . snd . objConcat+  }++builtin_reverse :: DaoFunc ()+builtin_reverse =+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . reverse . snd . objConcat+  }++_castNumerical :: String -> (Object -> Exec Object) -> DaoFunc ()+_castNumerical name f = let n = ustr name :: Name in+  daoFunc+  { funcAutoDerefParams = True+  , daoForeignFunc = \ () ox -> case ox of+      [o] -> (flip (,) () . Just <$> f o) <|> throwBadTypeError "cannot cast to numerical type" o []+      ox  -> throwArityError "" 1 ox [(errInFunc, obj $ reference UNQUAL n)]+  }++builtin_int :: DaoFunc ()+builtin_int = _castNumerical "int" $+  fmap OInt . (execute . castToCoreType IntType >=> xmaybe . fromObj)++builtin_long :: DaoFunc ()+builtin_long = _castNumerical "long" $+  fmap OLong . (execute . castToCoreType LongType >=> xmaybe . fromObj)++builtin_ratio :: DaoFunc ()+builtin_ratio = _castNumerical "ratio" $+  fmap ORatio . (execute . castToCoreType RatioType >=> xmaybe . fromObj)++builtin_float :: DaoFunc ()+builtin_float = _castNumerical "float" $+  fmap OFloat . (execute . castToCoreType FloatType >=> xmaybe . fromObj)++builtin_complex :: DaoFunc ()+builtin_complex = _castNumerical "complex" $+  fmap OComplex . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)++builtin_imag :: DaoFunc ()+builtin_imag = _castNumerical "imag" $+  fmap (OFloat . imagPart) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)++builtin_phase :: DaoFunc ()+builtin_phase = _castNumerical "phase" $+  fmap (OFloat . phase) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)++builtin_conj :: DaoFunc ()+builtin_conj = _castNumerical "conj" $+  fmap (OComplex . conjugate) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj)++builtin_abs :: DaoFunc ()+builtin_abs = _castNumerical "abs" $ execute . asPositive++builtin_time :: DaoFunc ()+builtin_time = _castNumerical "time" $ \o -> case o of+  ORelTime _ -> return o+  o          -> (ORelTime . fromRational) <$> execute (asRational o)++_funcWithoutParams :: String -> Exec (Maybe Object) -> DaoFunc ()+_funcWithoutParams name f =+  daoFunc+  { daoForeignFunc = \ () ox -> case ox of+      [] -> flip (,) () <$> f+      ox -> throwArityError "function takes no parameters" 0 ox $+        [(errInFunc, obj $ reference UNQUAL (ustr name))]+  }++builtin_now :: DaoFunc ()+builtin_now = _funcWithoutParams "now" $ (Just . obj) <$> liftIO getCurrentTime++builtin_ref :: DaoFunc ()+builtin_ref =+  daoFunc+  { daoForeignFunc = \ () -> fmap (flip (,) () . Just . ORef) . execute . mconcat .+      fmap (\o -> (castToCoreType RefType o) <|>+             (throwBadTypeError "could not convert to reference" o []) >>=+               (castToCoreType RefType >=> xmaybe . fromObj)+           )+  }++builtin_check_if_defined :: DaoFunc ()+builtin_check_if_defined =+  daoFunc+  { funcAutoDerefParams = False+  , daoForeignFunc = \ () args -> fmap (flip (,) () . Just . obj . and) $ forM args $ \arg -> case arg of+      ORef o -> catchError (referenceLookup o >> return True) $ \err -> case err of+        ExecError{ execErrorSubtype=ExecUndefinedRef _ } -> return False+        err                                              -> throwError err+      _      -> return True+  }++builtin_delete :: DaoFunc ()+builtin_delete =+  daoFunc+  { funcAutoDerefParams = False+  , daoForeignFunc = \ () args -> do+      forM_ args $ \arg -> case arg of+        ORef o -> void $ referenceUpdate o True (const $ return Nothing)+        _      -> return ()+      return (Nothing, ())+  }++builtin_typeof :: DaoFunc ()+builtin_typeof =+  daoFunc+  { daoForeignFunc = \ () ox -> return $ flip (,) () $ case ox of+      []  -> Nothing+      [o] -> Just $ OType $ typeOfObj o+      ox  -> Just $ OList $ map (OType . typeOfObj) ox+  }++builtin_sizeof :: DaoFunc ()+builtin_sizeof =+  daoFunc+  { daoForeignFunc = \ () ox -> case ox of+      [o] -> flip (,) () . Just <$> getSizeOf o+      ox  -> throwArityError "" 1 ox [(errInFunc, obj $ reference UNQUAL (ustr "sizeof"))]+  }++builtin_call :: DaoFunc ()+builtin_call =+  daoFunc+  { funcAutoDerefParams = False+  , daoForeignFunc = \ () ox -> case ox of+      [func, params] -> do+        let nonlist_err = fail "second parameter to \"call()\" function is not a list of arguments"+        params <- case params of+          OList params -> return params+          ORef  params -> referenceLookup params >>= \ (_, params) -> case params of+            Nothing     -> fail "second parameter parameter to \"call()\" function evaluated to null"+            Just params -> xmaybe (fromObj params) <|> nonlist_err+          _ -> nonlist_err+        qref <- xmaybe (fromObj func)+          <|> fail "first parameter to \"call()\" function is not a reference to a function"+        (qref, func) <- referenceLookup qref+        case func of+          Nothing   -> fail "first parameter to \"call()\" function evaluated to null"+          Just func -> fmap (const ()) <$> callObject qref func params+      _ -> fail $ unwords $+        [ "the \"call()\" function was evaluated with incorrect arguments."+        , "Expecting a reference to function as first parameter"+        , "and a list of arguments as the second parameter."+        ]+  }++builtin_toHash :: DaoFunc ()+builtin_toHash =+  daoFunc+  { daoForeignFunc = \ () ox -> do+      let qref = reference UNQUAL (ustr "toHash")+      let err  = throwArityError "" 1 ox [(errInFunc, obj qref)]+      case ox of+        [o] -> case o of+          OTree              _  -> return (Just o, ())+          OHaskell (Hata ifc d) -> case objToStruct ifc of+            Just to -> flip (,) () . Just . OTree <$> toDaoStructExec to d+            Nothing -> throwBadTypeError "data type is opaque, cannot do binary conversion for hash" o $+              [(errInFunc, obj qref)]+          _                     -> err+        _   -> err+  }++builtin_fromHash :: DaoFunc ()+builtin_fromHash =+  daoFunc+  { daoForeignFunc = \ () ox -> do+      let qref = reference UNQUAL (ustr "fromHash")+      case ox of+        [o] -> do+          let err = throwBadTypeError "hashed Struct parameter required" o [(errInFunc, obj qref)]+          xmaybe (fromObj o) <|> err >>= fmap (flip (,) () . Just . obj) . fromDaoStructExec +        ox  -> throwArityError "" 1 ox [(errInFunc, obj qref)]+  }++builtin_tokenize :: DaoFunc ()+builtin_tokenize =+  daoFunc{ daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj . map obj) . runTokenizer }++----------------------------------------------------------------------------------------------------++-- binary 0x42 0x45 RefSuffixExpr-->RefSuffix+instance B.Binary (RefSuffixExpr Object) MTab where+  put o = case o of+    NullRefExpr         -> B.putWord8   0x42+    DotRefExpr    a b c -> B.prefixByte 0x43 $ B.put a >> B.put b >> B.put c+    SubscriptExpr a b   -> B.prefixByte 0x44 $ B.put a >> B.put b+    FuncCallExpr  a b   -> B.prefixByte 0x45 $ B.put a >> B.put b+  get = B.word8PrefixTable <|> fail "expecting RefSuffixExpr"++instance B.HasPrefixTable (RefSuffixExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "RefSuffixExpr" 0x42 0x45 $+    [ return NullRefExpr+    , return DotRefExpr    <*> B.get <*> B.get <*> B.get+    , return SubscriptExpr <*> B.get <*> B.get+    , return FuncCallExpr  <*> B.get <*> B.get+    ]++instance Executable (RefSuffixExpr Object) RefSuffix where+  execute o = errLocation o $ case o of+    NullRefExpr              -> return NullRef+    DotRefExpr    name ref _ -> DotRef name <$> execute ref+    SubscriptExpr args ref   -> return Subscript <*> execute args <*> execute ref+    FuncCallExpr  args ref   -> return FuncCall  <*> execute args <*> execute ref++----------------------------------------------------------------------------------------------------++-- | To evaluate an 'Object' value against a type expression, you can store the+-- 'Object' into a 'TyChkExpr' and 'execute' it. This instance of+-- 'execute' evaluates a type checking monad computing over the 'tyChkExpr' in+-- the 'TyChkExpr'. If the type check determines the 'Object' value does not match, this+-- function backtracks. If the type check is successful, the most general type value for the object+-- if that type value is less-general or as-general as the 'TyChkExpr' provided.+instance Executable (TyChkExpr Object Object) Object where+  execute tc = case tc of+    NotTypeChecked _          -> return OTrue -- TODO: this needs to return the 'AnyType', not 'OTrue'.+    TypeChecked    _ _ _      -> return OTrue -- TODO: evaluate the actual type checking algorithm here+    DisableCheck   _ _ rslt _ -> return rslt++-- | Convert an 'ObjectExpr' to an 'Dao.Glob.Glob'.+paramsToGlobExpr :: ObjectExpr Object -> Exec (Glob UStr)+paramsToGlobExpr o = case o of+  ObjLiteralExpr (LiteralExpr (OString str) _) -> return (read (uchars str))+  _ -> fail "does not evaluate to a \"glob\" pattern"++-- | Called by 'callFunction' to match the list of 'Object's passed as arguments to the function.+-- Returns two 'T_dict's: the first is the 'T_dict' to be passed to 'execFuncPushStack', the second+-- is the dictionary of local variables passed by reference. Backtracks if any types do not match,+-- or if there are an incorrect number of parameters. Backtracking is important because of function+-- overloading.+matchFuncParams :: ParamListExpr Object -> [Object] -> Exec T_dict+matchFuncParams (ParamListExpr params _) ox = loop (0::Int) M.empty (tyChkItem params) ox where+  loop i dict params ox = case ox of+    [] | null params -> return dict+    [] -> mzero -- not enough parameters passed to function+    o:ox -> case params of+      [] -> mzero -- too many parameters passed to function+      ParamExpr passByRef tychk _ : params -> do+        let name = tyChkItem tychk+        execute $ fmapCheckedValueExpr (const o) tychk -- execute (TyChkExpr Object)+        o <- if passByRef then (case o of { ORef _ -> return o; _ -> mzero }) else derefObject o+        loop (i+1) (M.insert name o dict) params ox++-- | A guard script is some Dao script that is executed before or after some event, for example, the+-- code found in the @BEGIN@ and @END@ blocks.+execGuardBlock :: [ScriptExpr Object] -> Exec ()+execGuardBlock block = void $+  execFuncPushStack M.empty (mapM_ execute block >> return Nothing) >> return ()++-- | Takes two parameters: first is an error message parameter, the second is the 'Object' to be+-- called. The 'Object' to be called should be an 'OHaskell' constructed value containing a+-- 'Hata' where the 'interface' has defined 'defCallable'. If so, the 'CallableCode' objects+-- returned by 'objCallable' will be returned by this function. If not, +objToCallable :: Object -> Exec [CallableCode]+objToCallable o = case fromObj o >>= \ (Hata ifc o) -> fmap ($ o) (objCallable ifc) of+  Nothing -> mzero+  Just  f -> f++-- | 'CallableCode' objects are usually stored in lists because of function overloading: e.g. a+-- function with a single name but is defined with multiple parameter lists would have several+-- 'CallableCode' objects associated with that function mame. This function tries to perform a+-- function call with a list of parameters. The parameters are matched to each 'CallableCode'+-- object's 'argsPattern', the first 'argsPattern' that matches without backtracking will evaluate+-- the function body. The value returned is a pair containing the result of the function call as the+-- 'Prelude.fst', and update "this" value as 'Prelude.snd'+callCallables :: Maybe Object -> [CallableCode] -> [Object] -> Exec (Maybe Object, Maybe Object)+callCallables this funcs params = fmap (fmap (M.lookup (ustr "this"))) $ join $+  msum $ flip fmap funcs $ \call -> matchFuncParams (argsPattern call) params >>=+    return . flip execFuncPushStack (execute $ codeSubroutine call) . M.alter (const this) (ustr "this")++-- | This function assumes you have retrieved a callable function-like 'Object' using a 'Reference'.+-- This function evaluates 'callCallables', and extracts the 'CallableCode' from the 'Object'+-- provided as the second parameter using 'objToCallable'. The 'Reference' passed as the first+-- parameter should be the reference used to retrieve the function 'Object'. If the given object+-- provides a 'defCallable' callback, the object can be called with parameters as if it were a+-- function.+callObject :: Reference -> Object -> [Object] -> Exec (Maybe Object, Maybe Object)+callObject qref o params = case o of+  OHaskell (Hata ifc d) -> case fromDynamic d of+    Just func -> fmap (const Nothing) <$> executeDaoFunc func () params -- try calling an ordinary function+    Nothing   -> case objCallable ifc of+      Just getFuncs -> getFuncs d >>= \func -> callCallables (Just o) func params+      Nothing       -> err+  _ -> err+  where { err = throwBadTypeError "not a callable object" o [(errInFunc, obj qref)] }++-- | Evaluate to 'procErr' if the given 'Predicate' is 'Backtrack' or 'PFail'. You must pass a+-- 'Prelude.String' as the message to be used when the given 'Predicate' is 'Backtrack'. You can also+-- pass a list of 'Object's that you are checking, these objects will be included in the+-- 'procErr' value.+--     This function should be used for cases when you have converted 'Object' to a+-- Haskell value, because 'Backtrack' values indicate type exceptions, and 'PFail' values indicate a+-- value error (e.g. out of bounds, or some kind of assert exception), and the messages passed to+-- 'procErr' will indicate this.+checkPredicate :: String -> [Object] -> Exec a -> Exec a+checkPredicate altmsg tried f = do+  pval <- catchPredicate f+  let err = fail (altmsg++" evaulated to void expression")+  case pval of+    OK    a                     -> return a+    Backtrack                   -> err+    PFail (ExecReturn Nothing)  -> err+    PFail  err                  -> throwError $+      err{  execReturnValue = Just $ case execReturnValue err of+              Just (OList ox) -> obj $ tried ++ ox+              Just        o   -> obj $ tried ++ [o]+              Nothing         -> obj tried+         }++-- | 'evalObjectExprExpr' can return 'Data.Maybe.Nothing', and usually this happens when something has+-- failed (e.g. reference lookups), but it is not always an error (e.g. a void list of argument to+-- functions). If you want 'Data.Maybe.Nothing' to cause an error, evaluate your+-- @'Exec' ('Data.Maybe.Maybe' 'Object')@ as a parameter to this function.+checkVoid :: Location -> String -> Maybe a -> Exec a+checkVoid loc msg fn = case fn of+  Nothing -> throwError $+    newError+    { execErrorMessage  = ustr (msg++" evaluated to void")+    , execErrorLocation = loc+    }+  Just  a -> return a++instance ToDaoStructClass (AST_RefSuffix Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_RefNull                 -> makeNullary "Null"+    AST_DotRef dot name ref loc -> renameConstructor "DotRef" $ do+      "dot" .= dot >> "head" .= name >> "tail" .= ref >> putLocation loc+    AST_Subscript  args ref -> renameConstructor "Subscript" $ do+      "args" .= args >> "tail" .= ref >> return ()+    AST_FuncCall   args ref -> renameConstructor "FuncCall" $ do+      "args" .= args >> "tail" .= ref >> return ()++instance FromDaoStructClass (AST_RefSuffix Object) where+  fromDaoStruct = msum $+    [ constructor "Null"   >> return AST_RefNull+    , constructor "DotRef" >> return AST_DotRef <*> req "dot" <*> req "head" <*> req "tail" <*> location+    , constructor "Subscript" >> return AST_Subscript <*> req "args" <*> req "tail"+    , constructor "FuncCall"  >> return AST_FuncCall  <*> req "args" <*> req "tail"+    ]++instance ObjectClass (AST_RefSuffix Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_RefSuffix Object) where+  haskellDataInterface = interface "RefSuffixExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- | If an expression is inside of a 'ParenExpr', like it usually is after being parsed as part of+-- an @if@ or @while@ statement, this function evaluates the expression to a 'Prelude.Bool' value+-- used to determine if the conditional expression should be 'execute'd.+evalConditional :: ParenExpr Object -> Exec Bool+evalConditional o =+  (execute o :: Exec (Maybe Object)) >>=+    checkVoid (getLocation o) "conditional expression to if statement" >>= derefObject >>=+      execHandleIO [fmap (const False) execIOHandler] . return . not . testNull++-- binary 0x59 +instance B.Binary (ParenExpr Object) MTab where+  put (ParenExpr a b) = B.prefixByte 0x59 $ B.put a >> B.put b+  get = B.word8PrefixTable <|> fail "expecting ParenExpr"++instance B.HasPrefixTable (ParenExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "ParenExpr" 0x59 0x59 $+    [return ParenExpr <*> B.get <*> B.get]++instance Executable (ParenExpr Object) (Maybe Object) where { execute (ParenExpr a _) = execute a }++instance ObjectClass (ParenExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ParenExpr Object) where+  haskellDataInterface = interface "Parentheses" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt+    -- autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Paren Object) where+  toDaoStruct = renameConstructor "Paren" $ ask >>= \o -> case o of+    AST_Paren paren loc -> "inside" .= paren >> putLocation loc++instance FromDaoStructClass (AST_Paren Object) where+  fromDaoStruct = constructor "Paren" >> return AST_Paren <*> req "inside" <*> location++instance ObjectClass (AST_Paren Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Paren Object) where+  haskellDataInterface = interface "ParenthesesExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance B.Binary (IfExpr Object) MTab where+  put (IfExpr a b c) = B.put a >> B.put b >> B.put c+  get = return IfExpr <*> B.get <*> B.get <*> B.get++instance Executable (IfExpr Object) Bool where+  execute (IfExpr ifn thn _) = execNested_ M.empty $+    evalConditional ifn >>= \test -> when test (execute thn) >> return test++instance ObjectClass (IfExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (IfExpr Object) where+  haskellDataInterface = interface "Conditional" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_If Object) where+  toDaoStruct = renameConstructor "Conditional" $ ask >>= \o -> case o of+    AST_If ifn thn loc -> "condition" .= ifn >> "action" .= thn >> putLocation loc++instance FromDaoStructClass (AST_If Object) where+  fromDaoStruct = constructor "Conditional" >>+    return AST_If <*> req "condition" <*> req "action" <*> location++instance ObjectClass (AST_If Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_If Object) where+  haskellDataInterface = interface "ConditionalExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0xB6 +instance B.Binary (ElseExpr Object) MTab where+  put (ElseExpr a b) = B.prefixByte 0xB6 $ B.put a >> B.put b+  get = (B.tryWord8 0xB6 $ return ElseExpr <*> B.get <*> B.get) <|> fail "expecting ElseExpr"++instance Executable (ElseExpr Object) Bool where { execute (ElseExpr ifn _) = execute ifn }++instance ObjectClass (ElseExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ElseExpr Object) where+  haskellDataInterface = interface "Else" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Else Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_Else coms ifn loc -> renameConstructor "ElseIf" $ do+      "comments" .= coms >> "elseIf" .= ifn >> putLocation loc++instance FromDaoStructClass (AST_Else Object) where+  fromDaoStruct = constructor "ElseIf" >>+    return AST_Else <*> req "comments" <*> req "elseIf" <*> location++instance ObjectClass (AST_Else Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Else Object) where+  haskellDataInterface = interface "ElseExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0xBA +instance B.Binary (IfElseExpr Object) MTab where+  put (IfElseExpr a b c d) = B.prefixByte 0xBA $ B.put a >> B.put b >> B.put c >> B.put d+  get = B.word8PrefixTable <|> fail "expecting IfElseExpr"++instance B.HasPrefixTable (IfElseExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "IfElseExpr" 0xBA 0xBA $+    [return IfElseExpr <*> B.get <*> B.get <*> B.get <*> B.get]++instance Executable (IfElseExpr Object) () where+  execute (IfElseExpr ifn elsx final _loc) = do+    let tryEach elsx = case elsx of+          []       -> return False+          els:elsx -> execute els >>= \ok -> if ok then return ok else tryEach elsx+    (execute ifn >>= \ok ->+      if ok then return Nothing+            else tryEach elsx >>= \ok ->+                 if ok then return Nothing+                       else return final) >>= maybe (return ()) execute++instance ObjectClass (IfElseExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (IfElseExpr Object) where+  haskellDataInterface = interface "IfElse" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_IfElse Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_IfElse ifn els block loc -> renameConstructor "If" $ do+      "test" .= ifn >> "alt" .= listToObj els+      maybe (return ()) (void . defObjField "finalElse") block+      putLocation loc++instance FromDaoStructClass (AST_IfElse Object) where+  fromDaoStruct = constructor "If" >>+    return AST_IfElse+      <*> req "test"+      <*> reqList "alt"+      <*> opt "finalElse"+      <*> location++instance ObjectClass (AST_IfElse Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_IfElse Object) where+  haskellDataInterface = interface "IfElseExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary (not prefixed, always occurs within a list)+instance B.Binary (LastElseExpr Object) MTab where+  put (LastElseExpr a loc) = B.put a >> B.put loc+  get = (return LastElseExpr <*> B.get <*> B.get) <|> fail "expecting LastElseExpr"++instance Executable (LastElseExpr Object) () where { execute (LastElseExpr code _) = execute code }++instance ObjectClass (LastElseExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (LastElseExpr Object) where+  haskellDataInterface = interface "FinalElse" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_LastElse Object) where+  toDaoStruct = renameConstructor "LastElse" $ do+    (AST_LastElse coms code loc) <- ask+    "comments" .= coms >> "action" .= code >> putLocation loc++instance FromDaoStructClass (AST_LastElse Object) where+  fromDaoStruct = constructor "LastElse" >>+    return AST_LastElse <*> req "comments" <*> req "action" <*> location++instance ObjectClass (AST_LastElse Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_LastElse Object) where+  haskellDataInterface = interface "FinalElseExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary (not prefixed, always occurs within a list)+instance B.Binary (CatchExpr Object) MTab where+  put (CatchExpr a b loc) = B.put a >> B.put b >> B.put loc+  get = return CatchExpr <*> B.get <*> B.get <*> B.get++instance ObjectClass (CatchExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (CatchExpr Object) where+  haskellDataInterface = interface "CatchExpr" $ do+    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt++-- | Returns the 'Exec' function to be evaluated if the 'ExecControl' matches the 'CatchExpr' type+-- constraint. If the type constraint does not match, this function evaluates to+-- 'Control.Monad.mzero'.+executeCatchExpr :: ExecControl -> CatchExpr Object -> Exec (Exec ())+executeCatchExpr err (CatchExpr (ParamExpr _refd param _) catch _loc) = case param of -- TODO: do something with _refd+  NotTypeChecked name             -> ex name catch+  TypeChecked    name _check _loc -> ex name catch -- TODO: do something with _check+  DisableCheck   name _  _   _    -> ex name catch+  where+    ex name catch = return $ execNested_ M.empty $ localVarDefine name (new err) >> execute catch++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Catch Object) where+  toDaoStruct = ask >>= \ (AST_Catch coms param action loc) -> renameConstructor "Catch" $ do+    "comments" .= coms >> "test" .= param >> "action" .= action >> putLocation loc++instance FromDaoStructClass (AST_Catch Object) where+  fromDaoStruct = constructor "Catch" >>+    return AST_Catch <*> req "comments" <*> req "test" <*> req "action" <*> location++instance ObjectClass (AST_Catch Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Catch Object) where+  haskellDataInterface = interface "CatchExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x85 +instance B.Binary (WhileExpr Object) MTab where+  put (WhileExpr o) = B.prefixByte 0x85 $ B.put o+  get = B.word8PrefixTable <|> fail "expecting WhileExpr"++instance B.HasPrefixTable (WhileExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "WhileExpr" 0x85 0x85 [WhileExpr <$> B.get]++instance Executable (WhileExpr Object) () where+  execute (WhileExpr ifn) = fix $ \loop -> catchLoopCtrl (execute ifn) return >>= flip when loop++instance ObjectClass (WhileExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (WhileExpr Object) where+  haskellDataInterface = interface "While" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_While Object) where+  toDaoStruct = renameConstructor "While" $ ask >>= \ (AST_While o) -> innerToStruct o++instance FromDaoStructClass (AST_While Object) where+  fromDaoStruct = constructor "While" >> AST_While <$> innerFromStruct "Conditional"++instance ObjectClass (AST_While Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_While Object) where+  haskellDataInterface = interface "WhileExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0xA8 0xAF+instance B.Binary (ScriptExpr Object) MTab where+  put o = case o of+    IfThenElse   a           -> B.put a+    WhileLoop    a           -> B.put a+    RuleFuncExpr a           -> B.put a+    EvalObject   a         z -> B.prefixByte 0xA8 $ B.put a >> B.put z+    TryCatch     a     b c z -> B.prefixByte 0xA9 $ B.put a >> B.put b >> B.put c >> B.put z+    ForLoop      a     b c z -> B.prefixByte 0xAA $ B.put a >> B.put b >> B.put c >> B.put z+    ContinueExpr True  b   z -> B.prefixByte 0xAB $ B.put b >> B.put z+    ContinueExpr False b   z -> B.prefixByte 0xAC $ B.put b >> B.put z+    ReturnExpr   True  b   z -> B.prefixByte 0xAD $ B.put b >> B.put z+    ReturnExpr   False b   z -> B.prefixByte 0xAE $ B.put b >> B.put z+    WithDoc      a     b   z -> B.prefixByte 0xAF $ B.put a >> B.put b >> B.put z+  get = B.word8PrefixTable <|> fail "expecting ScriptExpr"++instance B.HasPrefixTable (ScriptExpr Object) B.Byte MTab where+  prefixTable = mconcat $+    [ fmap IfThenElse B.prefixTable+    , fmap WhileLoop  B.prefixTable+    , fmap RuleFuncExpr B.prefixTable+    , B.mkPrefixTableWord8 "ScriptExpr" 0xA8 0xAF $ -- 0x89 0x8A 0x8B 0x8C 0x8D 0x8E 0x8F 0x90+        [ return EvalObject   <*> B.get <*> B.get+        , return TryCatch     <*> B.get <*> B.get <*> B.get <*> B.get+        , return ForLoop      <*> B.get <*> B.get <*> B.get <*> B.get+        , return (ContinueExpr True ) <*> B.get <*> B.get+        , return (ContinueExpr False) <*> B.get <*> B.get+        , return (ReturnExpr   True ) <*> B.get <*> B.get+        , return (ReturnExpr   False) <*> B.get <*> B.get+        , return WithDoc      <*> B.get <*> B.get <*> B.get+        ]+    ]++-- | Convert a single 'ScriptExpr' into a function of value @'Exec' 'Object'@.+instance Executable (ScriptExpr Object) () where+  execute script = errCurrentModule $ errLocation script $ case script of+    IfThenElse   ifn    -> execute ifn+    WhileLoop    ifn    -> execute ifn+    EvalObject   o _loc -> execute (DerefAssignExpr o) >>= return . maybe () (`seq` ())+    RuleFuncExpr rulfn  -> do+      o <- execute rulfn -- this 'execute' handles function expressions+      let dyn o = case o of+            OHaskell (Hata _ h) -> fromDynamic h+            _ -> Nothing+      let getObj :: (ObjectClass o, Typeable o) => Exec o+          getObj = mplus (xmaybe $ o >>= dyn) $ case o of+            Nothing -> fail "RuleFuncExpr evaluated to void"+            Just  o -> throwBadTypeError "RuleFuncExpr evaluated to object of incorrect data type" o []+      let fsub sub = modify $ \xunit -> xunit{currentCodeBlock=Just sub}+      sub <- gets currentCodeBlock+      case sub of+        Nothing  -> case rulfn of+          LambdaExpr{} -> getObj >>= \o ->+            modify $ \xunit -> xunit{ lambdaSet = lambdaSet xunit ++ o }+          RuleExpr{}   -> do+            newtree <- getObj >>= \p -> execute (p::PatternRule)+            modify $ \xunit -> xunit{ ruleSet=T.unionWith (++) (ruleSet xunit) newtree }+          FuncExpr{}   -> return ()+            -- function expressions are placed in the correct store by the above 'execute'+        Just sub -> case rulfn of+          LambdaExpr{} -> getObj >>= \o -> fsub $ sub{ staticLambdas = staticLambdas sub ++ o }+          RuleExpr{}   -> do+            newtree <- getObj >>= \p -> execute (p::PatternRule)+            fsub $ sub{ staticRules=T.unionWith (++) (staticRules sub) newtree }+          FuncExpr{}   -> return ()+            -- function expressions are placed in the correct store by the above 'execute'+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    TryCatch try els catchers _loc -> do+      ce <- catchPredicate $ execNested_ M.empty (execute try) <|> msum (fmap execute els)+      case ce of+        OK     () -> return ()+        Backtrack -> mzero+        PFail err -> case err of+          ExecReturn{} -> predicate ce+          ExecError{execErrorSubtype=ExecLoopCtrl{}} -> predicate ce+          ExecError{}  -> join $ msum $ fmap (executeCatchExpr err) catchers+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    ForLoop varName inObj thn _loc -> do+      let run = void $ execute thn+      let readIter   o = execNested_ (M.singleton varName o) run+      let updateIter o = M.lookup varName . snd <$> execNested (maybe M.empty (M.singleton varName) o) run+      let readLoop   o = void $ readForLoop o readIter+      let updateLoop qref o = void $ fmap snd $+            updateForLoop o updateIter >>= referenceUpdate qref False . const . return . Just+      errLocation inObj $ execute inObj >>= maybeDerefObject >>= \ (qref, iter) -> case iter of+        Nothing   -> fail "iterator of for-loop expression evaluated to void"+        Just iter -> case qref of+          Nothing   -> void $ readLoop iter+          Just qref -> case iter of+            OHaskell (Hata ifc _) -> case objUpdateIterable ifc of+              Just  _ -> void $ updateLoop qref iter+              Nothing -> case objReadIterable ifc of+                Just  _ -> void $ readLoop iter+                Nothing -> throwBadTypeError "data type not iterable" iter [(errOfReference, obj qref)]+            _                     -> void $ updateLoop qref iter+      -- NOTE: the for loop iterator IS NOT passed to the 'referenceUpdate' function to be+      -- evaluated. This is to avoid introducing deadlocks in data types that may store their values+      -- in an MVar. The 'referenceLookup' function first evaluates the reference, creating a copy+      -- in the current thread, the for loop is evaluated, and THEN the 'referenceUpdate' function+      -- is evaluated, in those three discrete steps.  It is not possible to evaluate a for loop in+      -- the dao programming language as an atomic action, so race conditions may occur when+      -- updating MVars -- but deadlocks will not occur.+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    ContinueExpr a    test   _loc -> do+      test <- execute test+      let signal = execThrow "" (loopCtrl a) []+      case test of+        Nothing -> signal+        Just  o -> derefObject o >>= execute . objToBool >>= flip when signal+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    ReturnExpr returnStmt o _loc -> do+      o <- (execute o :: Exec (Maybe Object)) >>= maybe (return Nothing) (fmap Just . derefObject)+      if returnStmt then throwError (ExecReturn o) else maybe mzero (flip (execThrow "") [] . ExecThrow) o+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    WithDoc   expr   thn    _loc -> execute expr >>=+      checkVoid (getLocation expr) "target of \"with\" statement" >>=+        flip execWithWithRefStore (execute thn)+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --++instance ObjectClass (ScriptExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ScriptExpr Object) where+  haskellDataInterface = interface "Script" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++localVarDefine :: Name -> Object -> Exec (Maybe Object)+localVarDefine name o = fmap (snd . fst) $+  runObjectFocus (updateLocal name NullRef $ modify (const $ Just o) >> get) False (reference UNQUAL name) ()++localVarUpdate :: Name -> (Maybe Object -> Maybe Object) -> Exec (Maybe Object)+localVarUpdate name f = fmap (snd . fst) $+  runObjectFocus (updateLocal name NullRef $ modify f >> get) False (reference UNQUAL name) ()++localVarLookup :: Name -> Exec Object+localVarLookup name = +  (snd . fst) <$> runObjectFocus (updateLocal name NullRef get) True (reference UNQUAL name) () >>=+    maybe mzero return++-- | Like evaluating 'execute' on a value of 'Reference', except the you are evaluating an+-- 'Object' type. If the value of the 'Object' is not constructed with+-- 'ORef', the object value is returned unmodified.+derefObject :: Object -> Exec Object+derefObject = fmap snd . derefObjectGetReference++-- | Like 'derefObject' but also returns the 'Reference' value that was stored in the 'Object' that+-- was dereferenced, along with the dereferenced value. If the 'Object' is not constructed with+-- 'ORef', 'Prelude.Nothing' is returned instead of a 'Reference'.+derefObjectGetReference :: Object -> Exec (Maybe Reference, Object)+derefObjectGetReference o = maybeDerefObject (Just o) >>= \ (r, derefd) -> case derefd of+  Nothing -> case r of+    Nothing -> throwBadTypeError "dereferenced a non-reference value" o []+    Just  r -> execThrow "reference evaluated to void" r [(errOfReference, o)]+  Just derefd -> return (r, derefd)++-- | Tries to dereference an 'Object'. If the 'Object' is an 'ORef' constructed 'Reference', the+-- reference is de-referenced, which may evaluate to 'Prelude.Nothing'. The dereferenced value is+-- returned in the 'Prelude.snd' of the pair. If the given 'Object' is an 'ORef', regardless of the+-- dereferenced value, the 'Reference' is returned in the 'Prelude.fst' of the pair. If the given+-- 'Object' is not an 'ORef' constructed 'Object', it is returned unmodified along with+-- 'Prelude.Nothing' in the 'Prelude.fst' of the pair.+maybeDerefObject :: Maybe Object -> Exec (Maybe Reference, Maybe Object)+maybeDerefObject = maybe (return (Nothing, Nothing)) $ \o -> case o of+  ORef r -> referenceLookup r >>= \ (r, o) -> case o of+    Nothing -> return (Just r, Nothing)+    Just  o -> return (Just r, Just o)+  o      -> return (Nothing, Just o)++----------------------------------------------------------------------------------------------------++-- | This data type instantates the 'execute' function for use in for-loop expressions.+data ForLoopBlock = ForLoopBlock Name Object (CodeBlock Object)++instance Executable ForLoopBlock (Bool, Maybe Object) where+  execute (ForLoopBlock name o block) = +    execNested_ (M.singleton name o) $ loop (codeBlock block) where+      done cont = do+        ref <- gets execStack+        newValue <- return $ M.lookup name $ head $ mapList ref+        return (cont, newValue)+      loop ex = case ex of+        []   -> done True+        e:ex -> case e of+          ContinueExpr a cond _loc -> case cond of+            EvalExpr (ObjArithExpr (ObjectExpr VoidExpr)) -> done a+            cond -> execute cond >>= maybe err (execute . objToBool) >>= done . (if a then id else not) where+              err = fail "expression does not evaluate to boolean"+          e -> execute e >> loop ex++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Script Object) where+  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of+    AST_Comment      a           -> nm "Comment" $ putComments a+    AST_IfThenElse   a           -> innerToStruct a+    AST_WhileLoop    a           -> innerToStruct a+    AST_RuleFunc     a           -> innerToStruct a+    AST_EvalObject   a b     loc -> nm "ObjectExpr" $ "expr" .= a >> putComments b >> putLocation loc+    AST_TryCatch     a b c d loc -> nm "TryCatch" $ do+      "comments" .= a >> "tryBlock" .= b >> "elseBlocks" .= listToObj c+      "catchBlocks" .= listToObj d >> putLocation loc+    AST_ForLoop      a b c loc -> nm "ForLoop" $ do+      "varName" .= a >> "iterate" .= b >> "block" .= c >> putLocation loc+    AST_ContinueExpr a b c     loc -> nm (if a then "Continue" else "Break") $ do+      putComments b >> "condition" .= c >> putLocation loc+    AST_ReturnExpr   a b       loc -> nm (if a then "Return" else "Throw") $ do+      "expr" .= b >> putLocation loc+    AST_WithDoc      a b       loc -> nm "WithDoc" $ "expr" .= a >> "block" .= b >> putLocation loc++instance FromDaoStructClass (AST_Script Object) where+  fromDaoStruct = msum $+    [ constructor "Comment" >> AST_Comment <$> comments+    , AST_IfThenElse <$> fromDaoStruct+    , AST_WhileLoop  <$> fromDaoStruct+    , AST_RuleFunc   <$> fromDaoStruct+    , constructor "ObjectExpr" >> return AST_EvalObject <*> req "expr" <*> comments <*> location+    , constructor "TryCatch" >>+        return AST_TryCatch+          <*> comments+          <*> req "tryBlock"+          <*> reqList "elseBlocks"+          <*> reqList "catchBlocks"+          <*> location+    , constructor "ForLoop" >>+        return AST_ForLoop <*> req "varName" <*> req "iterate" <*> req "block" <*> location+    , constructor "Continue" >>+        return (AST_ContinueExpr True ) <*> comments <*> req "condition" <*> location+    , constructor "Break" >>+        return (AST_ContinueExpr False) <*> comments <*> req "condition" <*> location+    , constructor "Return" >> return (AST_ReturnExpr True ) <*> req "expr" <*> location+    , constructor "Throw"  >> return (AST_ReturnExpr False) <*> req "expr" <*> location+    , constructor "WithDoc" >> return AST_WithDoc <*> req "expr" <*> req "block" <*> location+    ]++instance ObjectClass [AST_Script Object] where { obj=listToObj; fromObj=listFromObj; }++instance ObjectClass (AST_Script Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Script Object) where+  haskellDataInterface = interface "ScriptExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x86 +instance B.Binary (ObjListExpr Object) MTab where+  put (ObjListExpr lst loc) = B.prefixByte 0x86 $ B.putUnwrapped lst >> B.put loc+  get = (B.tryWord8 0x86 $ return ObjListExpr <*> B.getUnwrapped <*> B.get) <|> fail "expecting ObjListExpr"++instance Executable (ObjListExpr Object) [Object] where+  execute (ObjListExpr exprs _) = forM (zip exprs [1..]) $ \ (a, i) -> execute a >>= maybe (err i) return where+    err i = execThrow "item in list literal expression evaluates to void" ExecErrorUntyped [(argNum, obj (i::Int))]++instance PPrintable (ObjListExpr Object) where { pPrint = pPrintInterm }++instance ObjectClass (ObjListExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ObjListExpr Object) where+  haskellDataInterface = interface "ListLiteral" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_ObjList Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_ObjList coms lst loc -> renameConstructor "ListLiteralExpression" $ do+      putComments coms >> defObjField "items" (listToObj lst) >> putLocation loc++instance FromDaoStructClass (AST_ObjList Object) where+  fromDaoStruct = constructor "ListLiteralExpression" >>+    return AST_ObjList <*> comments <*> reqList "items" <*> location++instance ObjectClass (AST_ObjList Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_ObjList Object) where+  haskellDataInterface = interface "ListLiteralExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance B.Binary (OptObjListExpr Object) MTab where+  put (OptObjListExpr o) = B.put o+  get = OptObjListExpr <$> B.get++instance Executable (OptObjListExpr Object) [Object] where+  execute (OptObjListExpr lst) = maybe (return []) execute lst++instance ObjectClass (OptObjListExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (OptObjListExpr Object) where+  haskellDataInterface = interface "OptionalListLiteral" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++-- | Evaluate an 'Exec', but if it throws an exception, set record an 'ObjectExpr' where+-- the exception occurred in the exception information.+updateExecError :: (ExecControl -> ExecControl) -> Exec a -> Exec a+updateExecError upd fn = catchError fn (\err -> throwError (upd err))++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_OptObjList Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_OptObjList coms o -> renameConstructor "OptObjList" $ "params" .=? o >> putComments coms++instance FromDaoStructClass (AST_OptObjList Object) where+  fromDaoStruct = constructor "OptObjList" >> return AST_OptObjList <*> comments <*> opt "params"++instance ObjectClass (AST_OptObjList Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_OptObjList Object) where+  haskellDataInterface = interface "OptionalListLiteralExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance B.Binary (LiteralExpr Object) MTab where+  put (LiteralExpr a loc) = B.put a >> B.put loc+  get = B.word8PrefixTable <|> fail "expecting LiteralExpr"++instance B.HasPrefixTable (LiteralExpr Object) B.Byte MTab where+  prefixTable = B.bindPrefixTable B.prefixTable $ \o -> LiteralExpr o <$> B.get++instance Executable (LiteralExpr Object) (Maybe Object) where { execute (LiteralExpr o _) = return (Just o) }++instance ObjectClass (LiteralExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (LiteralExpr Object) where+  haskellDataInterface = interface "Literal" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> defDeref execute++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Literal Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_Literal o loc -> renameConstructor "Literal" $ "obj" .= o >> putLocation loc++instance FromDaoStructClass (AST_Literal Object) where+  fromDaoStruct = constructor "Literal" >> return AST_Literal <*> req "obj" <*> location++instance ObjectClass (AST_Literal Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Literal Object) where+  haskellDataInterface = interface "LiteralExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x3C 0x42 ReferenceExpr-->Reference+instance B.Binary (ReferenceExpr Object) MTab where+  put qref = case qref of+    ReferenceExpr q n r loc -> prefix q $ B.put n >> B.put r >> B.put loc where+      prefix q = B.prefixByte $ case q of+        { UNQUAL -> 0x48; LOCAL -> 0x49; CONST -> 0x4A; STATIC -> 0x4B; GLOBAL -> 0x4C; GLODOT -> 0x4D; }+    RefObjectExpr o r loc -> B.putWord8 0x4E >> B.put o >> B.put r >> B.put loc+  get = B.word8PrefixTable <|> fail "expecting Reference"++instance B.HasPrefixTable (ReferenceExpr Object) Word8 MTab where+  prefixTable = B.mkPrefixTableWord8 "ReferenceExpr" 0x48 0x4E $+    [ f UNQUAL, f LOCAL, f CONST, f STATIC, f GLOBAL, f GLODOT+    , return RefObjectExpr <*> B.get <*> B.get <*> B.get+    ] where { f q = return (ReferenceExpr q) <*> B.get <*> B.get <*> B.get }++instance Executable (ReferenceExpr Object) (Maybe Object) where+  execute qref = errLocation qref $ case qref of+    RefObjectExpr o NullRefExpr _ -> execute o+    RefObjectExpr o suf _ -> do+      o <- execute o >>=+        checkVoid (getLocation o) "function call on item in parentheses which evaluated to a void value"+      suf <- execute suf+      return $ Just $ obj $ RefObject o suf+    ReferenceExpr q ref suf _loc -> execute suf >>= return . Just . ORef . Reference q ref++instance ObjectClass (ReferenceExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ReferenceExpr Object) where+  haskellDataInterface = interface "ReferenceLiteral" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt+    defDeref (execute >=> fmap snd . maybeDerefObject)++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Reference Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_RefObject o           ref loc -> renameConstructor "ParenExpr" $ do+      "paren" .= o >> "suffix" .= ref >> putLocation loc+    AST_Reference  q coms name ref loc -> renameConstructor "Reference" $ do+      "qualifier" .= q >> putComments coms >> "name" .= name >> "suffix" .= ref >> putLocation loc++instance FromDaoStructClass (AST_Reference Object) where+  fromDaoStruct = msum $+    [ constructor "ParenExpr" >>+        return AST_RefObject <*> req "paren" <*> req "suffix" <*> location+    , constructor "Reference" >>+        return AST_Reference <*> req "qualifier"+          <*> comments <*> req "name" <*> req "suffix" <*> location+    ]++instance ObjectClass (AST_Reference Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Reference Object) where+  haskellDataInterface = interface "ReferenceExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct+    defDeref (msum . map (execute >=> fmap snd . maybeDerefObject) . toInterm)++----------------------------------------------------------------------------------------------------++-- binary 0x52 0x53+instance B.Binary (RefPrefixExpr Object) MTab where+  put o = case o of+    PlainRefExpr  a     -> B.put a+    RefPrefixExpr a b z -> let f = B.put b >> B.put z in case a of+      REF   -> B.prefixByte 0x52 f+      DEREF -> B.prefixByte 0x53 f+  get = B.word8PrefixTable <|> fail "expecting RefPrefixExpr"++instance B.HasPrefixTable (RefPrefixExpr Object) B.Byte MTab where+  prefixTable = fmap PlainRefExpr B.prefixTable <>+    (B.mkPrefixTableWord8 "RefPrefixExpr" 0x52 0x53 $+      let f q = return (RefPrefixExpr q) <*> B.get <*> B.get in [f REF, f DEREF])++instance Executable (RefPrefixExpr Object) (Maybe Object) where+  execute ref = errLocation ref $ case ref of+    PlainRefExpr     ref     -> execute ref+    RefPrefixExpr op ref loc -> case op of+      REF   -> do+        ref <- execute ref >>= checkVoid loc "operand of referencing operator ($)"+        case ref of+          ORef ref -> return $ Just $ ORef $ RefWrapper ref+          ref      -> return $ Just $ ORef $ RefObject ref NullRef+      DEREF -> execute ref >>= checkVoid loc "operand of dereferencing operator (@)" >>=+        fmap Just . derefObject++instance ObjectClass (RefPrefixExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (RefPrefixExpr Object) where+  haskellDataInterface = interface "RefPrefixLiteral" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_RefPrefix Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_PlainRef  a         -> renameConstructor "PlainRef" $ "ref" .= a >> return ()+    AST_RefPrefix a b c loc -> renameConstructor "RefPrefix" $ do+      "op" .= a >> putComments b >> "expr" .= c >> putLocation loc++instance FromDaoStructClass (AST_RefPrefix Object) where+  fromDaoStruct = msum $+    [ constructor "RefPrefix" >>+        return AST_RefPrefix <*> req "op" <*> req "expr" <*> req "expr" <*> location+    , constructor "PlainRef" >> AST_PlainRef <$> req "ref"+    ]++instance ObjectClass (AST_RefPrefix Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_RefPrefix Object) where+  haskellDataInterface = interface "ReferencePrefixExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x74 0x76+instance B.Binary (RuleFuncExpr Object) MTab where+  put o = case o of+    LambdaExpr a b   z -> B.prefixByte 0x74 $ B.put a >> B.put b >> B.put z+    FuncExpr   a b c z -> B.prefixByte 0x75 $ B.put a >> B.put b >> B.put c >> B.put z+    RuleExpr   a b   z -> B.prefixByte 0x76 $ B.put a >> B.put b >> B.put z+  get = B.word8PrefixTable <|> fail "expecting RuleFuncExpr"++instance B.HasPrefixTable (RuleFuncExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "RuleFuncExpr" 0x74 0x76 $+    [ return LambdaExpr <*> B.get <*> B.get <*> B.get+    , return FuncExpr   <*> B.get <*> B.get <*> B.get <*> B.get+    , return RuleExpr   <*> B.get <*> B.get <*> B.get+    ]++instance Executable (RuleFuncExpr Object) (Maybe Object) where+  execute o = case o of+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    LambdaExpr params script _ -> do+      let exec = setupCodeBlock script+      return $ Just $ new $+        [CallableCode{argsPattern=params, codeSubroutine=exec, returnType=nullValue}]+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    FuncExpr name params script _ -> do+      let exec = setupCodeBlock script+      let callableCode = CallableCode{argsPattern=params, codeSubroutine=exec, returnType=nullValue}+      localVarUpdate name $ \o -> case o>>=fromObj of+        Nothing -> Just $ obj [callableCode]+        Just cc -> Just $ obj $ cc++[callableCode]+      return (Just $ obj [callableCode])+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    RuleExpr rs script _ -> do+      let sub = setupCodeBlock script+      pats <- execute rs+      return $ Just $ obj $ PatternRule{ rulePatterns=pats, ruleAction=sub }+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --++instance ObjectClass (RuleFuncExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (RuleFuncExpr Object) where+  haskellDataInterface = interface "FunctionLiteral" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_RuleFunc Object) where+  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of+    AST_Lambda a b     loc -> nm "Lambda"   $ "params" .= a >> "block" .= b >> putLocation loc+    AST_Func   a b c d loc -> nm "Function" $+      putComments a >> "name"  .= b >> "params" .= c >> "block" .= d >> putLocation loc+    AST_Rule   a b     loc -> nm "Rule" $ "params" .= a >> "block" .= b >> putLocation loc++instance FromDaoStructClass (AST_RuleFunc Object) where+  fromDaoStruct = msum $+    [ constructor "Lambda" >> return AST_Lambda <*> req "params" <*> req "block"  <*> location+    , constructor "Function" >>+        return AST_Func <*> comments <*> req "name" <*> req "params" <*> req "block" <*> location+    , constructor "Rule" >> return AST_Rule <*> req "params" <*> req "block" <*> location+    ]++instance ObjectClass (AST_RuleFunc Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_RuleFunc Object) where+  haskellDataInterface = interface "FunctionLiteralExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x60 0x65+instance B.Binary (ObjectExpr Object) MTab where+  put o = case o of+    ObjSingleExpr   a       -> B.put a+    ObjLiteralExpr  a       -> B.put a+    VoidExpr                -> B.putWord8   0x60+    ArithPfxExpr    a b   z -> B.prefixByte 0x61 $ B.put a >> B.put b >> B.put z+    InitExpr        a b c z -> B.prefixByte 0x62 $ B.put a >> B.put b >> B.put c >> B.put z+    StructExpr      a b   z -> B.prefixByte 0x63 $ B.put a >> B.put b >> B.put z+    MetaEvalExpr    a     z -> B.prefixByte 0x64 $ B.put a >> B.put z+  get = B.word8PrefixTable <|> fail "expecting ObjectExpr"++instance B.HasPrefixTable (ObjectExpr Object) B.Byte MTab where+  prefixTable = mconcat $+    [ ObjLiteralExpr  <$> B.prefixTable+    , ObjSingleExpr   <$> B.prefixTable+    , B.mkPrefixTableWord8 "ObjectExpr" 0x60 0x64 $+        [ return VoidExpr+        , return ArithPfxExpr <*> B.get <*> B.get <*> B.get+        , return InitExpr     <*> B.get <*> B.get <*> B.get <*> B.get+        , return StructExpr   <*> B.get <*> B.get <*> B.get+        , return MetaEvalExpr <*> B.get <*> B.get+        ]+    ]++instance Executable (ObjectExpr Object) (Maybe Object) where+  execute o = errLocation o $ case o of+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    VoidExpr -> return Nothing+      -- 'VoidExpr's only occur in return statements. Returning 'ONull' where nothing exists is+      -- probably the most intuitive thing to do on an empty return statement.+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    ObjLiteralExpr  o -> execute o+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    ObjSingleExpr   o -> execute o+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    ArithPfxExpr op expr loc -> do+      expr <- execute expr >>= fmap snd . maybeDerefObject >>=+        checkVoid loc ("operand to prefix operator "++show op)+      execute $ fmap Just (evalArithPrefixOp op expr)+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    InitExpr ref bnds initMap _ -> Just <$> _evalInit (dotLabelToRefExpr ref) bnds initMap+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    StructExpr name (OptObjListExpr items) _ -> case items of+      Nothing -> return (Just $ OTree $ Nullary{ structName=name })+      Just (ObjListExpr items _) -> execNested_ M.empty $ do+        forM_ items $ \item -> case item of +          AssignExpr{} -> execute item -- fill the local stack by executing each assignment+          _            -> fail "struct initializer is not an assignment expression"+        stack <- gets execStack+        let items = head $ mapList stack+        return $ Just $ OTree $+          if M.null items+          then Nullary{ structName=name }+          else Struct{ fieldMap=items, structName=name }+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    MetaEvalExpr expr _ -> return $ Just $ new expr+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --++_evalInit :: ReferenceExpr Object -> OptObjListExpr Object -> ObjListExpr Object -> Exec Object+_evalInit ref bnds initMap = do+  ref <- execute ref >>= checkVoid (getLocation ref) "initializer label"+  ref <- case ref of+    ORef (Reference UNQUAL name NullRef) -> pure name+    ref -> throwBadTypeError "cannot use reference as initalizer" ref []+  bnds <- execute bnds >>= mapM derefObject+  let cantUseBounds msg =+        execThrow ("initializer "++msg++" must be defined without bounding parameters")+          ExecErrorUntyped [(assertFailed, OList bnds)]+  let list = case bnds of+        [] -> execNested_ M.empty $ fmap OList $ execute initMap >>= mapM derefObject+        _  -> cantUseBounds "for list constructor"+  let (ObjListExpr items _) = initMap+  let dict = case bnds of+        [] -> (ODict . snd) <$> execNested M.empty (mapM_ assignUnqualifiedOnly items)+        _  -> cantUseBounds "for dict constructor"+  case uchars ref of+    "list"       -> list+    "List"       -> list+    "dict"       -> dict+    "Dict"       -> dict+    "Dictionary" -> dict+    _ -> do+      tab <- execGetObjTable ref+      let qref = Reference UNQUAL ref NullRef+      case tab of+        Nothing  -> execThrow "unknown object constructor" qref []+        Just tab -> execNested_ M.empty $ case objInitializer tab of+          Nothing           -> execThrow "cannot declare constant object of type" qref []+          Just (init, fold) -> do+            o     <- init bnds+            items <- forM items $ \item -> case item of+              AssignExpr a op b _ -> do+                a <- execute a >>= checkVoid (getLocation a) "left-hand side of initializer assignemt"+                b <- execute b >>= checkVoid (getLocation b) "right-hand side of initializer assignment" >>= derefObject+                return $ InitAssign a op b+              EvalExpr arith -> fmap InitSingle $+                execute arith >>= checkVoid (getLocation arith) "initializer item"+            OHaskell . Hata tab <$> fold o items++instance ObjectClass (ObjectExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ObjectExpr Object) where+  haskellDataInterface = interface "ObjectLiteral" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt+    defDeref execute >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Object Object) where+  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of+    AST_Void                   -> makeNullary "Void"+    AST_ObjLiteral   a         -> innerToStruct a+    AST_ObjSingle    a         -> innerToStruct a+    AST_ArithPfx     a b c loc -> nm "ArithPrefix" $ do+      "op" .= a >> putComments b >> "expr" .= c >> putLocation loc+    AST_Init         a b c loc -> nm "Init" $ do+      "name" .= a >> "params" .= b >> "initList" .= c >> putLocation loc+    AST_Struct       a b   loc -> nm "Struct" $ "name" .= a >> "initList" .= b >> putLocation loc+    AST_MetaEval     a     loc -> nm "MetaEval" $ "block" .= a >> putLocation loc++instance FromDaoStructClass (AST_Object Object) where+  fromDaoStruct = msum $+    [ nullary "Void" >> return AST_Void+    , AST_ObjLiteral  <$> fromDaoStruct+    , AST_ObjSingle   <$> fromDaoStruct+    , constructor "ArithPrefix" >>+        pure AST_ArithPfx <*> req "op" <*> comments <*> req "expr" <*> location+    , constructor "Init" >>+        pure AST_Init     <*> req "name" <*> req "params" <*> req "initList" <*> location+    , constructor "Struct" >> pure AST_Struct <*> req "name" <*> req "initList" <*> location+    , constructor "MetaEval" >> pure AST_MetaEval <*> req "block" <*> location+    ]++instance ObjectClass (AST_Object Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Object Object) where+  haskellDataInterface = interface "ObjectLiteralExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x6A +instance B.Binary (ArithExpr Object) MTab where+  put o = case o of+    ObjectExpr  a     -> B.put a+    ArithExpr a b c z -> B.prefixByte 0x6A $ B.put a >> B.put b >> B.put c >> B.put z+  get = B.word8PrefixTable <|> fail "expecting arithmetic expression"++instance B.HasPrefixTable (ArithExpr Object) B.Byte MTab where+  prefixTable = mappend (ObjectExpr <$> B.prefixTable) $+    B.mkPrefixTableWord8 "ArithExpr" 0x6A 0x6A $+      [pure ArithExpr <*> B.get <*> B.get <*> B.get <*> B.get]++instance Executable (ArithExpr Object) (Maybe Object) where+  execute o = case o of+    ObjectExpr o -> execute o+    ArithExpr left' op right' loc -> do+      let err1 msg = msg++"-hand operand of "++show op++ "operator "+          evalLeft   = execute left'  >>= checkVoid loc (err1 "left" )+          evalRight  = execute right' >>= checkVoid loc (err1 "right")+          derefLeft  = evalLeft  >>= derefObject+          derefRight = evalRight >>= derefObject+          logical isAndOp = fmap Just $ do+            left <- derefLeft >>= execute . objToBool+            if left+              then  if isAndOp then derefRight else return OTrue+              else  if isAndOp then return ONull else derefRight+      case op of+        AND -> logical True+        OR  -> logical False+        op  -> do+          (left, right) <- case op of+            ARROW -> liftM2 (,) derefLeft evalRight+            _     -> liftM2 (,) derefLeft derefRight+          execute (fmap Just $ evalInfixOp op left right)++instance ObjectClass (ArithExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ArithExpr Object) where+  haskellDataInterface = interface "Arithmetic" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt+    defDeref execute >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Arith Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_Object a         -> innerToStruct a+    AST_Arith  a b c loc -> renameConstructor "Arithmetic" $ do+      "left" .= a >> "op" .= b >> "right" .= c >> putLocation loc++instance FromDaoStructClass (AST_Arith Object) where+  fromDaoStruct = msum $+    [ AST_Object <$> fromDaoStruct+    , constructor "Arithmetic" >>+        pure AST_Arith <*> req "left" <*> req "op" <*> req "right" <*> location+    ]++instance ObjectClass (AST_Arith Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Arith Object) where+  haskellDataInterface = interface "ArithmeticExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++newtype DerefAssignExpr = DerefAssignExpr (AssignExpr Object)+-- ^ This data type instantiates 'Executable' such that the result is always dereference once. This+-- is necessary because an 'AssignExpr' always evaluates to an 'Object' literal expression, meaning+-- if the 'AssignExpr' contains  'ReferenceExpr', it will evaluate to an 'Object' constructing a+-- literal 'Reference' (using the 'ORef' constructor). Sometimes this is desirable, sometimes it is+-- not. It is desirable when evaluating arguments for a function call that requests it's arguments+-- not be dereferenced. It is not desirable when evaluating an arithmetic equation and the integer+-- value stored at a 'Reference' variable is required, and not the 'Reference' value itself.+--     The calling context cannot know what the result will be, or whether or not it is necessary to+-- call 'derefObject' on the result unless the calling context inspects the 'AssignExpr' value with+-- a case statement. By wrapping the 'AssignExpr' in this data type first and then evaluating+-- 'execute', you are guranteed that any 'ReferenceExpr' will evaluate to the value stored at the+-- resulting 'Reference' literal, and not the 'Reference' literal itself.++instance Executable DerefAssignExpr (Maybe Object) where+  execute (DerefAssignExpr o) = case o of+    EvalExpr{}   -> execute o >>= fmap snd . maybeDerefObject+    AssignExpr{} -> execute o++_executeAssignExpr+  :: (Reference -> UpdateOp -> Object -> Exec (Maybe Object))+  -> AssignExpr Object -> Exec (Maybe Object)+_executeAssignExpr update o = case o of+  EvalExpr           expr     -> execute expr+  AssignExpr qref op expr loc -> do+    qref <- execute qref >>=+      checkVoid (getLocation qref) "left-hand side of assignment expression evaluated to void"+    case qref of+      ORef qref -> do+        newObj <- execute expr >>= checkVoid loc "right-hand side of assignment" >>= derefObject +        update qref op newObj+      _    -> fail "left-hand side of assignment expression is not a reference value"++-- binary 0x6F +instance B.Binary (AssignExpr Object) MTab where+  put o = case o of+    EvalExpr   a       -> B.put a+    AssignExpr a b c z -> B.prefixByte 0x6F $ B.put a >> B.put b >> B.put c >> B.put z+  get = B.word8PrefixTable <|> fail "expecting AssignExpr"++instance B.HasPrefixTable (AssignExpr Object) B.Byte MTab where+  prefixTable = mappend (EvalExpr <$> B.prefixTable) $+    B.mkPrefixTableWord8 "AssignExpr" 0x6F 0x6F $+      [pure AssignExpr <*> B.get <*> B.get <*> B.get <*> B.get]++instance Executable (AssignExpr Object) (Maybe Object) where+  execute = _executeAssignExpr $ \qref op newObj ->+    snd <$> referenceUpdate qref (op/=UCONST) (evalUpdateOp (Just qref) op newObj)++-- | This function works a bit like how 'execute' works on an 'AssignExpr' data type, but every+-- assignment is checked to make sure it is local or unqualified. Furthurmore, all assignments are+-- forced into the top of the local variable stack, already-defined vairables at higher points in+-- the local variable stack are not updated in place. This function is used to define items in+-- is one important difference: it is specifically modified to work for evaluation of 'InitExpr'+-- data types, for example in the Dao language expression: @a = dict {a=1, b=2};@ Using this+-- function instead of 'execute' will always assign variables in the top of the local variable+-- stack, regardless of whether the variable has been defined before. This makes it possible to+-- write Dao language statements like this: @a=1; a = dict {a=a, b=2};@ which would create a+-- dictionary @a = dict {a=1, b=2};@, because before the "dict{}" expression, "a" had a value of 1.+assignUnqualifiedOnly :: AssignExpr Object -> Exec (Maybe Object)+assignUnqualifiedOnly = _executeAssignExpr $ \qref op newObj -> case qref of+  Reference UNQUAL r NullRef -> do+    store <- gets execStack+    let oldObj = stackLookup r store+    newObj <- evalUpdateOp (Just qref) op newObj oldObj+    (result, store) <- pure $ stackUpdateTop (const (newObj, newObj)) r store+    modify $ \xunit -> xunit{ execStack = store }+    return result+  _ -> execThrow "assignment must be unqualified" ExecErrorUntyped [(errOfReference, obj qref)]++instance ObjectClass (AssignExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AssignExpr Object) where+  haskellDataInterface = interface "Assignment" $ do+    autoDefNullTest >> autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt+    defDeref execute >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_Assign Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_Eval o ->  innerToStruct o+    AST_Assign to op from loc -> renameConstructor "Assign" $ do+      "to" .= to >> "op" .= op >> "from" .= from >> putLocation loc++instance FromDaoStructClass (AST_Assign Object) where+  fromDaoStruct = msum $+    [ AST_Eval <$> fromDaoStruct+    , pure AST_Assign <*> req "to" <*> req "op" <*> req "from" <*> location+    ]++instance ObjectClass (AST_Assign Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_Assign Object) where+  haskellDataInterface = interface "AssignmentExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance B.Binary (ObjTestExpr Object) MTab where+  put o = case o of+    ObjArithExpr      a -> B.put a+    ObjTestExpr a b c d -> B.prefixByte 0x73 $ B.put a >> B.put b >> B.put c >> B.put d+    ObjRuleFuncExpr a       -> B.put a+  get = B.word8PrefixTable <|> fail "expecting ObjTestExpr"++instance B.HasPrefixTable (ObjTestExpr Object) Word8 MTab where+  prefixTable = mconcat $ +    [ ObjArithExpr <$> B.prefixTable+    , ObjRuleFuncExpr <$> B.prefixTable+    , B.mkPrefixTableWord8 "ObjTestExpr" 0x73 0x73 $+        [return ObjTestExpr <*> B.get <*> B.get <*> B.get <*> B.get]+    ]++instance Executable (ObjTestExpr Object) (Maybe Object) where+  execute o = errCurrentModule $ case o of+    ObjArithExpr      a -> execute a+    ObjTestExpr a b c _ ->+      execute a >>= checkVoid (getLocation a) "conditional expression evaluates to void" >>= derefObject >>=+        execute . objToBool >>= \ok -> if ok then execute b else execute c+    ObjRuleFuncExpr o -> execute o++instance ObjectClass (ObjTestExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (ObjTestExpr Object) where+  haskellDataInterface = interface "ObjectTest" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_ObjTest Object) where+  toDaoStruct = ask >>= \o -> case o of+    AST_ObjArith  a -> innerToStruct a+    AST_ObjTest a b c d e f -> renameConstructor "ObjTest" $ do+      "condition" .= a+      "quesMarkComs" .= b >> "action" .= c+      "colonComs"    .= d >> "alt"    .= e+      putLocation f+    AST_ObjRuleFunc  a         -> innerToStruct a++instance FromDaoStructClass (AST_ObjTest Object) where+  fromDaoStruct = msum $+    [ AST_ObjArith <$> fromDaoStruct+    , do  constructor "ObjTest"+          return AST_ObjTest+            <*> req "condition" +            <*> (maybe (Com ()) id <$> opt "quesMarkComs") <*> req "action"+            <*> (maybe (Com ()) id <$> opt "colonComs"   ) <*> req "alt"+            <*> location+    , AST_ObjRuleFunc <$> fromDaoStruct+    ]++instance ObjectClass (AST_ObjTest Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_ObjTest Object) where+  haskellDataInterface = interface "ObjectTestExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass AST_Namespace where+  toDaoStruct = ask >>= \a -> case a of+    AST_NoNamespace     -> makeNullary "NoNamespace"+    AST_Namespace n loc -> renameConstructor "Namespace" $ "name" .= n >> putLocation loc++instance FromDaoStructClass AST_Namespace where+  fromDaoStruct = msum $+    [ nullary "NoNamespace" >> return AST_NoNamespace+    , constructor "Namespace" >> return AST_Namespace <*> req "name" <*> location+    ]++instance ObjectClass AST_Namespace where { obj=new; fromObj=objFromHata; }++instance HataClass AST_Namespace where+  haskellDataInterface = interface "NamespaceExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- binary 0x81 0x82 -- placed next to with 'DotNameExpr'+instance B.Binary AttributeExpr MTab where+  put o = case o of+    AttribDotNameExpr a     -> B.put a+    AttribStringExpr  a loc -> B.prefixByte 0x82 $ B.put a >> B.put loc+  get = B.word8PrefixTable <|> fail "expecting AttributeExpr"++instance B.HasPrefixTable AttributeExpr Word8 MTab where+  prefixTable = (AttribDotNameExpr <$> B.prefixTable) <>+    B.mkPrefixTableWord8 "AttributeExpr" 0x82 0x82 [return AttribStringExpr <*> B.get <*> B.get]++-- binary 0xE9 0xEE+instance B.Binary (TopLevelExpr Object) MTab where+  put o = case o of+    RequireExpr a               z -> B.prefixByte 0xE9 $ B.put a >> B.put z+    ImportExpr  a             b z -> B.prefixByte 0xEA $ B.put a >> B.put b >> B.put z+    TopScript   a               z -> B.prefixByte 0xEB $ B.put a >> B.put z+    EventExpr   BeginExprType b z -> B.prefixByte 0xEC $ B.put b >> B.put z+    EventExpr   ExitExprType  b z -> B.prefixByte 0xED $ B.put b >> B.put z+    EventExpr   EndExprType   b z -> B.prefixByte 0xEE $ B.put b >> B.put z+  get = B.word8PrefixTable <|> fail "expecting TopLevelExpr"++instance B.HasPrefixTable (TopLevelExpr Object) B.Byte MTab where+  prefixTable = B.mkPrefixTableWord8 "TopLevelExpr" 0xE9 0xEE $+    [ return RequireExpr <*> B.get <*> B.get+    , return ImportExpr  <*> B.get <*> B.get <*> B.get+    , return TopScript   <*> B.get <*> B.get+    , return (EventExpr BeginExprType) <*> B.get <*> B.get+    , return (EventExpr ExitExprType ) <*> B.get <*> B.get+    , return (EventExpr EndExprType  ) <*> B.get <*> B.get+    ]++instance Executable (TopLevelExpr Object) () where+  execute o = errCurrentModule $ case o of+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    RequireExpr{} -> attrib "require"+    ImportExpr{}  -> attrib "import"+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    TopScript script _ -> do+      ((), dict) <- execNested mempty $ catchPredicate (execute script) >>= \pval -> case pval of+        OK                _  -> return ()+        PFail (ExecReturn _) -> return ()+        PFail           err  -> throwError err+        Backtrack            -> return () -- do not backtrack at the top-level+      let addIfFuncs a b = maybe b id $ do -- overwrite previously declared variables...+            (a, b) <- Just (,) <*> fromObj a <*> fromObj b+            Just $ obj ((a++b)::[CallableCode]) -- ...unless both variables are [CallableCode]+      modify $ \xunit -> xunit{ globalData = M.unionWith addIfFuncs (globalData xunit) dict }+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    EventExpr typ script _ -> do+      let exec = setupCodeBlock script+      let f = (++[exec])+      modify $ \xunit -> case typ of+        BeginExprType -> xunit{ preExec      = f (preExec      xunit) }+        EndExprType   -> xunit{ postExec     = f (postExec     xunit) }+        ExitExprType  -> xunit{ quittingTime = f (quittingTime xunit) }+    --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --  --+    where+      attrib a = fail $ a++" expression must occur only at the top of a dao script file"++instance ObjectClass (TopLevelExpr Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (TopLevelExpr Object) where+  haskellDataInterface = interface "TopLevel" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass AST_Attribute where+  toDaoStruct = ask >>= \o -> case o of+    AST_AttribDotName str     -> renameConstructor "AttributeDotName" $ innerToStruct str+    AST_AttribString  str loc ->+      renameConstructor "AttributeString" $ "value" .= str >> putLocation loc++instance FromDaoStructClass AST_Attribute where+  fromDaoStruct = msum $+    [ constructor "AttributeDotName" >> AST_AttribDotName <$> innerFromStruct "DotLabel"+    , constructor "AttributeString"  >> return AST_AttribString  <*> req "value" <*> location+    ]++instance ObjectClass AST_Attribute where { obj=new; fromObj=objFromHata; }++instance HataClass AST_Attribute where+  haskellDataInterface = interface "AttributeExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++instance ToDaoStructClass (AST_TopLevel Object) where+  toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of+    AST_Require    a     loc -> nm "Require" $ "attribute" .= a >> putLocation loc+    AST_Import     a b   loc -> nm "Import" $ "attribute" .= a >> "namespace" .= b >> putLocation loc+    AST_TopScript  a     loc -> nm "TopLevel" $ "script" .= a >> putLocation loc+    AST_TopComment a         -> nm "Comment" $ putComments a+    AST_Event      a b c loc ->+      nm "Event" $ "type" .= a >> "block" .= c >> putComments b >> putLocation loc++instance FromDaoStructClass (AST_TopLevel Object) where+  fromDaoStruct = msum $+    [ constructor "Import"   >> return AST_Import    <*> req "attribute" <*> req "namespace" <*> location+    , constructor "Require"  >> return AST_Require   <*> req "attribute" <*> location+    , constructor "TopLevel" >> return AST_TopScript <*> req "script"    <*> location+    , constructor "Event"    >> return AST_Event     <*> req "type"      <*> comments <*> req "block" <*> location+    , constructor "Comment"  >> AST_TopComment     <$> comments+    ]++instance ObjectClass (AST_TopLevel Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_TopLevel Object) where+  haskellDataInterface = interface "TopLevelExpression" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++-- the number is encoded by the ASCII encoded string "DaoProg\0"+program_magic_number :: Word64+program_magic_number = 0x44616f50726f6700++instance B.Binary (Program Object) MTab where+  put o = do+    -- place a magic number first, +    B.putWord64be program_magic_number+    mapM_ B.put $ topLevelExprs o+  get = do+    magic <- B.lookAhead B.getWord64be+    guard (magic == program_magic_number)+    B.getWord64be >> fmap Program B.get++-- | Initialized the current 'ExecUnit' by evaluating all of the 'TopLevel' data in a+-- 'AST.AST_SourceCode'.+instance Executable (Program Object) () where+  execute (Program ast) = do+    ((), localVars) <- execNested mempty $ mapM_ execute (dropWhile isAttribute ast)+    -- Now, the local variables that were defined in the top level need to be moved to the global+    -- variable store.+    modify $ \xunit -> xunit{ globalData = M.union localVars (globalData xunit) }++instance ObjectClass (Program Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (Program Object) where+  haskellDataInterface = interface "ProgramData" $ do+    autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt++----------------------------------------------------------------------------------------------------++_withGlobalKey :: Object -> (H.Index Object -> RefMonad Object Dynamic a) -> Exec a+_withGlobalKey idx f = gets globalMethodTable >>= \mt -> +  gets runtimeRefTable >>= liftIO . runReaderT (f $ H.hashNewIndex (H.deriveHash128_DaoBinary mt) idx)++-- | Some objects may refer to an object that serves as a unique identifier created by the system,+-- for example objects refereing to file handles. These unique identifying objects should always be+-- stored in this table. The Dao 'Object' wrapper should be used as the index to retrieve the Object+-- in the table. This function takes the object to be stored, a destructor function to be called on+-- releasing the object, and an indexing object used to identify the stored object in the table.+initializeGlobalKey :: Typeable o => o -> (o -> IO ()) -> Object -> Exec (H.Index Object)+initializeGlobalKey o destructor idx = _withGlobalKey idx $ \key ->+  initializeWithKey (toDyn o) (destructor o) key >> return key++-- | Destroy an object that was stored into the global key table using 'initializeGlobalKey'. The+-- destructor function passed to the 'initializeGlobalKey' will be evaluated, and the object will+-- be removed from the table. This function takes an indexing object used to select the stored+-- object from the table.+destroyGlobalKey :: Object -> Exec ()+destroyGlobalKey = flip _withGlobalKey destroyWithKey++----------------------------------------------------------------------------------------------------++instance ToDaoStructClass (AST_SourceCode Object) where+  toDaoStruct = renameConstructor "SourceCode" $ do+    "modified" .=@ sourceModified+    "path"     .=@ sourceFullPath+    asks directives >>= define "code" . listToObj++instance FromDaoStructClass (AST_SourceCode Object) where+  fromDaoStruct = constructor "SourceCode" >>+    return AST_SourceCode <*> req "modified" <*> req "path" <*> reqList "code"++instance ObjectClass (AST_SourceCode Object) where { obj=new; fromObj=objFromHata; }++instance HataClass (AST_SourceCode Object) where+  haskellDataInterface = interface "SourceCode" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++-- | Simply converts an 'Dao.Interpreter.AST_SourceCode' directly to a list of+-- 'Dao.Interpreter.TopLevelExpr's.+evalTopLevelAST :: AST_SourceCode Object -> Exec (Program Object)+evalTopLevelAST ast = case toInterm ast of+  [o] -> return o+  []  -> fail "converting AST_SourceCode to Program by 'toInterm' returned null value"+  _   -> fail "convertnig AST_SourceCode to Program by 'toInterm' returned ambiguous value"++----------------------------------------------------------------------------------------------------+-- $Builtin_object_interfaces+-- The following functions provide object interfaces for essential data types.++instance HataClass () where { haskellDataInterface = interface "HaskellNullValue" (return ()) }++type Get a = B.GGet  MethodTable a+type Put   = B.GPut  MethodTable++-- This is only necessary to shorten the name 'MethodTable' because it is used throughout so many+-- instance declarations and type contexts.+type MTab = MethodTable++----------------------------------------------------------------------------------------------------++newtype MethodTable = MethodTable (M.Map Name (Interface Dynamic))++instance Monoid MethodTable where+  mempty  = MethodTable mempty+  mappend (MethodTable a) (MethodTable b) = let dups = M.intersection a b in+    if M.null dups+    then MethodTable (M.union b a)+    else error ("Namespace conflict when installing built-in data type interfaces: "++show (M.keys dups))++-- | Lookup an 'Interface' by it's name from within the 'Exec' monad.+execGetObjTable :: Name -> Exec (Maybe (Interface Dynamic))+execGetObjTable nm = gets (lookupMethodTable nm . globalMethodTable)++lookupMethodTable :: Name -> MethodTable -> Maybe (Interface Dynamic)+lookupMethodTable nm (MethodTable tab) = M.lookup nm tab++-- not for export, use 'daoClass'+_insertMethodTable :: (Typeable o, HataClass o) => o -> Interface o -> MethodTable -> MethodTable+_insertMethodTable _ ifc = flip mappend $+  MethodTable (M.singleton (objInterfaceName ifc) (interfaceToDynamic ifc))++instance B.HasCoderTable MethodTable where+  getEncoderForType nm mtab = fmap fst $ lookupMethodTable nm mtab >>= objBinaryFormat+  getDecoderForType nm mtab = fmap snd $ lookupMethodTable nm mtab >>= objBinaryFormat++----------------------------------------------------------------------------------------------------++-- | Implements a "for" loop using a 'ReadIterable' item. This function should receive the+-- 'iter' object produced by 'initReadIter' that can be used by this function to extract each+-- 'val' and a function that is evaluated using a 'val' on every iteration of the loop.+-- 'readForLoop' should be defined call the given function as many times as necessary to+-- exaust the 'val's in the 'iter'.+--+-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly+-- handle "break" and "catch" statements.+class ReadIterable iter val | iter -> val where+  readForLoop :: iter -> (val -> Exec ()) -> Exec ()++instance ReadIterable [Object] Object where { readForLoop iter = execForM_ iter }++instance ReadIterable Hata Object where+  readForLoop h@(Hata ifc d) f = case objReadIterable ifc of+    Nothing  -> throwBadTypeError "cannot iterate over object" (obj h) []+    Just for -> for d f++instance ReadIterable Object Object where+  readForLoop o f = case o of+    OList    o -> readForLoop o f+    OHaskell o -> readForLoop o f+    _          -> throwBadTypeError "cannot iterate over object" o []++----------------------------------------------------------------------------------------------------++-- | A class that provides the 'updateForLoop' function, which is a function that will iterate over+-- types which can be read sequentially and modified as they are read.+--+-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly+-- handle "break" and "catch" statements.+class UpdateIterable iter val | iter -> val where+  updateForLoop :: iter -> (val -> Exec val) -> Exec iter++instance UpdateIterable [Object] (Maybe Object) where+  updateForLoop iter f =+    fmap (concatMap $ \o -> maybe [] id $ (o>>=fromObj) <|> fmap return o) (execForM iter $ f . Just)++instance UpdateIterable Hata (Maybe Object) where+  updateForLoop h@(Hata ifc d) f = case objUpdateIterable ifc of+    Nothing  -> throwBadTypeError "cannot iterate over object" (obj h) []+    Just for -> Hata ifc <$> for d f++instance UpdateIterable T_dict (Maybe Object) where+  updateForLoop m f = fmap (M.fromList . concat) $ execForM (M.assocs m) $ \ (i, o) -> do+    p <- f (Just $ obj $ Pair (obj i, o))+    case p of+      Nothing -> return []+      Just  p -> case fromObj p of+        Just (Pair (ref, o)) -> case fromObj ref of+          Just ref -> return [(ref, o)]+          Nothing  -> throwBadTypeError "iterator cannot updte dictionary item" ref []+        Nothing -> throwBadTypeError "a dictionary iterator must store Pair objects" p []++instance UpdateIterable Object (Maybe Object) where+  updateForLoop o f = case o of+    OList    o -> OList    <$> updateForLoop o f+    ODict    o -> ODict    <$> updateForLoop o f+    OHaskell o -> OHaskell <$> updateForLoop o f+    o          -> throwBadTypeError "cannot iterae over object" o []++----------------------------------------------------------------------------------------------------++-- | This class only exists to allow many different Haskell data types to declare their+-- 'Interface' under the same funcion name: 'haskellDataInterface'. Instantiate this function with+-- the help of the 'interface' function.+class HataClass typ where { haskellDataInterface :: Interface typ }++instance HataClass Location where+  haskellDataInterface = interface "Location" $ do+    autoDefEquality >> autoDefOrdering+    autoDefToStruct >> autoDefFromStruct+    autoDefPPrinter++instance HataClass Comment where+  haskellDataInterface = interface "Comment" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter+    autoDefToStruct >> autoDefFromStruct++instance HataClass DotNameExpr where+  haskellDataInterface = interface "DotName" $ do+    autoDefEquality >> autoDefBinaryFmt >> autoDefPPrinter++instance HataClass AST_DotName where+  haskellDataInterface = interface "DotNameExpression" $ do+    autoDefEquality >> autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct++instance HataClass DotLabelExpr where+  haskellDataInterface = interface "DotLabel" $ do+    autoDefEquality >> autoDefBinaryFmt >> autoDefPPrinter++instance HataClass AST_DotLabel where+  haskellDataInterface = interface "DotLabelExpression" $ do+    autoDefEquality >> autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct++----------------------------------------------------------------------------------------------------++instance UpdateIterable (H.HashMap Object Object) (Maybe Object) where+  updateForLoop hm f = fmap (H.fromList . concat) $ execForM (H.assocs hm) $ \ (ix, o) -> do+    hash128 <- getObjectHash128+    p <- f (Just $ obj $ Pair (H.indexKey ix, o))+    case p of+      Nothing -> return []+      Just  p -> do+        let badtype = throwBadTypeError "cannot update hash map in iterator with item" p []+        maybe badtype (\ (Pair(a,b)) -> return [(H.hashNewIndex hash128 a, b)]) (fromObj p)++instance ObjectClass (H.HashMap Object Object) where { obj=new; fromObj=objFromHata; }++-- | The hash function for 'Object's relies on the binary serialization of the object, which+-- requires access to the 'MethodTable' of the current 'ExecUnit'. Therefore the hash function must+-- be derived from the 'Exec' monad, the 'Object' data type unfortunately cannot simply derive the+-- 'Data.HashMap.Int128Hashable' class.+getObjectHash128 :: Exec (Object -> H.Hash128)+getObjectHash128 = gets globalMethodTable >>= \mt -> return (H.deriveHash128_DaoBinary mt)++instance HataClass (H.HashMap Object Object) where+  haskellDataInterface = interface "HashMap" $ do+    autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt >> autoDefPPrinter+    autoDefSizeable >> autoDefUpdateIterable+    let un _ a b = xmaybe (fromObj b) >>= \b -> return $ new $ H.union b a+    defInfixOp ADD  un+    defInfixOp ORB  un+    defInfixOp ANDB $ \ _ a b -> xmaybe (fromObj b) >>= \b -> return $ new $ (H.intersection b a :: H.HashMap Object Object)+    defInfixOp SUB  $ \ _ a b -> xmaybe (fromObj b) >>= \b -> return $ new $ (H.difference b a :: H.HashMap Object Object)+    let initItems hmap ox = do+          hash128 <- getObjectHash128+          let f hmap o = case o of+                InitSingle o -> do+                  let idx = H.hashNewIndex hash128 o+                  return $ H.hashInsert idx o hmap+                InitAssign i op o -> do+                  i <- derefObject i+                  let idx = H.hashNewIndex hash128 i+                  let ref = Just (RefObject i NullRef) <|> fromObj i+                  o <- evalUpdateOp ref op o (H.hashLookup idx hmap)+                  return $ case o of+                    Nothing -> H.hashDelete idx hmap+                    Just  o -> H.hashInsert idx o hmap+          foldM f hmap ox+    defInitializer hashMapFromList initItems+    let single_index :: Monad m => (Object -> m a) -> [Object] -> m a+        single_index f ix = case ix of+          [i] -> f i+          []  -> fail "no index value provided in subscript to HashMap data type"+          _   -> fail "HashMap is a one-dimensional data type, indexed with multi-dimesional subscript"+    defIndexer $ \hm -> single_index $ \i -> do+      hash128 <- getObjectHash128+      i <- derefObject i+      xmaybe (H.hashLookup (H.hashNewIndex hash128 i) hm)+    defIndexUpdater $ \ix upd -> flip single_index ix $ \i -> do+      hash128 <- focusLiftExec getObjectHash128+      i <- focusLiftExec $ derefObject i+      i <- pure (H.hashNewIndex hash128 i)+      hm <- get+      (result, (changed, o)) <- withInnerLens (H.hashLookup i hm) upd+      when changed (put $ H.hashAlter (const o) i hm)+      return result++hashMapFromList :: [Object] -> Exec (H.HashMap Object Object)+hashMapFromList ox = do+  hash128 <- getObjectHash128+  let fromDict = fmap (\ (i, o) -> (H.hashNewIndex hash128 (obj i), o)) . M.assocs+      f (a, o) = case o of+        OList ox -> case mapM (\ (i, o) -> maybe (Left (i, o)) Right (fromObj o)) (zip [0..] ox) of+          Left (i, t) -> throwBadTypeError "list item in hash map initializer" t $+            [(errInInitzr, OInt a), (ustr "listIndex", OInt i)]+          Right ox -> return $ fmap (\ (Pair(a,b)) -> (H.hashNewIndex hash128 a, b)) ox+        OTree (Struct{fieldMap=ox}) -> return $ fromDict ox+        ODict   ox -> return $ fromDict ox+        o -> do+          let badtype = throwBadTypeError "hash map initializer from list" o [(errInInitzr, OInt a)]+          maybe badtype return $ msum $+            [ fromObj o >>= \ (Pair(a,b)) -> Just [(H.hashNewIndex hash128 a, b)]+            , H.assocs <$> fromObj o+            ]+  H.fromList . concat <$> mapM f (zip [1..] ox)++builtin_HashMap :: DaoFunc ()+builtin_HashMap =+  daoFunc{ daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj) . hashMapFromList }++----------------------------------------------------------------------------------------------------++-- | When defining the function used by the Dao interpreter to construct your object from an+-- initializer statement, a statement which looks like the following code:+-- > MyObj(0, a) { item = 1, item += 3, x, y };+-- you will need to receive the list of items expressed in curly-brackets, which could be an+-- assignment operation, or a single object value expression. This data type provides the necessary+-- data to your initializer function.+data InitItem+  = InitSingle Object+  | InitAssign Object UpdateOp Object+  deriving (Eq, Ord, Typeable)++----------------------------------------------------------------------------------------------------++-- | This is all of the functions used by the "Dao.Evaluator" when manipulating objects in a Dao+-- program. Behavior of objects when they are used in "for" statements or "with" statements, or when+-- they are dereferenced using the "@" operator, or when they are used in equations are all defined+-- here.+-- +-- So this table is the reason you instantiate 'HataClass'.+-- +-- @obj@ specifies the container type that will wrap-up data of type @typ@. @obj@ is the type used+-- throughout the runtime system to symbolize the basic unit of information operated on by+-- computations.+-- +-- @typ@ specifies the type that you want to wrap-up into an @obj@ constructor. When you want to,+-- for example, check for equality between object of type @typ@, you can define a function for+-- 'objEquality'. All of the other polymorphic types are bound to the @typ@ types by the functional+-- dependencies mechanism of the Haskell language.+-- +-- @exec@ specifies a monad in which to evaluate functions which may need to cause side-effects.+-- This should usually be a 'Control.Monad.Monad'ic type like @IO@ or 'Exec'.+data Interface typ =+  Interface+  { objInterfaceName   :: Name+  , objHaskellType     :: TypeRep -- ^ this type is deduced from the initial value provided to the 'interface'.+  , objCastFrom        :: Maybe (Object -> typ)                                                      -- ^ defined by 'defCastFrom'+  , objEquality        :: Maybe (typ -> typ -> Bool)                                                 -- ^ defined by 'defEquality'+  , objOrdering        :: Maybe (typ -> typ -> Ordering)                                             -- ^ defined by 'defOrdering'+  , objBinaryFormat    :: Maybe (typ -> Put, Get typ)                                                -- ^ defined by 'defBinaryFmt'+  , objNullTest        :: Maybe (typ -> Bool)                                                        -- ^ defined by 'defNullTest'+  , objPPrinter        :: Maybe (typ -> PPrint)                                                      -- ^ defined by 'defPPrinter'+  , objReadIterable    :: Maybe (typ -> (Object -> Exec ()) -> Exec ())                              -- ^ defined by 'defReadIterator'+  , objUpdateIterable  :: Maybe (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ)           -- ^ defined by 'defUpdateIterator'+  , objIndexer         :: Maybe (typ -> [Object] -> Exec Object)                                     -- ^ defined by 'defIndexer'+  , objIndexUpdater    :: Maybe (ObjectUpdate typ [Object])                                          -- ^ defined by 'defIndexUpdater'+  , objSizer           :: Maybe (typ -> Exec Object)                                                 -- ^ defined by 'defSizer'+  , objToStruct        :: Maybe (ToDaoStruct typ ())                                                 -- ^ defined by 'defStructFormat'+  , objFromStruct      :: Maybe (FromDaoStruct typ)                                                  -- ^ defined by 'defStructFormat'+  , objInitializer     :: Maybe ([Object] -> Exec typ, typ -> [InitItem] -> Exec typ)                -- ^ defined by 'defDictInit'+  , objTraverse        :: Maybe (ObjectTraverse typ [Object])                                        -- ^ defined by 'defTraverse'+  , objInfixOpTable    :: Maybe (Array InfixOp  (Maybe (InfixOp  -> typ -> Object -> XPure Object))) -- ^ defined by 'defInfixOp'+  , objArithPfxOpTable :: Maybe (Array ArithPfxOp (Maybe (ArithPfxOp -> typ -> XPure Object)))       -- ^ defined by 'defPrefixOp'+  , objCallable        :: Maybe (typ -> Exec [CallableCode])                                         -- ^ defined by 'defCallable'+  , objDereferencer    :: Maybe (typ -> Exec (Maybe Object))+  , objMethodTable     :: M.Map Name (DaoFunc typ)+  }+  deriving Typeable++instance Eq  (Interface typ) where { a==b = objHaskellType a == objHaskellType b }++instance Ord (Interface typ) where { compare a b = compare (objHaskellType a) (objHaskellType b) }++-- | This function works a bit like 'Data.Functor.fmap', but maps an 'Interface' from one type+-- to another. This requires two functions: one that can cast from the given type to the adapted+-- type (to convert outputs of functions), and one that can cast back from the adapted type to the+-- original type (to convert inputs of functions). Each coversion function takes a string as it's+-- first parameter, this is a string containing the name of the function that is currently making+-- use of the conversion operation. Should you need to use 'Prelude.error' or 'newError', this+-- string will allow you to throw more informative error messages. WARNING: this function leaves+-- 'objHaskellType' unchanged because the original type value should usually be preserved.+interfaceAdapter+  :: (Typeable typ_a, Typeable typ_b)+  => (String -> typ_a -> typ_b)+  -> (String -> typ_b -> typ_a)+  -> Interface typ_a+  -> Interface typ_b+interfaceAdapter a2b b2a ifc = +  ifc+  { objCastFrom        = let n="objCastFrom"       in fmap (fmap (a2b n)) (objCastFrom ifc)+  , objEquality        = let n="objEquality"       in fmap (\eq  a b -> eq  (b2a n a) (b2a n b)) (objEquality ifc)+  , objOrdering        = let n="objOrdering"       in fmap (\ord a b -> ord (b2a n a) (b2a n b)) (objOrdering ifc)+  , objBinaryFormat    = let n="objBinaryFormat"   in fmap (\ (toBin , fromBin) -> (toBin . b2a n, fmap (a2b n) fromBin)) (objBinaryFormat ifc)+  , objNullTest        = let n="objNullTest"       in fmap (\null b -> null (b2a n b)) (objNullTest ifc)+  , objPPrinter        = let n="objPPrinter"       in fmap (\eval -> eval . b2a n) (objPPrinter ifc)+  , objReadIterable    = let n="objReadIterable"   in fmap (\for t -> for (b2a n t)) (objReadIterable ifc)+  , objUpdateIterable  = let n="objUpdateIterable" in fmap (\for t -> fmap (a2b n) . for (b2a n t)) (objUpdateIterable ifc)+  , objIndexer         = let n="objIndexer"        in fmap (\f i -> f (b2a n i)) (objIndexer ifc)+  , objIndexUpdater    = let n="objIndexUpdater"   in fmap (\upd i f -> convertFocus (a2b n) (b2a n) (upd i f)) (objIndexUpdater ifc)+  , objSizer           = let n="objSizer"          in fmap (\f o -> f (b2a n o)) (objSizer ifc)+  , objToStruct        = let n="objToStruct"       in fmap (fmapHaskDataToStruct (a2b n) (b2a n)) (objToStruct ifc)+  , objFromStruct      = let n="objFromStruct"     in fmap (fmap (a2b n)) (objFromStruct ifc)+  , objInitializer     = let n="objInitializer"    in fmap (\ (init, eval) -> (\ox -> fmap (a2b n) (init ox), \typ ox -> fmap (a2b n) (eval (b2a n typ) ox))) (objInitializer ifc)+  , objTraverse        = let n="objTraverse"       in fmap (\focus f -> convertFocus (a2b n) (b2a n) (focus f)) (objTraverse ifc)+  , objInfixOpTable    = let n="objInfixOpTable"   in fmap (fmap (fmap (\infx op b -> infx op (b2a n b)))) (objInfixOpTable  ifc)+  , objArithPfxOpTable = let n="objPrefixOpTable"  in fmap (fmap (fmap (\prfx op b -> prfx op (b2a n b)))) (objArithPfxOpTable ifc)+  , objMethodTable     = let n="objMethodTable"    in fmap (\func -> func{ daoForeignFunc = \t -> fmap (fmap (a2b n)) . daoForeignFunc func (b2a n t) }) (objMethodTable ifc)+  , objCallable        = let n="objCallable"       in fmap (\eval -> eval . b2a n) (objCallable ifc)+  , objDereferencer    = let n="objDerferencer"    in fmap (\eval -> eval . b2a n) (objDereferencer ifc)+  }++interfaceToDynamic :: Typeable typ => Interface typ -> Interface Dynamic+interfaceToDynamic oi = interfaceAdapter (\ _ -> toDyn) (from oi) oi where+  from :: Typeable typ => Interface typ -> String -> Dynamic -> typ+  from oi msg dyn = fromDyn dyn (dynErr oi msg dyn)+  dynErr :: Typeable typ => Interface typ -> String -> Dynamic -> typ+  dynErr oi msg dyn = error $ concat $+    [ "The '", msg+    , "' function defined for objects of type ", show (objHaskellType oi)+    , " was evaluated on an object of type ", show (dynTypeRep dyn)+    ]++-- Used to construct an 'Interface' in a "Control.Monad.State"-ful way. Instantiates+-- 'Data.Monoid.Monoid' to provide 'Data.Monoid.mempty' an allows multiple inheritence by use of the+-- 'Data.Monoid.mappend' function in the same way as+data HDIfcBuilder typ =+  HDIfcBuilder+  { objIfcHaskellType    :: TypeRep+  , objIfcCastFrom       :: Maybe (Object -> typ)+  , objIfcEquality       :: Maybe (typ -> typ -> Bool)+  , objIfcOrdering       :: Maybe (typ -> typ -> Ordering)+  , objIfcBinaryFormat   :: Maybe (typ -> Put, Get typ)+  , objIfcNullTest       :: Maybe (typ -> Bool)+  , objIfcPPrinter       :: Maybe (typ -> PPrint)+  , objIfcReadIterable   :: Maybe (typ -> (Object -> Exec ()) -> Exec ())+  , objIfcUpdateIterable :: Maybe (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ)+  , objIfcIndexer        :: Maybe (typ -> [Object] -> Exec Object)+  , objIfcIndexUpdater   :: Maybe (ObjectUpdate typ [Object])+  , objIfcSizer          :: Maybe (typ -> Exec Object)+  , objIfcToStruct       :: Maybe (ToDaoStruct typ ())+  , objIfcFromStruct     :: Maybe (FromDaoStruct typ)+  , objIfcInitializer    :: Maybe ([Object] -> Exec typ, typ -> [InitItem] -> Exec typ)+  , objIfcTraverse       :: Maybe (ObjectTraverse typ [Object])+  , objIfcInfixOpTable   :: [(InfixOp , InfixOp  -> typ -> Object -> XPure Object)]+  , objIfcPrefixOpTable  :: [(ArithPfxOp, ArithPfxOp -> typ -> XPure Object)]+  , objIfcMethodTable    :: M.Map Name (DaoFunc typ)+  , objIfcCallable       :: Maybe (typ -> Exec [CallableCode])+  , objIfcDerefer        :: Maybe (typ -> Exec (Maybe Object))+  }++initHDIfcBuilder :: TypeRep -> HDIfcBuilder typ+initHDIfcBuilder typ =+  HDIfcBuilder+  { objIfcHaskellType    = typ+  , objIfcCastFrom       = Nothing+  , objIfcEquality       = Nothing+  , objIfcOrdering       = Nothing+  , objIfcBinaryFormat   = Nothing+  , objIfcNullTest       = Nothing+  , objIfcPPrinter       = Nothing+  , objIfcReadIterable   = Nothing+  , objIfcUpdateIterable = Nothing+  , objIfcIndexer        = Nothing+  , objIfcIndexUpdater   = Nothing+  , objIfcSizer          = Nothing+  , objIfcToStruct       = Nothing+  , objIfcFromStruct     = Nothing+  , objIfcInitializer    = Nothing+  , objIfcTraverse       = Nothing+  , objIfcInfixOpTable   = []+  , objIfcPrefixOpTable  = []+  , objIfcMethodTable    = mempty+  , objIfcCallable       = Nothing+  , objIfcDerefer        = Nothing+  }++-- | A handy monadic interface for defining an 'Interface' using nice, clean procedural+-- syntax.+type    DaoClassDef typ = DaoClassDefM typ ()+newtype DaoClassDefM typ a = DaoClassDefM { daoClassDefState :: State (HDIfcBuilder typ) a }+instance Typeable typ => Functor (DaoClassDefM typ) where+  fmap f (DaoClassDefM m) = DaoClassDefM (fmap f m)+instance Typeable typ => Monad (DaoClassDefM typ) where+  return = DaoClassDefM . return+  (DaoClassDefM m) >>= f = DaoClassDefM (m >>= daoClassDefState . f)+instance Typeable typ => Applicative (DaoClassDefM typ) where { pure=return; (<*>)=ap; }++_updHDIfcBuilder :: Typeable typ => (HDIfcBuilder typ -> HDIfcBuilder typ) -> DaoClassDefM typ ()+_updHDIfcBuilder = DaoClassDefM . modify++-- | The callback function defined here is used when objects of your @typ@ can be constructed from+-- some other 'Object'. This function is used to convert an 'Object' of another types to an data+-- type of your @typ@ when it is necessary to do so (for example, evaluating the @==@ or @!=@+-- operator).+defCastFrom :: Typeable typ => (Object -> typ) -> DaoClassDefM typ ()+defCastFrom fn = _updHDIfcBuilder(\st->st{objIfcCastFrom=Just fn})++-- | The callback function defined here is used where objects of your @typ@ might be compared to+-- other objects using the @==@ and @!=@ operators in Dao programs. However using this is slightly+-- different than simply overriding the @==@ or @!=@ operators. Defining an equality reliation with+-- this function also allows Haskell language programs to compare your object to other objects+-- without unwrapping them from the 'Object' wrapper.+--+-- This function automatically define an equality operation over your @typ@ using the+-- instantiation of 'Prelude.Eq' and the function you have provided to the 'defCastFrom' function.+-- The 'defCastFrom' function is used to cast 'Object's to a value of your @typ@, and then the+-- @Prelude.==@ function is evaluated. If you eventually never define a type casting funcion using+-- 'defCastFrom', this function will fail, but it will fail lazily and at runtime, perhaps when you+-- least expect it, so be sure to define 'defCastFrom' at some point.+autoDefEquality :: (Typeable typ, Eq typ) => DaoClassDefM typ ()+autoDefEquality = defEquality (==)++-- | The callback function defined here is used where objects of your @typ@ might be compared to+-- other objects using the @==@ and @!=@ operators in Dao programs. However using this is slightly+-- different than simply overriding the @==@ or @!=@ operators. Defining an equality relation with+-- this function also allows Haskell language programs to compare your object to other objects+-- without unwrapping them from the 'Object' wrapper.+--+-- This function differs from 'autoDefEquality' because you must provide a customized equality+-- relation for your @typ@, if the 'autoDefEquality' and 'defCastFrom' functions are to be avoided+-- for some reason.+defEquality :: (Typeable typ, Eq typ) => (typ -> typ -> Bool) -> DaoClassDefM typ ()+defEquality fn = _updHDIfcBuilder(\st->st{objIfcEquality=Just fn})++-- | The callback function defined here is used where objects of your @typ@ might be compared to+-- other objects using the @<@, @>@, @<=@, and @>=@ operators in Dao programs. However using this is+-- slightly different than simply overriding the @<@, @>@, @<=@, or @>=@ operators. Defining an+-- equality relation with this function also allows Haskell language programs to compare your obejct+-- to other objects without unwrapping them from the 'Object' wrapper.+-- +-- Automatically define an ordering for your @typ@ using the instantiation of+-- 'Prelude.Eq' and the function you have provided to the 'defCastFrom' function. The 'defCastFrom'+-- function is used to cast 'Object's to a value of your @typ@, and then the @Prelude.==@ function+-- is evaluated. If you eventually never define a type casting funcion using 'defCastFrom', this+-- function will fail, but it will fail lazily and at runtime, perhaps when you least expect it, so+-- be sure to define 'defCastFrom' at some point.+autoDefOrdering :: (Typeable typ, Ord typ) => DaoClassDefM typ ()+autoDefOrdering = defOrdering compare++-- | The callback function defined here is used where objects of your @typ@ might be compared to+-- other objects using the @<@, @>@, @<=@, and @>=@ operators in Dao programs. However using this is+-- slightly different than simply overriding the @<@, @>@, @<=@, or @>=@ operators. Defining an+-- equality relation with this function also allows Haskell language programs to compare your obejct+-- to other objects without unwrapping them from the 'Object' wrapper.+-- +-- Define a customized ordering for your @typ@, if the 'autoDefEquality' and 'defCastFrom'+-- functions are to be avoided for some reason.+defOrdering :: (Typeable typ) => (typ -> typ -> Ordering) -> DaoClassDefM typ ()+defOrdering fn = _updHDIfcBuilder(\st->st{objIfcOrdering=Just fn})++-- | The callback function defined here is used if an object of your @typ@ should ever need to be+-- stored into a binary file in persistent storage (like your filesystem) or sent across a channel+-- (like a UNIX pipe or a socket).+-- +-- It automatically define the binary encoder and decoder using the 'Data.Binary.Binary' class+-- instantiation for this @typ@.+autoDefBinaryFmt :: (Typeable typ, B.Binary typ MethodTable) => DaoClassDefM typ ()+autoDefBinaryFmt = defBinaryFmt B.put B.get++-- | This function is used if an object of your @typ@ should ever need to be stored into a binary+-- file in persistent storage (like your filesystem) or sent across a channel (like a UNIX pipe or a+-- socket).+-- +-- If you have binary coding and decoding methods for your @typ@ but for some silly reason not+-- instantiated your @typ@ into the 'Data.Binary.Binary' class, your @typ@ can still be used as a+-- binary formatted object by the Dao system if you define the encoder and decoder using this+-- function. However, it would be better if you instantiated 'Data.Binary.Binary' and used+-- 'autoDefBinaryFmt' instead.+defBinaryFmt :: (Typeable typ) => (typ -> Put) -> Get typ -> DaoClassDefM typ ()+defBinaryFmt put get = _updHDIfcBuilder(\st->st{objIfcBinaryFormat=Just(put,get)})++autoDefNullTest :: (Typeable typ, HasNullValue typ) => DaoClassDefM typ ()+autoDefNullTest = defNullTest testNull++-- | The callback function defined here is used if an object of your @typ@ is ever used in an @if@+-- or @while@ statement in a Dao program. This function will return @Prelude.True@ if the object is+-- of a null value, which will cause the @if@ or @while@ test to fail and execution of the Dao+-- program will branch accordingly. There is no default method for this function so it must be+-- defined by this function, otherwise your object cannot be tested by @if@ or @while@ statements.+defNullTest :: Typeable typ => (typ -> Bool) -> DaoClassDefM typ ()+defNullTest fn = _updHDIfcBuilder(\st->st{objIfcNullTest=Just fn})++-- | The callback function to be called when the "print" built-in function is used.+defPPrinter :: Typeable typ => (typ -> PPrint) -> DaoClassDefM typ ()+defPPrinter fn = _updHDIfcBuilder(\st->st{objIfcPPrinter=Just fn})++-- | The callback function to be called when the "print" built-in function is used.+autoDefPPrinter :: (Typeable typ, PPrintable typ) => DaoClassDefM typ ()+autoDefPPrinter = defPPrinter pPrint++-- | The callback function defined here is used if an object of your @typ@ is ever used in a @for@+-- statement in a Dao program. However it is much better to instantiate your @typ@ into the+-- 'ReadIterable' class and use 'autoDefIterator' instead. If 'defUpdateIterator' is also defined,+-- the function defined here will never be used.+--+-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly+-- handle "break" and "catch" statements.+defReadIterable :: Typeable typ => (typ -> (Object -> Exec ()) -> Exec ()) -> DaoClassDefM typ ()+defReadIterable iter = _updHDIfcBuilder $ \st -> st{ objIfcReadIterable=Just iter }++-- | Define 'defReadIterable' automatically using the instance of @typ@ in the 'ReadIterable' class.+--+-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly+-- handle "break" and "catch" statements.+autoDefReadIterable :: (Typeable typ, ReadIterable typ Object) => DaoClassDefM typ ()+autoDefReadIterable = defReadIterable readForLoop++-- | The callback function defined here is used if an object of your @typ@ is ever used in a @for@+-- statement in a Dao program. However it is much better to instantiate your @typ@ into the+-- 'UpdateIterable' class and use 'autoDefIterator' instead. If 'defReadIterator' is also defined,+-- the read iterator is always ignored in favor of this function.+--+-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly+-- handle "break" and "catch" statements.+defUpdateIterable :: Typeable typ => (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ) -> DaoClassDefM typ ()+defUpdateIterable iter = _updHDIfcBuilder(\st->st{objIfcUpdateIterable=Just iter})++-- | Define 'defUpdateIterable' automatically using the instance of @typ@ in the 'ReadIterable'+-- class.+--+-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly+-- handle "break" and "catch" statements.+autoDefUpdateIterable :: (Typeable typ, UpdateIterable typ (Maybe Object)) => DaoClassDefM typ ()+autoDefUpdateIterable = defUpdateIterable updateForLoop++-- | The callback function defined here is used at any point in a Dao program where an expression+-- containing your object typ is subscripted with square brackets, for example in the statement:+-- @x = t[0][A][B];@ The object passed to your callback function is the object containing the+-- subscript value. So in the above example, if the local variable @t@ is a value of+-- your @typ@, this callback function will be evaluated three times:+-- 1.  with the given 'Object' parameter being @('OInt' 0)@ and the @typ@ parameter as the value+--     stored in the local variable @y@.+-- 2.  once with the 'Object' parameter being the result of dereferencing the local varaible @A@ and+--     the @typ@ parameter as the value stored in the local variable @y@.+-- 3.  once the given 'Object' parameter being the result of dereferencing the local variable @B@ and+--     the @typ@ parameter as the value stored in the local variable @y@.+-- +-- Statements like this:+-- > ... = a[0,1,2]+-- access a single multi-dimensional index, in this case 3-dimensions with the tuple [0,1,2].+-- > ... = a[0][1][2]+-- accesses a sequence of single-dimensional elements, each element being accessed by the next+-- snigle-dimensional index in the sequence. Although this is one method of programming+-- multi-dimensional data types, it is evaluated differently than an index expressed as a tuple.+defIndexer :: Typeable typ => (typ -> [Object] -> Exec Object) -> DaoClassDefM typ ()+defIndexer fn = _updHDIfcBuilder(\st->st{objIfcIndexer=Just fn})++-- | The callback function defined here is used at any point in a Dao program where an expression+-- containing your object typ is subscripted with square brackets on the left-hand side of an+-- assignment expression:+-- @x[0][A][B] = t;@+-- This function must take the original object of your @typ@ and return the updated object along+-- with the value used to updated it.  The object passed to your callback function is the object+-- containing the subscript value. So in the above example, if the local variables @x@ is a value of+-- your @typ@, this callback function will be evaluated three times:+-- 1.  with the given 'Object' parameter being @('OInt' 0)@ and the @typ@ parameter as the value+--     stored in the local variable @y@.+-- 2.  once with the 'Object' parameter being the result of dereferencing the local varaible @A@ and+--     the @typ@ parameter as the value stored in the local variable @y@.+-- 3.  once the given 'Object' parameter being the result of dereferencing the local variable @B@ and+--     the @typ@ parameter as the value stored in the local variable @y@.+-- +-- Statements like this:+-- > a[0,1,2] = ...+-- access a single multi-dimensional index, in this case 3-dimensions with the tuple [0,1,2].+-- > a[0][1][2] = ...+-- accesses a sequence of single-dimensional elements, each element being accessed by the next+-- snigle-dimensional index in the sequence. Although this is one method of programming+-- multi-dimensional data types, it is evaluated differently than an index expressed as a tuple.+defIndexUpdater :: Typeable typ => ObjectUpdate typ [Object] -> DaoClassDefM typ ()+defIndexUpdater fn = _updHDIfcBuilder(\st->st{ objIfcIndexUpdater=Just fn })++-- | Define a function used by the built-in "size()" function to return an value indicating the size+-- of your @typ@ object.+defSizer :: Typeable typ => (typ -> Exec Object) -> DaoClassDefM typ ()+defSizer fn = _updHDIfcBuilder(\st->st{objIfcSizer=Just fn})++autoDefSizeable :: (Typeable typ, Sizeable typ) => DaoClassDefM typ ()+autoDefSizeable = defSizer getSizeOf++-- | Use your data type's instantiation of 'ToDaoStructClass' to call 'defToStruct'.+autoDefToStruct :: forall typ . (Typeable typ, ToDaoStructClass typ) => DaoClassDefM typ ()+autoDefToStruct = defToStruct toDaoStruct++-- | When a label referencing your object has a field record accessed, for example:+-- > c = a.b;+-- if your object is referenced by @a@ and the script expression wants to access a record called @b@+-- from within it, then function defined here will be used.+defToStruct :: Typeable typ => ToDaoStruct typ () -> DaoClassDefM typ ()+defToStruct encode = _updHDIfcBuilder (\st -> st{ objIfcToStruct=Just encode })++-- | When a label referencing your object has a field record updated, for example:+-- > a.b = c;+-- if your object is referenced by @a@ and the script expression wants to update a record called @b@+-- within it by assigning it the value referenced by @c@, then the function defined here will be+-- used.+autoDefFromStruct :: (Typeable typ, FromDaoStructClass typ) => DaoClassDefM typ ()+autoDefFromStruct = defFromStruct fromDaoStruct++-- | If for some reason you need to define a tree encoder and decoder for the 'Interface' of your+-- @typ@ without instnatiating 'ToDaoStructClass' or 'FromDaoStructClass', use+-- this function to define the tree encoder an decoder directly+defFromStruct :: Typeable typ => FromDaoStruct typ -> DaoClassDefM typ ()+defFromStruct decode = _updHDIfcBuilder (\st -> st{ objIfcFromStruct=Just decode })++-- | The callback defined here is used when a Dao program makes use of the static initialization+-- syntax of the Dao programming language, which are expression of this form:+-- > a = MyType { paramA=initA, paramB=initB, .... };+-- > a = MyType(param1, param2, ...., paramN) { paramA=initA, paramB=initB, .... };+-- When the interpreter sees this form of expression, it looks up the 'Interface' for your+-- @typ@ and checks if a callback has been defined by 'defDictInit'. If so, then the callback is+-- evaluated with a list of object values passed as the first parameter which contain the object+-- values written in the parentheses, and a list of 'InitItem's as the second parameter containing+-- the contents of the curly-brackets.+defInitializer :: Typeable typ => ([Object] -> Exec typ) -> (typ -> [InitItem] -> Exec typ) -> DaoClassDefM typ ()+defInitializer fa fb = _updHDIfcBuilder(\st->st{objIfcInitializer=Just (fa, fb)})++-- | Data structures in the Dao programming language can be traversed if you provide a function that+-- can update every 'Object' contained wihtin the data structure.+defTraverse :: Typeable typ => (([Object] -> Object -> ObjectFocus [([Object], Object)] ()) -> ObjectFocus typ ()) -> DaoClassDefM typ ()+defTraverse f = _updHDIfcBuilder(\st->st{objIfcTraverse=Just f})++-- | Define the 'defTraverse' function using the instance of 'objectFMap' for your @typ@ in the+-- @('ObjectFunctor' ['Object'] typ)@ class.+autoDefTraverse :: (Typeable typ, ObjectFunctor typ [Object]) => DaoClassDefM typ ()+autoDefTraverse = defTraverse objectFMap++-- | Overload infix operators in the Dao programming language, for example @+@, @*@, or @<<@.+-- +-- Like with C++, the operator prescedence and associativity is permanently defined by the parser+-- and cannot be changed by the overloading mechanism. You can only change how the operator behaves+-- based on the type of it's left and right hand parameters.+--+-- If you define two callbacks for the same 'UpdateOp', this will result in a runtime error,+-- hopefully the error will occur during the Dao runtime's object loading phase, and not while+-- actually executing a program.+defInfixOp :: Typeable typ => InfixOp -> (InfixOp -> typ -> Object -> XPure Object) -> DaoClassDefM typ ()+defInfixOp op fn = _updHDIfcBuilder $ \st -> st{objIfcInfixOpTable  = objIfcInfixOpTable  st ++ [(op, fn)] }++-- | Overload prefix operators in the Dao programming language, for example @!@, @~@, @-@, and @+@.+-- +-- Like with C++, the operator prescedence and associativity is permanently defined by the parser+-- and cannot be changed by the overloading mechanism. You can only change how the operator behaves+-- based on the type of it's left and right hand parameters.+-- +-- If you define two callbacks for the same 'UpdateOp', this will result in a runtime error,+-- hopefully the error will occur during the Dao runtime's object loading phase, and not while+-- actually executing a program.+defPrefixOp :: Typeable typ => ArithPfxOp -> (ArithPfxOp -> typ -> XPure Object) -> DaoClassDefM typ ()+defPrefixOp op fn = _updHDIfcBuilder $ \st -> st{objIfcPrefixOpTable = objIfcPrefixOpTable st ++ [(op, fn)] }++defCallable :: Typeable typ => (typ -> Exec [CallableCode]) -> DaoClassDefM typ ()+defCallable fn = _updHDIfcBuilder (\st -> st{objIfcCallable=Just fn})++defDeref :: Typeable typ => (typ -> Exec (Maybe Object)) -> DaoClassDefM typ ()+defDeref  fn = _updHDIfcBuilder (\st -> st{objIfcDerefer=Just fn})++defMethod :: (UStrType name, Typeable typ) => name -> DaoFunc typ -> DaoClassDefM typ ()+defMethod inname infn = do+  let name = fromUStr $ toUStr inname+  let fn = infn{ daoFuncName=name }+  let dupname st _  = error $ concat $ +        [ "Internal error: duplicate method name \"", show name+        , "\" for data type ", show (objIfcHaskellType st)+        ] +  _updHDIfcBuilder $ \st ->+    st{ objIfcMethodTable = M.alter (maybe (Just fn) (dupname st)) name $ objIfcMethodTable st }++-- | Like 'detMethod' but creates a function that takes no parameters.+defMethod0 :: (UStrType name, Typeable this) => name -> (this -> Exec (Maybe Object, this)) -> DaoClassDefM this ()+defMethod0 name f = defMethod name $+  daoFunc+  { funcAutoDerefParams = False+  , daoForeignFunc = \this ox -> case ox of+      [] -> f this+      ox -> throwArityError "" 0 ox [(errInFunc, obj $ reference UNQUAL (fromUStr $ toUStr name))]+  }++-- | Rocket. Yeah. Sail away with you.+defLeppard :: Typeable typ => rocket -> yeah -> DaoClassDefM typ ()+defLeppard _ _ = return ()++-- | This is the Dao 'Object' interface to the Haskell language. Every function in this data type+-- allows you to customize the behavior of the Dao evaluator for a particular Haskell data type+-- @typ@. In order for your type to be useful, it must be possible to pass your data type to the+-- 'OHaskell' constructor, which requires a data type of 'Data.Dynamic.Dynamic', which means your+-- @typ@ must derive a class instance for 'Data.Typeable.Typeable'. The first parameter of type+-- @typ@ is not used except to retrieve it's 'Data.Typeable.TypeRep' using the+-- 'Data.Typealble.typeOf' function, it is safe to pass any data constructor with all of it's fields+-- 'Prelude.undefined', just the constructor itself must not be 'Prelude.undefined'.+-- +-- The @'DaoClassDefM'@ parameter you pass to this function is a monadic function so you can simply+-- declare the functionality you would like to include in this object one line at a time using+-- the procedural coding style. Each line in the "procedure" will be one of the @def*@ functions,+-- for example 'autoDefEquality' or 'autoDefOrdering'.+interface :: (UStrType name, Typeable typ) => name -> DaoClassDefM typ ig -> Interface typ+interface nm defIfc = let name = toUStr nm in case maybeFromUStr name of+  Nothing   -> error $+    "Failed to install built-in data type interface, invalid type name provided: "++uchars nm+  Just name ->+    Interface+    { objHaskellType     = typ+    , objInterfaceName   = name+    , objCastFrom        = objIfcCastFrom       ifc+    , objEquality        = objIfcEquality       ifc+    , objOrdering        = objIfcOrdering       ifc+    , objBinaryFormat    = objIfcBinaryFormat   ifc+    , objNullTest        = objIfcNullTest       ifc+    , objPPrinter        = objIfcPPrinter       ifc+    , objReadIterable    = objIfcReadIterable   ifc+    , objUpdateIterable  = objIfcUpdateIterable ifc+    , objIndexer         = objIfcIndexer        ifc+    , objIndexUpdater    = objIfcIndexUpdater   ifc+    , objSizer           = objIfcSizer          ifc+    , objToStruct        = objIfcToStruct       ifc+    , objFromStruct      = objIfcFromStruct     ifc+    , objInitializer     = objIfcInitializer    ifc+    , objTraverse        = objIfcTraverse       ifc+    , objCallable        = objIfcCallable       ifc+    , objDereferencer    = objIfcDerefer        ifc+    , objInfixOpTable    = mkArray "defInfixOp"  $ objIfcInfixOpTable  ifc+    , objArithPfxOpTable = mkArray "defPrefixOp" $ objIfcPrefixOpTable ifc+    , objMethodTable     = objIfcMethodTable    ifc+    }+  where+    mktyp :: Typeable typ => DaoClassDefM typ ig -> typ -> TypeRep+    mktyp _ undefd = typeOf undefd+    typ = mktyp defIfc $+      error "'Dao.Interpreter.interface' evaluated 'Data.Typeable.typeOf' on undefined value"+    ifc = execState (daoClassDefState defIfc) (initHDIfcBuilder typ)+    mkArray oiName elems =+      minAccumArray (onlyOnce oiName) Nothing $ map (\ (i, e) -> (i, (i, Just e))) elems+    onlyOnce oiName a (i, b)  = case a of+      Nothing -> b+      Just  _ -> conflict oiName ("the "++show i++" operator")+    conflict oiName funcName = error $ concat $+      [ "'", oiName+      , "' has conflicting functions for ", funcName+      , " for the 'HataClass' instantiation of the '", show typ+      , "' Haskell data type."+      ]+
+ src/Dao/Interpreter/AST.hs view
@@ -0,0 +1,3135 @@+-- "src/Dao/Interpreter/AST.hs"  defines the data types for the Dao+-- programming language abstract syntax tree and related type classes.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++module Dao.Interpreter.AST+  ( Intermediate(toInterm, fromInterm), Canonical(canonicalize),+    Comment(InlineComment, EndlineComment),+    Com(Com, ComBefore, ComAfter, ComAround),+    NamespaceExpr(NamespaceExpr), AST_Namespace(AST_NoNamespace, AST_Namespace),+    setCommentBefore, setCommentAfter, unComment, getComment, +    pPrintInterm, putAST, getAST, commentString, pPrintComWith,+    pListOfComsWith, pListOfComs, randComWith, appendComments, com,+    DotNameExpr(DotNameExpr), AST_DotName(AST_DotName), getDotNameAST, undotNameExpr,+    DotLabelExpr(DotLabelExpr), AST_DotLabel(AST_DotLabel), +    dotLabelToNameList, dotLabelToRefExpr, refToDotLabelExpr, dotLabelToRefAST, refToDotLabelAST,+    RefSuffixExpr(NullRefExpr, DotRefExpr, SubscriptExpr, FuncCallExpr),+    ReferenceExpr(ReferenceExpr, RefObjectExpr),+    RefPfxOp(REF, DEREF), +    RefQualifier(UNQUAL, LOCAL, CONST, STATIC, GLOBAL, GLODOT),+    UpdateOp(UCONST, UADD, USUB, UMULT, UDIV, UMOD, UPOW, UORB, UANDB, UXORB, USHL, USHR), +    ArithPfxOp(INVB, NOT, NEGTIV, POSTIV), +    InfixOp(+      ADD, SUB, MULT, DIV, MOD, POW, ORB, ANDB, XORB, SHL, SHR, OR, AND,+      EQUL, NEQUL, GTN, LTN, GTEQ, LTEQ, ARROW+    ), infixOpCommutativity,+    allUpdateOpStrs, allPrefixOpChars, allPrefixOpStrs, allInfixOpChars, allInfixOpStrs,+    AST_RefSuffix(AST_RefNull, AST_DotRef, AST_Subscript, AST_FuncCall),+    AST_Reference(AST_Reference, AST_RefObject),+    ObjListExpr(ObjListExpr), AST_ObjList(AST_ObjList),+    OptObjListExpr(OptObjListExpr), AST_OptObjList(AST_OptObjList),+    LiteralExpr(LiteralExpr), AST_Literal(AST_Literal),+    ParenExpr(ParenExpr), AST_Paren(AST_Paren), +    AssignExpr(EvalExpr, AssignExpr), AST_Assign(AST_Eval, AST_Assign),+    ObjTestExpr(ObjArithExpr, ObjTestExpr, ObjRuleFuncExpr),+    AST_ObjTest(AST_ObjArith, AST_ObjTest, AST_ObjRuleFunc),+    ArithExpr(ObjectExpr, ArithExpr), AST_Arith(AST_Object, AST_Arith), +    RuleFuncExpr(LambdaExpr, FuncExpr, RuleExpr), AST_RuleFunc(AST_Lambda, AST_Func, AST_Rule),+    TyChkExpr(NotTypeChecked, TypeChecked, DisableCheck), fmapCheckedValueExpr,+    tyChkItem, tyChkExpr, tyChkLoc, typChkResult, checkedExpr,+    AST_TyChk(AST_NotChecked, AST_Checked), checkedAST, fmapCheckedValueAST,+    ParamExpr(ParamExpr), AST_Param(AST_NoParams, AST_Param), +    ParamListExpr(ParamListExpr), getTypeCheckList,+    AST_ParamList(AST_ParamList), +    RuleHeadExpr(RuleStringExpr, RuleHeadExpr), +    AST_RuleHeader(AST_NullRules, AST_RuleString, AST_RuleHeader), +    CodeBlock(CodeBlock), codeBlock,+    AST_CodeBlock(AST_CodeBlock), getAST_CodeBlock, +    RefPrefixExpr(PlainRefExpr, RefPrefixExpr), cleanupRefPrefixExpr,+    AST_RefPrefix(AST_RefPrefix, AST_PlainRef),+    ObjectExpr(+      VoidExpr, ObjLiteralExpr, ObjSingleExpr,+      ArithPfxExpr, InitExpr, StructExpr, MetaEvalExpr+    ),+    AST_Object(+      AST_Void, AST_ObjLiteral, AST_ObjSingle,+      AST_ArithPfx, AST_Init, AST_Struct, AST_MetaEval+    ),+    ScriptExpr(+      IfThenElse, WhileLoop, RuleFuncExpr, EvalObject,+      TryCatch, ForLoop, ContinueExpr, ReturnExpr, WithDoc+    ),+    IfExpr(IfExpr), AST_If(AST_If), +    ElseExpr(ElseExpr), AST_Else(AST_Else), +    IfElseExpr(IfElseExpr), AST_IfElse(AST_IfElse), +    LastElseExpr(LastElseExpr), AST_LastElse(AST_LastElse),+    CatchExpr(CatchExpr), AST_Catch(AST_Catch),+    WhileExpr(WhileExpr), AST_While(AST_While), +    AST_Script(+      AST_Comment, AST_IfThenElse, AST_WhileLoop, AST_RuleFunc, AST_EvalObject,+      AST_TryCatch, AST_ForLoop, AST_ContinueExpr, AST_ReturnExpr, AST_WithDoc+    ),+    TopLevelEventType(BeginExprType, EndExprType, ExitExprType), +    TopLevelExpr(RequireExpr, ImportExpr, TopScript, EventExpr), isAttribute, +    AST_TopLevel(AST_Require, AST_Import, AST_TopScript, AST_Event, AST_TopComment),+    isAST_Attribute, getRequiresAndImports,+    AttributeExpr(AttribDotNameExpr, AttribStringExpr),+    AST_Attribute(AST_AttribDotName, AST_AttribString),+    Program(Program), topLevelExprs,+    AST_SourceCode(AST_SourceCode), sourceModified, sourceFullPath, directives, +  )+  where++import qualified Dao.Binary  as B+import           Dao.String+import           Dao.PPrint+import           Dao.Random+import           Dao.Token++import           Data.Array.IArray+import           Data.List (intersperse)+import           Data.Monoid+import           Data.Typeable+import           Data.Word++import           Control.Applicative+import           Control.DeepSeq+import           Control.Monad++----------------------------------------------------------------------------------------------------++-- | Elements of the symantic data structures that instantiate 'Executable' and do not instantiate+-- 'Dao.PPrint.PPrintable', 'Dao.Struct.Structured', or any parsers. Elements of the abstract syntax+-- tree (AST) instantiate 'Dao.PPrint.PPrintable', 'Dao.Struct.Structured', and all of the parsers,+-- but are not executable and do not instantiate 'Executable'. This separates concerns pretty well,+-- but leaves us with the problem of having to convert back and forth between these various data+-- types.+--+-- The 'Intermediate' class allows us to declare a one-to-one relationship between AST types and+-- executable types. For example, 'ObjectExpr' is the intermediate representation of+-- 'AST_Object', so our instance for this relationship is @instane 'Intermediate'+-- 'ObjectExpr' 'AST_Object'@.+class Intermediate obj ast | obj -> ast, ast -> obj where+  toInterm   :: ast -> [obj]+  fromInterm :: obj -> [ast]++-- | This class is used to classify data types that can be generated at random by+-- 'Dao.Random.HasRandGen' and parsed from source code, which might generate data types with+-- identical functionality, identical pretty-printed forms, identical 'Executable' semantics but may+-- have differences in the recursive structure that the 'Prelude.Eq' class would compute as not+-- identical. The job of the 'canonicalize' function is to eliminate these discrepancies by reducing+-- the data structure to a canonical form.+class Canonical a where { canonicalize :: a -> a }++instance Intermediate Name Name where { toInterm = return; fromInterm = return; }++-- Not for export: here are a bunch of shortcuts to converting the AST to the intermediate data+-- type. Sinec 'toInterm' returns a single item in a list to indicate success and an empty list to+-- indicate failure, all of these items have their evaluated type wrapped in a list type. This is to+-- allow the 'toInterm' instances use the 'Control.Monad.liftM' family of functions.+ti :: Intermediate obj ast => ast -> [obj]+ti = toInterm+uc :: Com a -> [a]+uc = return . unComment+uc0 :: Intermediate obj ast =>  Com ast  -> [obj]+uc0 = toInterm . unComment+um1 :: Intermediate obj ast => Maybe ast -> [Maybe obj]+um1 = maybe [Nothing] (fmap Just . toInterm)++fi :: Intermediate obj ast => obj -> [ast]+fi = fromInterm+nc :: a -> [Com a]+nc = return . Com+nc0 :: Intermediate obj ast => obj -> [Com ast]+nc0 = fmap Com . fromInterm+nm1 :: Intermediate obj ast => Maybe obj -> [Maybe ast]+nm1 = maybe [Nothing] (fmap Just . fromInterm)++-- not for export+no :: RandO Location+no = return LocationUnknown++-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type+-- that is pretty-printable ('Dao.PPrint.PPrintable').+pPrintInterm :: (Intermediate o ast, PPrintable ast) => o -> PPrint+pPrintInterm = mapM_ pPrint . fromInterm++-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type+-- that is 'Dao.Binary.GPut'.+putAST :: (Intermediate obj ast, B.Binary obj mtab) => ast -> B.GPut mtab+putAST ast = case toInterm ast of+    [obj] -> B.put obj+    _     -> fail "binary encoder could not convert AST to intermediate expression"++-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type+-- that is 'Dao.Binary.GGet'.+getAST :: (Intermediate obj ast, B.Binary obj mtab) => B.GGet mtab ast+getAST = B.get >>= \obj -> case fromInterm obj of+    [ast] -> return ast+    _     -> fail "binary decoder constructed object that could not be converted to an AST representation"++----------------------------------------------------------------------------------------------------++-- | Comments in the Dao language are not interpreted, but they are not disgarded either. Dao is+-- intended to manipulate natural language, and itself, so that it can "learn" new semantic+-- structures. Dao scripts can manipulate the syntax tree of other Dao scripts, and so it might be+-- helpful if the syntax tree included comments.+data Comment+  = InlineComment  UStr+  | EndlineComment UStr+  deriving (Eq, Ord, Typeable, Show)++commentString :: Comment -> UStr+commentString com = case com of+  InlineComment  a -> a+  EndlineComment a -> a++instance NFData Comment where+  rnf (InlineComment  a) = seq a ()+  rnf (EndlineComment a) = seq a ()++instance HasNullValue Comment where+  nullValue = EndlineComment nil+  testNull (EndlineComment c) = c==nil+  testNull (InlineComment  c) = c==nil++instance PPrintable Comment where+  pPrint com = do+    case com of+      EndlineComment c -> pString ("//"++uchars c) >> pForceNewLine+      InlineComment  c -> pGroup True $ pInline $+        concat [[pString " /*"], map pString (lines (uchars c)), [pString "*/ "]]++instance PrecedeWithSpace a => PrecedeWithSpace (Com a) where+  precedeWithSpace o = case o of+    Com         b   -> precedeWithSpace b+    ComBefore a b   -> precedeWithSpace a || precedeWithSpace b+    ComAfter    b _ -> precedeWithSpace b+    ComAround a b _ -> precedeWithSpace a || precedeWithSpace b+    -- there should always be a space before a comment.++instance PPrintable [Comment] where { pPrint = mapM_ pPrint }++instance PrecedeWithSpace [Comment] where { precedeWithSpace = not . null }++instance HasRandGen [Comment] where { randO = return []; defaultO = return []; }+--  randO = do+--    i0 <- randInt+--    let (i1, many) = divMod i0 4+--        (i2, typn) = divMod i1 16+--        typx = take many (randToBase 2 typn ++ replicate 4 0)+--        lenx = map (+1) (randToBase 29 i2)+--        com typ = if typ==0 then EndlineComment else InlineComment+--    forM (zip typx lenx) $ \ (typ, len) ->+--      fmap (com typ . ustr . unwords . map (B.unpack . getRandomWord)) (replicateM len randInt)++----------------------------------------------------------------------------------------------------++-- | Symbols in the Dao syntax tree that can actually be manipulated can be surrounded by comments.+-- The 'Com' structure represents a space-efficient means to surround each syntactic element with+-- comments that can be ignored without disgarding them.+data Com a = Com a | ComBefore [Comment] a | ComAfter a [Comment] | ComAround [Comment] a [Comment]+  deriving (Eq, Ord, Typeable, Show)++instance Functor Com where+  fmap fn c = case c of+    Com          a    -> Com          (fn a)+    ComBefore c1 a    -> ComBefore c1 (fn a)+    ComAfter     a c2 -> ComAfter     (fn a) c2+    ComAround c1 a c2 -> ComAround c1 (fn a) c2++instance NFData a => NFData (Com a) where+  rnf (Com         a  ) = deepseq a ()+  rnf (ComBefore a b  ) = deepseq a $! deepseq b ()+  rnf (ComAfter    a b) = deepseq a $! deepseq b ()+  rnf (ComAround a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue a => HasNullValue (Com a) where+  nullValue = Com nullValue+  testNull (Com a) = testNull a+  testNull _ = False++instance HasLocation a => HasLocation (Com a) where+  getLocation = getLocation . unComment+  setLocation com loc = fmap (\a -> setLocation a loc) com+  delLocation = fmap delLocation++instance HasRandGen a => HasRandGen (Com a) where+  randO    = Com <$> randO+  defaultO = Com <$> defaultO++instance PPrintable a => PPrintable (Com a) where { pPrint = pPrintComWith pPrint }++pPrintComWith :: (a -> PPrint) -> Com a -> PPrint+pPrintComWith prin com = case com of+  Com          c    -> prin c+  ComBefore ax c    -> pcom ax >> prin c+  ComAfter     c bx -> prin c >> pcom bx+  ComAround ax c bx -> pcom ax >> prin c >> pcom bx+  where { pcom = pInline . map pPrint }++pListOfComsWith :: (a -> PPrint) -> [Com a] -> PPrint+pListOfComsWith prin = sequence_ . map (pPrintComWith prin)++pListOfComs :: PPrintable a => [Com a] -> PPrint+pListOfComs = pListOfComsWith pPrint++randComWith :: RandO a -> RandO (Com a)+randComWith rand = fmap Com rand+--  randComWith :: RandO a -> RandO (Com a)+--  randComWith rand = do+--    typ <- fmap (flip mod 24 . unsign) randInt+--    a <- rand+--    case typ of+--      0 -> do+--        before <- randO+--        after  <- randO+--        return (ComAround before a after)+--      1 -> do+--        before <- randO+--        return (ComBefore before a)+--      2 -> do+--        after <- randO+--        return (ComAfter a after)+--      _ -> return (Com a)++appendComments :: Com a -> [Comment] -> Com a+appendComments com cx = case com of+  Com          a    -> ComAfter     a cx+  ComAfter     a ax -> ComAfter     a (ax++cx)+  ComBefore ax a    -> ComAround ax a cx+  ComAround ax a bx -> ComAround ax a (bx++cx)++com :: [Comment] -> a -> [Comment] -> Com a+com before a after = case before of+  [] -> case after of+    [] -> Com a+    dx -> ComAfter a dx+  cx -> case after of+    [] -> ComBefore cx a+    dx -> ComAround cx a dx++setCommentBefore :: [Comment] -> Com a -> Com a+setCommentBefore cx com = case com of+  Com         a    -> ComBefore cx a+  ComBefore _ a    -> ComBefore cx a+  ComAfter    a dx -> ComAround cx a dx+  ComAround _ a dx -> ComAround cx a dx++setCommentAfter :: [Comment] -> Com a -> Com a+setCommentAfter cx com = case com of+  Com          a   -> ComAfter     a cx+  ComBefore dx a   -> ComAround dx a cx+  ComAfter     a _ -> ComAfter     a cx+  ComAround dx a _ -> ComAround dx a cx++unComment :: Com a -> a+unComment com = case com of+  Com         a   -> a+  ComBefore _ a   -> a+  ComAfter    a _ -> a+  ComAround _ a _ -> a++getComment :: Com a -> ([Comment], [Comment])+getComment com = case com of+  Com         _   -> ([], [])+  ComBefore a _   -> (a, [])+  ComAfter    _ b -> ([], b)+  ComAround a _ b -> (a, b)++----------------------------------------------------------------------------------------------------++-- | Direct a reference at a particular tree in the runtime.+data RefQualifier+  = UNQUAL -- ^ unqualified+  | LOCAL  -- ^ refers to the current local variable stack+  | CONST  -- ^ refers to a built-in constant+  | STATIC -- ^ a local variable stack specific to a 'Subroutine' that lives on even after the+           -- subroutine has completed.+  | GLOBAL -- ^ the global variable space for the current module.+  | GLODOT -- ^ a relative reference, gets it's name because it begins with a dot (".") character.+           -- Similar to the "this" keyword in C++ and Java, refers to the object of the current+           -- context set by the "with" statement, but defaults to the global variable space when+           -- not within a "with" statement. This is necessary to differentiate between local+           -- variables and references to the "with" context.+  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)++instance NFData RefQualifier where { rnf a = seq a () }++instance PPrintable RefQualifier where { pPrint = pUStr . toUStr }++instance PrecedeWithSpace RefQualifier where+   precedeWithSpace o = case o of+     LOCAL  -> True+     CONST  -> True+     STATIC -> True+     GLOBAL -> True+     _      -> False++instance UStrType RefQualifier where+  toUStr a = ustr $ case a of+    UNQUAL -> ""+    LOCAL  -> "local"+    CONST  -> "const"+    STATIC -> "static"+    GLOBAL -> "global"+    GLODOT -> "."+  maybeFromUStr str = case uchars str of+    "local"  -> Just LOCAL+    "const"  -> Just CONST+    "static" -> Just STATIC+    "global" -> Just GLOBAL+    "."      -> Just GLODOT+    ""       -> Just UNQUAL+    _        -> Nothing+  fromUStr str = maybe (error (show str++" is not a reference qualifier")) id (maybeFromUStr str)++instance HasRandGen RefQualifier where+  randO = fmap toEnum (nextInt (1+fromEnum (minBound::RefQualifier)))+  defaultO = randO++----------------------------------------------------------------------------------------------------++-- | Binary operators.+data InfixOp+  = ADD   | SUB   | MULT+  | DIV   | MOD   | POW+  | ORB   | ANDB  | XORB+  | SHL   | SHR+  | OR    | AND+  | EQUL  | NEQUL      +  | GTN   | LTN+  | GTEQ  | LTEQ+  | ARROW+  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)++instance UStrType InfixOp where+  toUStr a = ustr $ case a of+    { ADD  -> "+" ; SUB  -> "-" ; MULT  -> "*"+    ; DIV  -> "/" ; MOD  -> "%" ; POW   -> "**"+    ; ORB  -> "|" ; ANDB -> "&" ; XORB  -> "^"+    ; SHL  -> "<<"; SHR  -> ">>"+    ; OR   -> "||"; AND  -> "&&"+    ; EQUL -> "=="; NEQUL-> "!="+    ; LTN  -> "<" ; GTN  -> ">"+    ; LTEQ -> "<="; GTEQ -> ">="+    ; ARROW -> "->";+    }+  maybeFromUStr str = case uchars str of+    { "+"  -> Just ADD  ; "-"  -> Just SUB  ; "*"  -> Just MULT +    ; "/"  -> Just DIV  ; "%"  -> Just MOD  ; "**" -> Just POW  +    ; "|"  -> Just ORB  ; "&"  -> Just ANDB ; "^"  -> Just XORB +    ; "<<" -> Just SHL  ; ">>" -> Just SHR+    ; "||" -> Just OR   ; "&&" -> Just AND+    ; "==" -> Just EQUL ; "!=" -> Just NEQUL+    ; "<"  -> Just LTN  ; ">"  -> Just GTN+    ; "<=" -> Just LTEQ ; ">=" -> Just GTEQ +    ; "->" -> Just ARROW;+    ; _    -> Nothing+    }+  fromUStr str = maybe (error (show str++" is not an infix operator")) id (maybeFromUStr str)++instance NFData InfixOp  where { rnf a = seq a () }++instance PPrintable InfixOp  where { pPrint = pUStr . toUStr }++infixOpCommutativity :: InfixOp -> Bool+infixOpCommutativity = (arr !) where+  arr :: Array InfixOp Bool+  arr = array (minBound, maxBound) $+    [ (ADD, True), (SUB, False), (MULT, True), (DIV, False), (MOD, False), (POW, False)+    , (ORB, True), (ANDB, True), (XORB, True), (SHL, False), (SHR, False), (OR, False), (AND, False)+    , (EQUL, True), (NEQUL, True), (LTN, False), (GTN, False), (LTEQ, False), (GTEQ, False)+    , (ARROW, False)+    ]++-- binary 0x8D 0xA0+instance B.Binary InfixOp mtab where+  put o = B.putWord8 $ case o of+    { EQUL -> 0x8D; NEQUL -> 0x8E; GTN  -> 0x8F; LTN   -> 0x90; GTEQ -> 0x91; LTEQ -> 0x92+    ; ADD  -> 0x93; SUB   -> 0x94; MULT -> 0x95; DIV   -> 0x96+    ; MOD  -> 0x97; POW   -> 0x98; ORB  -> 0x99; ANDB  -> 0x9A+    ; XORB -> 0x9B; SHL   -> 0x9C; SHR  -> 0x9D; ARROW -> 0x9E+    ; OR   -> 0x9F; AND   -> 0xA0 } +  get = B.word8PrefixTable <|> fail "expecting InfixOp"++-- The byte prefixes overlap with the update operators of similar function to+-- the operators, except for the comparison opeators (EQUL, NEQUL, GTN, LTN,+-- GTEQ, LTEQ) which overlap with the prefix operators (INVB, NOT, NEGTIV, POSTIV, REF, DEREF)+instance B.HasPrefixTable InfixOp B.Byte mtab where+  prefixTable = B.mkPrefixTableWord8 "InfixOp" 0x8D 0xA0 $ let {r=return} in+    [ r EQUL , r NEQUL, r GTN , r LTN, r GTEQ , r LTEQ -- 0x8D,0x8E,0x8F,0x90,0x91,0x92+    , r ADD  , r SUB  , r MULT, r DIV, r MOD  , r POW  , r ORB -- 0x93,0x94,0x95,0x96,0x97,0x98,0x99+    , r ANDB , r XORB , r SHL , r SHR, r ARROW, r OR   , r AND -- 0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,0xA0+    ]++instance HasRandGen InfixOp where+  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::InfixOp)))+  defaultO = randO++allPrefixOpChars :: String+allPrefixOpChars = "$@~!-+"++allPrefixOpStrs :: String+allPrefixOpStrs = " $ @ ~ - + ! "++----------------------------------------------------------------------------------------------------++-- | Unary operators.+data ArithPfxOp = INVB | NOT | NEGTIV | POSTIV+  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)++instance NFData ArithPfxOp where { rnf a = seq a () }++instance UStrType ArithPfxOp where+  toUStr op = ustr $ case op of+    INVB   -> "~"+    NOT    -> "!"+    NEGTIV -> "-"+    POSTIV -> "+"+  maybeFromUStr str = case uchars str of+    "~" -> Just INVB+    "!" -> Just NOT+    "-" -> Just NEGTIV+    "+" -> Just POSTIV+    _   -> Nothing+  fromUStr str = maybe (error (show str++" is not a prefix opretor")) id (maybeFromUStr str)++instance PPrintable ArithPfxOp where { pPrint = pUStr . toUStr }++-- binary 0x8E 0x9B+instance B.Binary ArithPfxOp mtab where+  put o = B.putWord8 $ case o of { INVB -> 0x9B; NOT -> 0x8E; NEGTIV -> 0x94; POSTIV -> 0x93 }+  get = B.word8PrefixTable <|> fail "expecting ArithPfxOp"++instance B.HasPrefixTable ArithPfxOp B.Byte mtab where+  prefixTable = B.mkPrefixTableWord8 "ArithPfxOp" 0x8E 0x9F $ let {r=return;z=mzero} in+    [ r NOT -- 0x8E+    , z, z, z, z -- 0x8F,0x90,0x91,0x92+    , r POSTIV, r NEGTIV -- 0x93,0x94+    , z, z, z, z, z, z -- 0x95,0x96,0x97,0x98,0x99,0x9A+    , r INVB -- 0x9B+    ]++instance HasRandGen ArithPfxOp where+  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::ArithPfxOp)))+  defaultO = randO++allInfixOpChars :: String+allInfixOpChars = "+-*/%<>^&|.?:"++allInfixOpStrs :: String+allInfixOpStrs = " + - * / % ** -> . || && == != | & ^ << >> < > <= >= . -> <- ? : :: "++----------------------------------------------------------------------------------------------------++newtype DotNameExpr = DotNameExpr{ undotNameExpr :: Name } deriving (Eq, Ord, Show, Typeable)++instance NFData DotNameExpr where { rnf (DotNameExpr n) = deepseq n () }++instance B.Binary DotNameExpr mtab where { put (DotNameExpr n) = B.put n; get = DotNameExpr <$> B.get; }++instance PPrintable DotNameExpr where { pPrint (DotNameExpr n) = pPrint n }++-- | A 'DotName' is simply a ".name" expression in the Dao language. It is a component of the+-- 'DotLabelExpr' and 'AST_DotLabel' data types.+data AST_DotName = AST_DotName (Com ()) Name deriving (Eq, Ord, Show, Typeable)++getDotNameAST :: AST_DotName -> Name+getDotNameAST (AST_DotName _ n) = n++instance NFData AST_DotName where { rnf (AST_DotName a b) = deepseq a $! deepseq b () }++instance PPrintable AST_DotName where+  pPrint (AST_DotName c n) = pInline [pPrintComWith (\ () -> pString ".") c, pPrint n]++instance Intermediate DotNameExpr AST_DotName where+  toInterm   (AST_DotName _ n) = [DotNameExpr n]+  fromInterm (DotNameExpr   n) = [AST_DotName (Com ()) n]++----------------------------------------------------------------------------------------------------++data NamespaceExpr = NamespaceExpr (Maybe Name) Location deriving (Eq, Ord, Show, Typeable)++instance NFData NamespaceExpr where { rnf (NamespaceExpr a b) = deepseq a $! deepseq b () }++instance HasNullValue NamespaceExpr where+  nullValue = NamespaceExpr Nothing LocationUnknown+  testNull (NamespaceExpr Nothing _) = True+  testNull _ = False++instance HasLocation NamespaceExpr where+  getLocation (NamespaceExpr _ loc)     = loc+  setLocation (NamespaceExpr a _  ) loc = NamespaceExpr a loc+  delLocation (NamespaceExpr a _  )     = NamespaceExpr a LocationUnknown++instance PPrintable NamespaceExpr where { pPrint = pPrintInterm }++instance B.Binary NamespaceExpr mtab where+  put (NamespaceExpr a loc) = B.put a >> B.put loc+  get = return NamespaceExpr <*> B.get <*> B.get++----------------------------------------------------------------------------------------------------++data AST_Namespace+  = AST_NoNamespace+  | AST_Namespace (Com Name) Location+  deriving (Eq, Ord, Show, Typeable)++instance NFData AST_Namespace where+  rnf  AST_NoNamespace    = ()+  rnf (AST_Namespace a b) = deepseq a $! deepseq b ()++instance HasNullValue AST_Namespace where+  nullValue = AST_NoNamespace+  testNull AST_NoNamespace = True+  testNull _ = False++instance HasLocation AST_Namespace where+  getLocation o     = case o of+    AST_NoNamespace     -> LocationUnknown+    AST_Namespace _ loc -> loc+  setLocation o loc = case o of+    AST_NoNamespace     -> AST_NoNamespace+    AST_Namespace a _   -> AST_Namespace a loc+  delLocation o     = case o of+    AST_NoNamespace     -> AST_NoNamespace+    AST_Namespace a _   -> AST_Namespace a LocationUnknown++instance PPrintable AST_Namespace where+  pPrint o = case o of { AST_NoNamespace -> return (); AST_Namespace a _ -> pPrint a; }++instance HasRandGen AST_Namespace where+  randO = countNode $ runRandChoice+  randChoice = randChoiceList [return AST_NoNamespace, return AST_Namespace <*> randO <*> no]+  defaultO = randO+  defaultChoice = randChoiceList [defaultO]++instance Intermediate NamespaceExpr AST_Namespace where+  toInterm o = case o of+    AST_NoNamespace     -> [nullValue]+    AST_Namespace n loc -> [NamespaceExpr (Just $ unComment n) loc]+  fromInterm (NamespaceExpr n loc) = case n of+    Nothing -> [nullValue]+    Just  n -> [AST_Namespace (Com n) loc]++----------------------------------------------------------------------------------------------------++-- | The intermediate form of 'AST_DotLabel'.+data DotLabelExpr = DotLabelExpr DotNameExpr [DotNameExpr] Location +  deriving (Eq, Ord, Show, Typeable)++instance NFData DotLabelExpr where+  rnf (DotLabelExpr n nm loc) = deepseq n $! deepseq nm $! deepseq loc ()++instance HasLocation DotLabelExpr where+  getLocation (DotLabelExpr _ _  loc)     = loc+  setLocation (DotLabelExpr n nx _  ) loc = DotLabelExpr n nx loc+  delLocation (DotLabelExpr n nx _  )     = DotLabelExpr n nx LocationUnknown++instance B.Binary DotLabelExpr mtab where+  put (DotLabelExpr n nx loc) = B.prefixByte 0x81 $ B.put n >> B.put nx >> B.put loc+  get = B.word8PrefixTable <|> fail "expecting DotLabelExpr"++instance B.HasPrefixTable DotLabelExpr Word8 mtab where+  prefixTable = B.mkPrefixTableWord8 "DotLabelExpr" 0x81 0x81 $+    [return DotLabelExpr <*> B.get <*> B.get <*> B.get]++instance PPrintable DotLabelExpr where { pPrint = pPrintInterm }++dotLabelToNameList :: DotLabelExpr -> [Name]+dotLabelToNameList (DotLabelExpr n nx _) = map undotNameExpr (n:nx)++----------------------------------------------------------------------------------------------------++-- | This is a list of 'Dao.String.Name's separated by dots. It is a pseudo-reference used to denote+-- things like constructor names in 'InitExpr', or setting the logical names of "import" modules+-- statements. It is basically a list of 'Dao.String.Name's that always has at least one element.+data AST_DotLabel = AST_DotLabel Name [AST_DotName] Location deriving (Eq, Ord, Show, Typeable)++instance NFData AST_DotLabel where+  rnf (AST_DotLabel n nx loc) = deepseq n $! deepseq nx $! deepseq loc ()++instance HasLocation AST_DotLabel where+  getLocation (AST_DotLabel _ _  loc)     = loc+  setLocation (AST_DotLabel n nx _  ) loc = AST_DotLabel n nx loc+  delLocation (AST_DotLabel n nx _  )     = AST_DotLabel n nx LocationUnknown++instance PPrintable AST_DotLabel where+  pPrint (AST_DotLabel n nx _) = pWrapIndent $ pPrint n : map pPrint nx++instance HasRandGen AST_DotLabel where+  randO = return AST_DotLabel <*> randO <*> randListOf 0 3 (return AST_DotName <*> randO <*> randO) <*> no+  defaultO = randO++instance Intermediate DotLabelExpr AST_DotLabel where+  toInterm   (AST_DotLabel              n  nx loc) = [DotLabelExpr] <*> [DotNameExpr n] <*> [nx >>= ti] <*> [loc]+  fromInterm (DotLabelExpr (DotNameExpr n) nx loc) = [AST_DotLabel] <*>             [n] <*> [nx >>= fi] <*> [loc]++dotLabelToRefExpr :: DotLabelExpr -> ReferenceExpr o+dotLabelToRefExpr (DotLabelExpr (DotNameExpr n) nx loc) =+  ReferenceExpr UNQUAL n (loop nx) loc where+    loop nx = case nx of+      []                 -> NullRefExpr+      (DotNameExpr n):nx -> DotRefExpr n (loop nx) LocationUnknown++refToDotLabelExpr :: ReferenceExpr o -> Maybe (DotLabelExpr, Maybe (ObjListExpr o))+refToDotLabelExpr o = case o of+  ReferenceExpr UNQUAL n suf loc ->+    loop (\nx loc ol -> (DotLabelExpr (DotNameExpr n) nx loc, ol)) [] loc suf+  _ -> mzero+  where+    loop f nx loc suf = case suf of+      NullRefExpr                 -> return (f nx loc Nothing)+      DotRefExpr   n  suf    loc' -> loop f (nx++[DotNameExpr n]) (loc<>loc') suf+      FuncCallExpr ol NullRefExpr -> return (f nx loc (Just ol))+      _                           -> mzero++dotLabelToRefAST :: AST_DotLabel -> AST_Reference o+dotLabelToRefAST (AST_DotLabel n nx loc) = AST_Reference UNQUAL [] n (loop nx) loc where+  loop nx = case nx of+    []                   -> AST_RefNull+    (AST_DotName c n):nx -> AST_DotRef c n (loop nx) LocationUnknown++refToDotLabelAST :: AST_Reference o -> Maybe (AST_DotLabel, Maybe (AST_ObjList o))+refToDotLabelAST o = case o of+  AST_Reference UNQUAL _ n suf loc -> loop (\nx loc ol -> (AST_DotLabel n nx loc, ol)) [] loc suf+  _                                -> mzero+  where+    loop f nx loc suf = case suf of+      AST_RefNull                 -> return (f nx loc Nothing)+      AST_DotRef c n  suf    loc' -> loop f (nx++[AST_DotName c n]) (loc<>loc') suf+      AST_FuncCall ol AST_RefNull -> return (f nx loc (Just ol))+      _                           -> mzero++----------------------------------------------------------------------------------------------------++data RefSuffixExpr o+  = NullRefExpr+  | DotRefExpr    Name        (RefSuffixExpr o) Location+  | SubscriptExpr (ObjListExpr o) (RefSuffixExpr o)+  | FuncCallExpr  (ObjListExpr o) (RefSuffixExpr o)+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (RefSuffixExpr o) where+  rnf  NullRefExpr          = ()+  rnf (DotRefExpr    a b c) = deepseq a $! deepseq b $! deepseq c ()+  rnf (SubscriptExpr a b  ) = deepseq a $! deepseq b ()+  rnf (FuncCallExpr  a b  ) = deepseq a $! deepseq b ()++instance HasNullValue (RefSuffixExpr o) where+  nullValue = NullRefExpr+  testNull NullRefExpr = True+  testNull _           = False++instance HasLocation (RefSuffixExpr o) where+  getLocation o = case o of+    NullRefExpr           -> LocationUnknown+    DotRefExpr    _ _ loc -> loc+    SubscriptExpr a _     -> getLocation a+    FuncCallExpr  a _     -> getLocation a+  setLocation o loc = case o of+    NullRefExpr           -> NullRefExpr+    DotRefExpr    a b _   -> DotRefExpr    a b loc+    SubscriptExpr a b     -> SubscriptExpr (setLocation a loc) b+    FuncCallExpr  a b     -> FuncCallExpr  (setLocation a loc) b+  delLocation o     = case o of+    NullRefExpr           -> NullRefExpr+    DotRefExpr    a b _   -> DotRefExpr    a (delLocation b) LocationUnknown+    SubscriptExpr a b     -> SubscriptExpr a (delLocation b)+    FuncCallExpr  a b     -> FuncCallExpr  a (delLocation b)++----------------------------------------------------------------------------------------------------++-- | Anything that follows a reference, which could be square-bracketed indecies, function+-- parameters, or a dot and another reference. This is actually only a partial reference. The+-- 'Reference' is the full reference. The item selected by the 'Reference' is then further inspected+-- using a 'RefSuffix'; a 'RefSuffix' may be null, but a 'Reference' is never null.+data AST_RefSuffix o+  = AST_RefNull+  | AST_DotRef    (Com ()) Name (AST_RefSuffix o) Location+  | AST_Subscript (AST_ObjList o)   (AST_RefSuffix o)+  | AST_FuncCall  (AST_ObjList o)   (AST_RefSuffix o)+  deriving (Eq, Ord, Typeable, Show, Functor)++instance HasNullValue (AST_RefSuffix o) where+  nullValue = AST_RefNull+  testNull AST_RefNull = True+  testNull _ = False++instance HasLocation (AST_RefSuffix o) where+  getLocation o     = case o of+    AST_RefNull             -> LocationUnknown+    AST_DotRef    _ _ _ loc -> loc+    AST_Subscript a _       -> getLocation a+    AST_FuncCall  a _       -> getLocation a+  setLocation o loc = case o of+    AST_RefNull           -> AST_RefNull+    AST_DotRef    a b c _ -> AST_DotRef  a b c loc+    AST_Subscript a b     -> AST_Subscript (setLocation a loc) b+    AST_FuncCall  a b     -> AST_FuncCall  (setLocation a loc) b+  delLocation o     = case o of+    AST_RefNull           -> AST_RefNull+    AST_DotRef    a b c _ -> AST_DotRef  a b (delLocation c) LocationUnknown+    AST_Subscript a b     -> AST_Subscript (delLocation a) (delLocation b)+    AST_FuncCall  a b     -> AST_FuncCall  (delLocation a) (delLocation b)++instance PPrintable o => PPrintable (AST_RefSuffix o) where+  pPrint = pWrapIndent . loop where+    loop ref = case ref of+      AST_RefNull                  -> []+      AST_DotRef    dot name ref _ -> pPrintComWith (\ () -> pString ".") dot : pUStr (toUStr name) : loop ref+      AST_Subscript args     ref   -> pArgs "[]" args ++ loop ref+      AST_FuncCall  args     ref   -> pArgs "()" args ++ loop ref+      where+        pArgs str args = case str of+          (open:close:_) -> [pString [open], pPrint args, pString [close]]+          _              -> error "INTERNAL: bad instance definition of PPrintable AST_RefSuffix"++instance NFData o => NFData (AST_RefSuffix o) where+  rnf  AST_RefNull            = ()+  rnf (AST_DotRef    a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (AST_Subscript a b    ) = deepseq a $! deepseq b ()+  rnf (AST_FuncCall  a b    ) = deepseq a $! deepseq b ()++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RefSuffix o) where+  randO = recurse $ countNode $ runRandChoice+  randChoice = randChoiceList $+    [ return AST_RefNull+    , scramble $ return AST_DotRef    <*> randO <*> randO <*> randO <*> no+    , scramble $ return AST_Subscript <*> randO <*> randO+    , scramble $ return AST_FuncCall  <*> randO <*> randO+    ]+  defaultO = runDefaultChoice+  defaultChoice = randChoiceList $+    [ return AST_RefNull+    , return AST_DotRef <*> defaultO <*> randO <*> pure AST_RefNull <*> no+    , return AST_Subscript <*> pure nullValue <*> pure AST_RefNull+    , return AST_FuncCall  <*> pure nullValue <*> pure AST_RefNull+    ]++instance Intermediate (RefSuffixExpr o) (AST_RefSuffix o) where+  toInterm   ast = case ast of+    AST_RefNull                -> [NullRefExpr]+    AST_DotRef  _ name ref loc -> [DotRefExpr]    <*> [name]        <*> toInterm ref <*> [loc]+    AST_Subscript args ref     -> [SubscriptExpr] <*> toInterm args <*> toInterm ref+    AST_FuncCall  args ref     -> [FuncCallExpr]  <*> toInterm args <*> toInterm ref+  fromInterm obj = case obj of+    NullRefExpr                -> [AST_RefNull]+    DotRefExpr    name ref loc -> [AST_DotRef] <*> [Com ()] <*> [name] <*> fromInterm ref <*> [loc]+    SubscriptExpr args ref     -> [AST_Subscript] <*> fromInterm args <*> fromInterm ref+    FuncCallExpr  args ref     -> [AST_FuncCall]  <*> fromInterm args <*> fromInterm ref++----------------------------------------------------------------------------------------------------++data ReferenceExpr o+  = RefObjectExpr (ParenExpr o)     (RefSuffixExpr o) Location+  | ReferenceExpr RefQualifier Name (RefSuffixExpr o) Location+    -- ^ reference suffixed by square brackets or round brackets. If the 3rd parameter is False, it+    -- is suffixed by square brackets, and True means suffixed by round brackets. Square brackets+    -- indicates an indexing expression, round brackets indicates a function call.+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (ReferenceExpr o) where+  rnf (RefObjectExpr a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (ReferenceExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (ReferenceExpr o) where+  nullValue = RefObjectExpr nullValue NullRefExpr LocationUnknown+  testNull (RefObjectExpr a NullRefExpr LocationUnknown) = testNull a+  testNull _                                             = False++instance HasLocation (ReferenceExpr o) where+  getLocation o     = case o of+    RefObjectExpr _ _   loc -> loc+    ReferenceExpr _ _ _ loc -> loc+  setLocation o loc = case o of+    RefObjectExpr a b _     -> RefObjectExpr a b   loc+    ReferenceExpr a b c loc -> ReferenceExpr a b c loc+  delLocation o    = case o of+    RefObjectExpr a b _     -> RefObjectExpr (delLocation a) b   LocationUnknown+    ReferenceExpr a b c _   -> ReferenceExpr              a  b c LocationUnknown++instance PPrintable o => PPrintable (ReferenceExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++data AST_Reference o+  = AST_RefObject (AST_Paren o)               (AST_RefSuffix o) Location+  | AST_Reference RefQualifier [Comment] Name (AST_RefSuffix o) Location+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (AST_Reference o) where+  rnf (AST_RefObject a b c    ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (AST_Reference a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e ()++instance HasLocation (AST_Reference o) where+  getLocation o     = case o of+    AST_RefObject _ _     loc -> loc+    AST_Reference _ _ _ _ loc -> loc+  setLocation o loc = case o of+    AST_RefObject a b     _   -> AST_RefObject a b     loc+    AST_Reference a b c d _   -> AST_Reference  a b c d loc+  delLocation o     = case o of+    AST_RefObject a b     _   -> AST_RefObject (delLocation a) (delLocation b) LocationUnknown+    AST_Reference a b c d _   -> AST_Reference a b c (delLocation d) LocationUnknown++instance PPrintable o => PPrintable (AST_Reference o) where+  pPrint o = pInline $ case o of+    AST_RefObject  o           ref _ -> [pPrint o, pPrint ref]+    AST_Reference  q coms name ref _ -> concat $+      [ if q==UNQUAL then [] else [pPrint q, pString " "]+      , [pPrint coms, pUStr (toUStr name), pPrint ref]+      ]++instance PrecedeWithSpace (AST_Reference o) where { precedeWithSpace _ = True }++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Reference o) where+  randO = countNode $ runRandChoice+  randChoice = randChoiceList $+    [ scramble $ return AST_Reference <*> randO <*> randO <*> randO <*> randO <*> no+    , scramble $ return AST_RefObject <*> randO <*> randO <*> no+    ]+  defaultO = runDefaultChoice+  defaultChoice = randChoiceList $+    [ return AST_Reference <*> defaultO <*> defaultO <*> defaultO <*> defaultO <*> no+    , return AST_RefObject <*> defaultO <*> defaultO <*> no+    ]++instance Intermediate (ReferenceExpr o) (AST_Reference o) where+  toInterm ast = case ast of+    AST_RefObject paren    ref loc -> [RefObjectExpr] <*> ti paren <*> ti ref            <*> [loc]+    AST_Reference q _ name ref loc -> [ReferenceExpr] <*> [q]      <*> [name] <*> ti ref <*> [loc]+  fromInterm o = case o of+    RefObjectExpr paren  ref loc -> [AST_RefObject] <*> fi paren <*> fi ref <*> [loc]+    ReferenceExpr q name ref loc ->+      [AST_Reference] <*> [q] <*> [[]] <*> [name]  <*> fi ref <*> [loc]++----------------------------------------------------------------------------------------------------++data RefPrefixExpr o+  = PlainRefExpr  (ReferenceExpr o)+  | RefPrefixExpr RefPfxOp (RefPrefixExpr o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++-- | Eliminate composed DEREF-REF operations+-- > @$a == a+cleanupRefPrefixExpr :: RefPrefixExpr o -> RefPrefixExpr o+cleanupRefPrefixExpr o =+  case o of { RefPrefixExpr DEREF (RefPrefixExpr REF o _) _ -> cleanupRefPrefixExpr o; _ -> o; }++instance NFData o => NFData (RefPrefixExpr o) where+  rnf (RefPrefixExpr a b c) = deepseq a $! deepseq b $! deepseq c ()+  rnf (PlainRefExpr  a    ) = deepseq a ()++instance HasNullValue (RefPrefixExpr o) where+  nullValue = PlainRefExpr nullValue+  testNull (PlainRefExpr a) = testNull a+  testNull _ = False++instance HasLocation (RefPrefixExpr o) where+  getLocation o     = case o of+    PlainRefExpr      o -> getLocation o+    RefPrefixExpr _ _ o -> o+  setLocation o loc = case o of+    PlainRefExpr  a     -> PlainRefExpr (setLocation a loc)+    RefPrefixExpr a b _ -> RefPrefixExpr a b loc+  delLocation o     = case o of+    PlainRefExpr  a     -> PlainRefExpr (delLocation a)+    RefPrefixExpr a b _ -> RefPrefixExpr a (delLocation b) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_RefPrefix o+  = AST_PlainRef  (AST_Reference o)+  | AST_RefPrefix RefPfxOp [Comment] (AST_RefPrefix o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_RefPrefix o) where+  rnf (AST_PlainRef  a      ) = deepseq a ()+  rnf (AST_RefPrefix a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d  ()++instance HasLocation (AST_RefPrefix o) where+  getLocation o     = case o of+    AST_PlainRef  a         -> getLocation a+    AST_RefPrefix _ _ _ loc -> loc+  setLocation o loc = case o of+    AST_PlainRef  a         -> AST_PlainRef $ setLocation a loc+    AST_RefPrefix a b c _   -> AST_RefPrefix a b c loc+  delLocation o     = case o of+    AST_PlainRef  a         -> AST_PlainRef $ delLocation a+    AST_RefPrefix a b c _   -> AST_RefPrefix a b (delLocation c) LocationUnknown++instance PPrintable o => PPrintable (AST_RefPrefix o) where+  pPrint o = case o of+    AST_PlainRef o                   -> pPrint o+    AST_RefPrefix ariOp coms objXp _ -> pWrapIndent [pPrint ariOp, pPrint coms, pPrint objXp]++instance PrecedeWithSpace (AST_RefPrefix o) where+  precedeWithSpace o = case o of+    AST_PlainRef _ -> True+    _              -> False++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RefPrefix o) where+  randO      = recurse $ countNode $ runRandChoice+  randChoice = randChoiceList $+    [ return AST_PlainRef  <*> randO+    , return AST_RefPrefix <*> randO <*> randO <*> randO <*> no+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ AST_PlainRef <$> defaultO+    , return AST_RefPrefix <*> defaultO <*> defaultO <*> (AST_PlainRef <$> defaultO) <*> no+    ]++instance Intermediate (RefPrefixExpr o) (AST_RefPrefix o) where+  toInterm ast = case ast of+    AST_PlainRef  a         -> PlainRefExpr <$> toInterm a+    AST_RefPrefix a _ c loc -> [RefPrefixExpr] <*> [a] <*> toInterm c <*> [loc]+  fromInterm o = case o of+    PlainRefExpr  a       -> AST_PlainRef <$> fromInterm a+    RefPrefixExpr a c loc -> [AST_RefPrefix] <*> [a] <*> [[]] <*> fromInterm c <*> [loc]++----------------------------------------------------------------------------------------------------++-- | Contains a list of 'ObjectExpr's, which are used to encode parameters to function calls, and+-- intialization lists.+data ObjListExpr o = ObjListExpr [AssignExpr o] Location deriving (Eq, Ord, Typeable, Show, Functor)++instance Monoid (ObjListExpr o) where+  mempty = ObjListExpr [] LocationUnknown+  mappend (ObjListExpr a locA) (ObjListExpr b locB) = ObjListExpr (a++b) (locA<>locB)++instance NFData o => NFData (ObjListExpr o) where { rnf (ObjListExpr a b) = deepseq a $! deepseq b () }++instance HasNullValue (ObjListExpr o) where+  nullValue = mempty+  testNull (ObjListExpr a _) = null a++instance HasLocation (ObjListExpr o) where+  getLocation (ObjListExpr _ loc)     = loc+  setLocation (ObjListExpr a _  ) loc = ObjListExpr (fmap delLocation a) loc+  delLocation (ObjListExpr a _  )     = ObjListExpr (fmap delLocation a) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_ObjList o = AST_ObjList [Comment] [Com (AST_Assign o)] Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance Monoid (AST_ObjList o) where+  mempty = AST_ObjList [] [] LocationUnknown+  mappend (AST_ObjList a1 a2 aloc) (AST_ObjList b1 b2 bloc) = AST_ObjList (a1++b1) (a2++b2) (aloc<>bloc)++instance HasNullValue (AST_ObjList o) where+  nullValue = mempty+  testNull (AST_ObjList [] [] _) = True+  testNull _ = False++instance HasLocation (AST_ObjList o) where+  getLocation (AST_ObjList _ _ loc)     = loc+  setLocation (AST_ObjList a b _  ) loc = AST_ObjList a      b  loc+  delLocation (AST_ObjList a b _  )     = AST_ObjList a (fmap delLocation b) LocationUnknown++instance PPrintable o => PPrintable (AST_ObjList o) where+  pPrint (AST_ObjList coms lst _) = pPrint coms >>+    pInline (intersperse (pString ", ") (map pPrint lst))++instance NFData o => NFData (AST_ObjList o) where { rnf (AST_ObjList a b c) = deepseq a $! deepseq b $! deepseq c () }++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ObjList o) where+  randO = recurse $ depthLimitedInt 8 >>= \x -> AST_ObjList <$> randO <*> randList 0 x <*> no+  defaultO = return AST_ObjList <*> defaultO <*> pure [] <*> no++instance Intermediate (ObjListExpr o) (AST_ObjList o) where+  toInterm   (AST_ObjList _ lst loc) = [ObjListExpr]          <*> [lst>>=uc0] <*> [loc]+  fromInterm (ObjListExpr   lst loc) = [AST_ObjList] <*> [[]] <*> [lst>>=nc0] <*> [loc]++----------------------------------------------------------------------------------------------------++newtype OptObjListExpr o = OptObjListExpr (Maybe (ObjListExpr o))+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (OptObjListExpr o) where { rnf (OptObjListExpr a) = deepseq a () }++instance HasLocation (OptObjListExpr o) where+  getLocation (OptObjListExpr o)     = maybe LocationUnknown getLocation o+  setLocation (OptObjListExpr o) loc = OptObjListExpr (setLocation o loc)+  delLocation (OptObjListExpr o)     = OptObjListExpr (delLocation o    )++instance HasNullValue (OptObjListExpr o) where+  nullValue = OptObjListExpr Nothing+  testNull (OptObjListExpr Nothing) = True+  testNull _ = False++----------------------------------------------------------------------------------------------------++data AST_OptObjList o = AST_OptObjList [Comment] (Maybe (AST_ObjList o))+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_OptObjList o) where+  rnf (AST_OptObjList a b) = deepseq a $! deepseq b ()++instance HasNullValue (AST_OptObjList o) where+  nullValue = AST_OptObjList [] Nothing+  testNull (AST_OptObjList _ a) = maybe True testNull a++pPrintObjList :: PPrintable o => String -> String -> String -> AST_ObjList o -> PPrint+pPrintObjList open comma close (AST_ObjList coms lst _) = pList (pPrint coms) open comma close (map pPrint lst)++pPrintOptObjList :: PPrintable o => String -> String -> String -> AST_OptObjList o -> PPrint+pPrintOptObjList open comma close (AST_OptObjList coms o) =+  maybe (return ()) (\o -> pPrint coms >> pPrintObjList open comma close o) o++instance HasLocation (AST_OptObjList o) where+  getLocation (AST_OptObjList _ o)     = maybe LocationUnknown getLocation o+  setLocation (AST_OptObjList c o) loc = AST_OptObjList c (fmap (flip setLocation loc) o)+  delLocation (AST_OptObjList c o)     = AST_OptObjList c (fmap delLocation o)++instance PPrintable o => PPrintable (AST_OptObjList o) where { pPrint o = pPrintOptObjList "{" ", " "}" o }++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_OptObjList o) where+  randO = countNode $ return AST_OptObjList <*> randO <*> randO+  defaultO = return AST_OptObjList <*> defaultO <*> defaultO++instance Intermediate (OptObjListExpr o) (AST_OptObjList o) where+  toInterm   (AST_OptObjList _ o) = OptObjListExpr    <$> um1 o+  fromInterm (OptObjListExpr   o) = AST_OptObjList [] <$> nm1 o++----------------------------------------------------------------------------------------------------++data LiteralExpr o = LiteralExpr o Location deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (LiteralExpr o) where+  rnf (LiteralExpr a b) = deepseq a $! deepseq b ()++instance {- KEEP -} HasNullValue o => HasNullValue (LiteralExpr o) where+  nullValue = LiteralExpr nullValue LocationUnknown+  testNull (LiteralExpr o _) = testNull o++instance HasLocation (LiteralExpr o) where+  getLocation (LiteralExpr _ loc)     = loc+  setLocation (LiteralExpr o _  ) loc = LiteralExpr o loc+  delLocation (LiteralExpr o _  )     = LiteralExpr o LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_Literal o = AST_Literal o Location deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_Literal o) where+  rnf (AST_Literal a b) = deepseq a $! deepseq b ()++instance {- KEEP -} HasNullValue o => HasNullValue (AST_Literal o) where+  nullValue = AST_Literal nullValue LocationUnknown+  testNull (AST_Literal o _) = testNull o++instance HasLocation (AST_Literal o) where+  getLocation (AST_Literal _ loc)     = loc+  setLocation (AST_Literal a _  ) loc = AST_Literal a loc+  delLocation (AST_Literal a _  )     = AST_Literal a LocationUnknown++instance PPrintable o => PPrintable (AST_Literal o) where+  pPrint (AST_Literal o _  ) = pPrint o++instance PrecedeWithSpace (AST_Literal o) where+  precedeWithSpace (AST_Literal _ _) = True++instance HasRandGen o => HasRandGen (AST_Literal o) where+  randO    = scramble $ return AST_Literal <*> defaultO <*> no+  defaultO = randO++instance Intermediate (LiteralExpr o) (AST_Literal o) where+  toInterm   (AST_Literal a loc) = [LiteralExpr] <*> [a] <*> [loc]+  fromInterm (LiteralExpr a loc) = [AST_Literal] <*> [a] <*> [loc]++----------------------------------------------------------------------------------------------------++-- | Required parenthesese.+data ParenExpr o = ParenExpr (AssignExpr o) Location deriving (Eq, Ord, Typeable, Show, Functor)++instance HasLocation (ParenExpr o) where+  getLocation (ParenExpr _ loc)     = loc+  setLocation (ParenExpr o _  ) loc = ParenExpr o loc+  delLocation (ParenExpr o _  )     = ParenExpr (delLocation o) LocationUnknown++instance HasNullValue (ParenExpr o) where+  nullValue = ParenExpr nullValue LocationUnknown+  testNull (ParenExpr a _) = testNull a++instance NFData o => NFData (ParenExpr o) where { rnf (ParenExpr a b) = deepseq a $! deepseq b () }++instance PPrintable o => PPrintable (ParenExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++data AST_Paren o = AST_Paren (Com (AST_Assign o)) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance HasLocation (AST_Paren o) where+  getLocation (AST_Paren _ loc)     = loc+  setLocation (AST_Paren o _  ) loc = AST_Paren o loc+  delLocation (AST_Paren o _  )     = AST_Paren (delLocation o) LocationUnknown++instance HasNullValue (AST_Paren o) where+  nullValue = AST_Paren nullValue LocationUnknown+  testNull (AST_Paren a _) = testNull a++instance NFData o => NFData (AST_Paren o) where { rnf (AST_Paren a b) = deepseq a $! deepseq b () }++instance PPrintable o => PPrintable (AST_Paren o) where+  pPrint (AST_Paren o _) = pInline [pString "(", pPrint o, pString ")"]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Paren o) where+  randO    = recurse $ return AST_Paren <*> randO <*> no+  defaultO = return AST_Paren <*> defaultO <*> no++instance Intermediate (ParenExpr o) (AST_Paren o) where+  toInterm   (AST_Paren o loc) = [ParenExpr] <*> uc0 o <*> [loc]+  fromInterm (ParenExpr o loc) = [AST_Paren] <*> nc0 o <*> [loc]++----------------------------------------------------------------------------------------------------++data AssignExpr o+  = EvalExpr   (ObjTestExpr o)+  | AssignExpr (ObjTestExpr o) UpdateOp (AssignExpr o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AssignExpr o) where+  rnf (EvalExpr   a      ) = deepseq a ()+  rnf (AssignExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (AssignExpr o) where+  nullValue = EvalExpr nullValue+  testNull (EvalExpr a) = testNull a+  testNull _ = False++instance HasLocation (AssignExpr o) where+  getLocation o     = case o of+    EvalExpr         o -> getLocation o+    AssignExpr _ _ _ o -> o+  setLocation o loc = case o of+    EvalExpr   a       -> EvalExpr  (setLocation a loc)+    AssignExpr a b c _ -> AssignExpr a b c loc+  delLocation o     = case o of+    EvalExpr   a       -> EvalExpr   (delLocation a)+    AssignExpr a b c _ -> AssignExpr (delLocation a) b (delLocation c) LocationUnknown++instance PPrintable o => PPrintable (AssignExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++data AST_Assign o+  = AST_Eval   (AST_ObjTest o)+  | AST_Assign (AST_ObjTest o) (Com UpdateOp) (AST_Assign o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_Assign o) where+  rnf (AST_Eval   a      ) = deepseq a ()+  rnf (AST_Assign a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (AST_Assign o) where+  nullValue = AST_Eval  nullValue+  testNull (AST_Eval  a) = testNull a+  testNull _ = False++instance HasLocation (AST_Assign o) where+  getLocation o = case o of+    AST_Eval         o -> getLocation o+    AST_Assign _ _ _ o -> o+  setLocation o loc = case o of+    AST_Eval         o -> AST_Eval  (setLocation o loc)+    AST_Assign a b c _ -> AST_Assign a b c loc+  delLocation o = case o of                            +    AST_Eval         o -> AST_Eval  (delLocation o)+    AST_Assign a b c _ -> AST_Assign (delLocation a) b (delLocation c) LocationUnknown++instance PPrintable o => PPrintable (AST_Assign o) where+  pPrint expr = case expr of+    AST_Eval  eq -> pPrint eq+    AST_Assign objXp1 comUpdOp objXp2 _ -> pWrapIndent $+      [pPrint objXp1, pPrint comUpdOp, pPrint objXp2]++instance PrecedeWithSpace (AST_Assign o) where+  precedeWithSpace o = case o of+    AST_Eval   o       -> precedeWithSpace o+    AST_Assign o _ _ _ -> precedeWithSpace o++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Assign o) where+  randO = countNode $ recurse $ runRandChoice+  randChoice = randChoiceList $+    [ AST_Eval <$> randO+    , do ox <- randListOf 0 3 (pure (,) <*> randO <*> randO)+         o  <- randO+         return (foldr (\ (left, op) right -> AST_Assign left op right LocationUnknown) o ox)+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ AST_Eval <$> defaultO+    , return AST_Assign <*> defaultO <*> defaultO <*> (AST_Eval <$> defaultO) <*> no+    ]++instance Intermediate (AssignExpr o) (AST_Assign o) where+  toInterm ast = case ast of+    AST_Eval   a         -> EvalExpr <$> ti a+    AST_Assign a b c loc -> [AssignExpr] <*> ti a <*> uc b <*> ti c <*> [loc]+  fromInterm o = case o of+    EvalExpr   a         -> AST_Eval <$> fi a+    AssignExpr a b c loc -> [AST_Assign] <*> fi a <*> nc b <*> fi c <*> [loc]++----------------------------------------------------------------------------------------------------++-- | A conditional expression of the form @a==b ? "yes" : "no"@+data ObjTestExpr o+  = ObjArithExpr    (ArithExpr    o)+  | ObjTestExpr     (ArithExpr    o) (ArithExpr o) (ArithExpr o) Location+  | ObjRuleFuncExpr (RuleFuncExpr o)+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (ObjTestExpr o) where+  rnf (ObjArithExpr  a    ) = deepseq a ()+  rnf (ObjTestExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (ObjRuleFuncExpr a      ) = deepseq a $! ()++instance HasNullValue (ObjTestExpr o) where+  nullValue = ObjArithExpr nullValue+  testNull (ObjArithExpr a) = testNull a+  testNull _ = False++instance HasLocation (ObjTestExpr o) where+  getLocation o = case o of+    ObjArithExpr      a   -> getLocation a+    ObjTestExpr _ _ _ loc -> loc+    ObjRuleFuncExpr       o -> getLocation o+  setLocation o loc = case o of+    ObjArithExpr      a   -> ObjArithExpr (setLocation a loc)+    ObjTestExpr a b c _   -> ObjTestExpr a b c loc+    ObjRuleFuncExpr a       -> ObjRuleFuncExpr (setLocation a loc)+  delLocation o     = case o of+    ObjArithExpr      a   -> ObjArithExpr (delLocation a)+    ObjTestExpr a b c _   ->+      ObjTestExpr (delLocation a) (delLocation b) (delLocation c) LocationUnknown+    ObjRuleFuncExpr a       -> ObjRuleFuncExpr (delLocation a)++instance PPrintable o => PPrintable (ObjTestExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++-- | A conditional expression of the form @a==b ? "yes" : "no"@+data AST_ObjTest o+  = AST_ObjArith    (AST_Arith    o)+  | AST_ObjTest     (AST_Arith    o) (Com ()) (AST_Arith o) (Com ()) (AST_Arith o) Location+  | AST_ObjRuleFunc (AST_RuleFunc o)+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (AST_ObjTest o) where+  rnf (AST_ObjArith  a        ) = deepseq a ()+  rnf (AST_ObjTest a b c d e f) =+    deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e $! deepseq f ()+  rnf (AST_ObjRuleFunc a      ) = deepseq a ()++instance HasNullValue (AST_ObjTest o) where+  nullValue = AST_ObjArith nullValue+  testNull (AST_ObjArith a) = testNull a+  testNull _ = False++instance HasLocation (AST_ObjTest o) where+  getLocation o     = case o of+    AST_ObjArith          a   -> getLocation a+    AST_ObjTest _ _ _ _ _ loc -> loc+    AST_ObjRuleFunc      o -> getLocation o+  setLocation o loc = case o of+    AST_ObjArith          a   -> AST_ObjArith (setLocation a loc)+    AST_ObjTest a b c d e _   -> AST_ObjTest a b c d e loc+    AST_ObjRuleFunc a         -> AST_ObjRuleFunc (setLocation a loc)+  delLocation o     = case o of+    AST_ObjArith          a   -> AST_ObjArith (delLocation a)+    AST_ObjTest a b c d e _   -> +      AST_ObjTest (delLocation a) b (delLocation c) d (delLocation e) LocationUnknown+    AST_ObjRuleFunc a         -> AST_ObjRuleFunc (delLocation  a)++instance PPrintable o => PPrintable (AST_ObjTest o) where+  pPrint o = case o of+    AST_ObjArith  a         -> pPrint a+    AST_ObjTest a b c d e _ -> pWrapIndent $+      [ pPrint a+      , pPrintComWith (\ () -> pString " ? ") b, pPrint c+      , pPrintComWith (\ () -> pString " : ") d, pPrint e+      ]+    AST_ObjRuleFunc o                -> pPrint o++instance PrecedeWithSpace (AST_ObjTest o) where+  precedeWithSpace o = case o of+    AST_ObjArith          o -> precedeWithSpace o+    AST_ObjTest o _ _ _ _ _ -> precedeWithSpace o+    AST_ObjRuleFunc{}       -> True++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ObjTest o) where+  randO      = countNode $ runRandChoice+  randChoice = randChoiceList $+    [ AST_ObjArith <$> randO+    , let p = pure (Com ()) in+        recurse $ scramble $ return AST_ObjTest <*> randO <*> p <*> randO <*> p <*> randO <*> no+    , AST_ObjRuleFunc <$> randO+    ]+  defaultO      = AST_ObjArith <$> defaultO+  defaultChoice = randChoiceList [defaultO]++instance Intermediate (ObjTestExpr o) (AST_ObjTest o) where+  toInterm   o = case o of+    AST_ObjArith    o         ->  ObjArithExpr <$> ti o+    AST_ObjTest a _ b _ c loc -> [ObjTestExpr] <*> ti a <*> ti b <*> ti c <*> [loc]+    AST_ObjRuleFunc a         -> [ObjRuleFuncExpr] <*> ti a+  fromInterm o = case o of+    ObjArithExpr  o       -> AST_ObjArith <$> fi o+    ObjTestExpr a b c loc ->+      [AST_ObjTest] <*> fi a <*> [Com ()] <*> fi b <*> [Com ()] <*> fi c <*> [loc]+    ObjRuleFuncExpr a         ->  AST_ObjRuleFunc  <$> fi a++----------------------------------------------------------------------------------------------------++data RefPfxOp = REF | DEREF deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)++instance NFData RefPfxOp where { rnf a = seq a () }++instance UStrType RefPfxOp where+  toUStr op = ustr $ case op of+    REF         -> "$"+    DEREF       -> "@"+  maybeFromUStr str = case uchars str of+    "$" -> Just REF+    "@" -> Just DEREF+    _   -> Nothing+  fromUStr str = maybe (error (show str++" is not a prefix opretor")) id (maybeFromUStr str)++instance PPrintable RefPfxOp where { pPrint = pUStr . toUStr }++instance HasRandGen RefPfxOp where+  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::RefPfxOp)))+  defaultO = randO++----------------------------------------------------------------------------------------------------++data UpdateOp+  = UCONST | UADD | USUB | UMULT | UDIV | UMOD | UPOW | UORB | UANDB | UXORB | USHL | USHR+  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)+instance NFData UpdateOp where { rnf a = seq a () }++allUpdateOpStrs :: String+allUpdateOpStrs = " = += -= *= /= %= **= |= &= ^= <<= >>= "++instance UStrType UpdateOp where+  toUStr a = ustr $ case a of+    UCONST -> "="+    UADD   -> "+="+    USUB   -> "-="+    UMULT  -> "*="+    UDIV   -> "/="+    UMOD   -> "%="+    UPOW   -> "**="+    UORB   -> "|="+    UANDB  -> "&="+    UXORB  -> "^="+    USHL   -> "<<="+    USHR   -> ">>="+  maybeFromUStr str = case uchars str of+    "="   -> Just UCONST+    "+="  -> Just UADD  +    "-="  -> Just USUB  +    "*="  -> Just UMULT +    "/="  -> Just UDIV  +    "%="  -> Just UMOD  +    "**=" -> Just UPOW+    "|="  -> Just UORB  +    "&="  -> Just UANDB +    "^="  -> Just UXORB +    "<<=" -> Just USHL  +    ">>=" -> Just USHR  +    _     -> Nothing+  fromUStr str =+    maybe (error (show str++" is not an assignment/update operator")) id (maybeFromUStr str)++instance PPrintable UpdateOp where { pPrint op = pString (' ':uchars op++" ") }++-- binary 0x8D 0x9D UpdateOp-->InfixOp+instance B.Binary UpdateOp mtab where+  put o = B.putWord8 $ case o of+    UCONST -> 0x8D+    UADD   -> 0x93+    USUB   -> 0x94+    UMULT  -> 0x95+    UDIV   -> 0x96+    UMOD   -> 0x97+    UPOW   -> 0x98+    UORB   -> 0x99+    UANDB  -> 0x9A+    UXORB  -> 0x9B+    USHL   -> 0x9C+    USHR   -> 0x9D+  get = B.word8PrefixTable <|> fail "expecting UpdateOp"++instance B.HasPrefixTable UpdateOp B.Byte mtab where+  prefixTable = B.mkPrefixTableWord8 "UpdateOp" 0x8D 0x9D $ let {r=return;z=mzero} in+    [ r UCONST -- 0x8D+    , z, z, z, z, z -- 0x8E,0x8F,0x90,0x91,0x92+    , r UADD, r USUB, r UMULT, r UDIV, r UMOD, r UPOW, r UORB -- 0x93,0x94,0x95,0x96,0x97,0x98,0x99+    , r UANDB, r UXORB, r USHL, r USHR -- 0x9A,0x9B,0x9C,0x9D+    ]++instance HasRandGen UpdateOp where+  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::UpdateOp)))+  defaultO = randO++----------------------------------------------------------------------------------------------------++data ArithExpr o+  = ObjectExpr (ObjectExpr o)+  | ArithExpr  (ArithExpr  o) InfixOp (ArithExpr o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (ArithExpr o) where+  rnf (ObjectExpr a      ) = deepseq a ()+  rnf (ArithExpr  a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (ArithExpr o) where+  nullValue = ObjectExpr nullValue+  testNull (ObjectExpr a) = testNull a+  testNull _ = False++instance HasLocation (ArithExpr o) where+  getLocation o     = case o of+    ObjectExpr      o -> getLocation o+    ArithExpr _ _ _ o -> o+  setLocation o loc = case o of+    ObjectExpr  a     -> ObjectExpr (setLocation a loc)+    ArithExpr a b c _ -> ArithExpr a b c loc+  delLocation o     = case o of+    ObjectExpr  a     -> ObjectExpr (delLocation a)+    ArithExpr a b c _ -> ArithExpr (delLocation a) b (delLocation c) LocationUnknown++instance PPrintable o => PPrintable (ArithExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++data AST_Arith o+  = AST_Object (AST_Object o)+  | AST_Arith  (AST_Arith  o) (Com InfixOp) (AST_Arith o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_Arith o) where+  rnf (AST_Object   a        ) = deepseq a ()+  rnf (AST_Arith a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (AST_Arith o) where+  nullValue = AST_Object nullValue+  testNull (AST_Object a) = testNull a+  testNull _ = False++instance HasLocation (AST_Arith o) where+  getLocation o     = case o of+    AST_Object      o -> getLocation o+    AST_Arith _ _ _ o -> o+  setLocation o loc = case o of+    AST_Object   a    -> AST_Object (setLocation a loc)+    AST_Arith a b c _ -> AST_Arith a b c loc+  delLocation o     = case o of+    AST_Object   a    -> AST_Object (delLocation a)+    AST_Arith a b c _ -> AST_Arith (delLocation a) b (delLocation c) LocationUnknown++instance PPrintable o => PPrintable (AST_Arith o) where+  pPrint o = case o of+    AST_Object o -> pPrint o+    AST_Arith objXp1 comAriOp objXp2 _ -> pWrapIndent [pPrint objXp1, pPrint comAriOp, pPrint objXp2]++instance PrecedeWithSpace (AST_Arith o) where+  precedeWithSpace o = case o of+    AST_Object o       -> precedeWithSpace o+    AST_Arith  o _ _ _ -> precedeWithSpace o++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Arith o) where+  randO = countNode $ runRandChoice+  defaultChoice = randChoiceList $+    [ AST_Object <$> defaultO+    , return AST_Arith <*> (AST_Object <$> defaultO) <*> defaultO <*> (AST_Object <$> defaultO) <*> no+    ]+  defaultO   = runDefaultChoice+  randChoice = randChoiceList $+    [ AST_Object <$> randO+    , do  left <- AST_Object <$> randO+          x    <- getCurrentDepth+          ops  <- randListOf 0 (max 1 (4-x)) $+            pure (,) <*> randInfixOp <*> (AST_Object <$> randO)+          return $ foldPrec left ops+    ] where+      randInfixOp :: RandO (Com InfixOp, Int, Bool)+      randInfixOp = do+        (op, prec, assoc) <- runRandChoiceOf opGroups+        op <- randComWith (return op)+        return (op, prec, assoc)+      left  op = (True , op)+      right op = (False, op)+      opGroups :: RandChoice (InfixOp, Int, Bool)+      opGroups = randChoiceList $ map return $ do+        (precedence, (associativity, operators)) <- zip [1..] $ concat $+          [ map right [[OR], [AND], [EQUL, NEQUL]]+          , map left $+              [ [GTN, LTN, GTEQ, LTEQ], [SHL, SHR]+              , [ORB], [XORB], [ANDB]+              , [ADD, SUB], [MULT, DIV, MOD]+              ]+          , map right [[POW], [ARROW]]+          ]+        operator <- operators+        return (operator, precedence, associativity)+      bind left op right = AST_Arith left op right LocationUnknown+      foldPrec left ops = case ops of+        [] -> left+        ((op, prec, _), right):ops -> case scanRight prec right ops of+          (right, ops) -> foldPrec (bind left op right) ops+      scanRight prevPrec left ops = case ops of+        [] -> (left, [])+        ((op, prec, assoc), right):next -> +          if prevPrec<prec || (prevPrec==prec && not assoc)+          then  case scanRight prec right next of+                  (right, next) -> scanRight prevPrec (bind left op right) next+          else  (left, ops)++instance Intermediate (ArithExpr o) (AST_Arith o) where+  toInterm o = case o of+    AST_Object  a       -> ObjectExpr <$> ti a+    AST_Arith a b c loc -> [ArithExpr ] <*> ti a <*> uc b <*> ti c <*> [loc]+  fromInterm o = case o of+    ObjectExpr  a       -> AST_Object <$> fi a+    ArithExpr a b c loc -> [AST_Arith ] <*> fi a <*> nc b <*> fi c <*> [loc]++----------------------------------------------------------------------------------------------------++data ObjectExpr o+  = VoidExpr+  | ObjLiteralExpr  (LiteralExpr   o)+  | ObjSingleExpr   (RefPrefixExpr o)+  | ArithPfxExpr     ArithPfxOp       (ObjectExpr     o)                  Location+  | InitExpr         DotLabelExpr     (OptObjListExpr o)  (ObjListExpr o) Location+  | StructExpr       Name             (OptObjListExpr o)                  Location+  | MetaEvalExpr    (CodeBlock     o)                                     Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (ObjectExpr o) where+  rnf  VoidExpr                 = ()+  rnf (ObjLiteralExpr  a      ) = deepseq a ()+  rnf (ObjSingleExpr   a      ) = deepseq a $! ()+  rnf (ArithPfxExpr    a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (InitExpr        a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (StructExpr      a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (MetaEvalExpr    a b    ) = deepseq a $! deepseq b ()++instance HasNullValue (ObjectExpr o) where+  nullValue = VoidExpr+  testNull VoidExpr = True+  testNull _        = False++instance HasLocation (ObjectExpr o) where+  getLocation o = case o of+    VoidExpr                -> LocationUnknown+    ObjLiteralExpr        o -> getLocation o+    ObjSingleExpr         o -> getLocation o+    ArithPfxExpr    _ _   o -> o+    InitExpr        _ _ _ o -> o+    StructExpr      _ _   o -> o+    MetaEvalExpr    _     o -> o+  setLocation o loc = case o of+    VoidExpr                -> VoidExpr+    ObjLiteralExpr  a       -> ObjLiteralExpr  (setLocation a loc)+    ObjSingleExpr   a       -> ObjSingleExpr   (setLocation a loc)+    ArithPfxExpr    a b   _ -> ArithPfxExpr    a b   loc+    InitExpr        a b c _ -> InitExpr        a b c loc+    StructExpr      a b   _ -> StructExpr      a b   loc+    MetaEvalExpr    a     _ -> MetaEvalExpr    a     loc+  delLocation o = case o of+    VoidExpr                -> VoidExpr+    ObjLiteralExpr  a       -> ObjLiteralExpr  (fd a)+    ObjSingleExpr   a       -> ObjSingleExpr   (fd a)+    ArithPfxExpr    a b   _ -> ArithPfxExpr        a  (fd b)        lu+    InitExpr        a b c _ -> InitExpr        (fd a) (fd b) (fd c) lu+    StructExpr      a b   _ -> StructExpr      (fd a) (fd b)        lu+    MetaEvalExpr    a     _ -> MetaEvalExpr    (fd a)               lu+    where+      lu = LocationUnknown+      fd :: HasLocation a => a -> a+      fd = delLocation++instance PPrintable o => PPrintable (ObjectExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++-- | Part of the Dao language abstract syntax tree: any expression that evaluates to an Object.+data AST_Object o+  = AST_Void -- ^ Not a language construct, but used where an object expression is optional.+  | AST_ObjLiteral  (AST_Literal o)+  | AST_ObjSingle   (AST_RefPrefix o)+  | AST_ArithPfx     ArithPfxOp      [Comment]          (AST_Object  o)   Location+  | AST_Init         AST_DotLabel    (AST_OptObjList o) (AST_ObjList o)   Location+  | AST_Struct       Name            (AST_OptObjList o)                   Location+  | AST_MetaEval                     (AST_CodeBlock  o)                   Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_Object o) where+  rnf AST_Void = ()+  rnf (AST_ObjLiteral  a      ) = deepseq a ()+  rnf (AST_ObjSingle   a      ) = deepseq a ()+  rnf (AST_ArithPfx    a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (AST_Init        a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (AST_Struct      a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (AST_MetaEval    a b    ) = deepseq a $! deepseq b ()++instance HasNullValue (AST_Object o) where+  nullValue = AST_Void+  testNull AST_Void = True+  testNull _        = False++instance HasLocation (AST_Object o) where+  getLocation o = case o of+    AST_Void               -> LocationUnknown+    AST_ObjLiteral       o -> getLocation o+    AST_ObjSingle        o -> getLocation o+    AST_ArithPfx _ _ _   o -> o+    AST_Init     _ _ _   o -> o+    AST_Struct   _ _     o -> o+    AST_MetaEval _       o -> o+  setLocation o loc = case o of+    AST_Void                  -> AST_Void+    AST_ObjLiteral  a         -> AST_ObjLiteral  (setLocation a loc)+    AST_ObjSingle   a         -> AST_ObjSingle   (setLocation a loc)+    AST_ArithPfx    a b c   _ -> AST_ArithPfx    a b c   loc+    AST_Init        a b c   _ -> AST_Init        a b c   loc+    AST_Struct      a b     _ -> AST_Struct      a b     loc+    AST_MetaEval    a       _ -> AST_MetaEval    a       loc+  delLocation o = case o of                            +    AST_Void                  -> AST_Void+    AST_ObjLiteral  a         -> AST_ObjLiteral   (delLocation  a)+    AST_ObjSingle   a         -> AST_ObjSingle    (delLocation  a)+    AST_ArithPfx    a b c   _ -> AST_ArithPfx a b (delLocation  c) LocationUnknown+    AST_Init        a b c   _ -> AST_Init         (delLocation  a) (delLocation  b) (delLocation  c) LocationUnknown+    AST_Struct      a b     _ -> AST_Struct   a   (delLocation  b) LocationUnknown+    AST_MetaEval    a       _ -> AST_MetaEval     (delLocation  a) LocationUnknown++instance PPrintable o => PPrintable (AST_Object o) where+  pPrint expr = case expr of+    AST_Void                         -> return ()+    AST_ObjLiteral  o                -> pPrint o+    AST_ObjSingle   o                -> pPrint o+    AST_ArithPfx    op coms objXp  _ -> pWrapIndent $+      [pPrint op, pPrint coms, pPrint objXp]+    AST_Init          ref objs     elems   _ ->+      pInline [pPrint ref, pPrintOptObjList "(" ", " ")" objs, pPrintObjList "{" ", " "}" elems]+    AST_Struct      nm itms        _ -> case itms of+      AST_OptObjList coms items -> do+        let name = pString $ '#' : uchars (toUStr nm)+        pPrint coms+        case items of+          Nothing -> name+          Just (AST_ObjList coms items _) -> do+            pPrint coms+            pList name "{" ", " "}" $ map pPrint items+    AST_MetaEval cObjXp                    _ -> pInline [pString "${", pPrint cObjXp, pString "}"]++instance PrecedeWithSpace (AST_Object o) where+  precedeWithSpace o = case o of+    AST_Void         -> False+    AST_MetaEval{}   -> False+    AST_ObjSingle  o -> precedeWithSpace o+    _                -> True++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Object o) where+  randO      = countNode $ runRandChoice+  randChoice = randChoiceList $+    [ AST_ObjLiteral  <$> randO+    , AST_ObjSingle   <$> randO+    , pure AST_ArithPfx <*> randO <*> randO <*> randO <*> no+    , pure AST_Init     <*> randO <*> randO <*> randO <*> no+    , pure AST_MetaEval <*> randO <*> no+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ AST_ObjLiteral  <$> defaultO+    , AST_ObjSingle   <$> defaultO+    , return AST_ArithPfx <*> defaultO <*> defaultO <*> (AST_ObjLiteral <$> defaultO) <*> no+    , return AST_Init     <*> defaultO <*> defaultO <*> defaultO <*> no+    , return AST_Struct   <*> defaultO <*> defaultO <*> no+    ]++instance (HasNullValue o, HasRandGen o) => HasRandGen [Com (AST_Object o)] where+  randO = depthLimitedInt 24 >>= \x -> countNode $ randList 1 x++instance Intermediate (ObjectExpr o) (AST_Object o) where+  toInterm ast = case ast of+    AST_Void                  -> [VoidExpr       ]+    AST_ObjLiteral  a         ->  ObjLiteralExpr   <$> ti a+    AST_ObjSingle   a         -> [ObjSingleExpr  ] <*> ti a+    AST_ArithPfx    a _ c loc -> [ArithPfxExpr   ] <*>   [a]          <*> ti c <*> [loc]+    AST_Init        a b c loc -> [InitExpr       ] <*> ti a  <*> ti b <*> ti c <*> [loc]+    AST_Struct      a b   loc -> [StructExpr     ] <*>   [a] <*> ti b          <*> [loc]+    AST_MetaEval    a     loc -> [MetaEvalExpr   ] <*> ti a                    <*> [loc]+  fromInterm o = case o of+    VoidExpr                  -> [AST_Void       ]+    ObjLiteralExpr  a         ->  AST_ObjLiteral   <$> fi a+    ObjSingleExpr   a         ->  AST_ObjSingle    <$> fi a+    ArithPfxExpr    a b   loc -> [AST_ArithPfx   ] <*>   [a] <*> [[]] <*> fi b <*> [loc]+    InitExpr        a b c loc -> [AST_Init       ] <*> fi a  <*> fi b <*> fi c <*> [loc]+    StructExpr      a b   loc -> [AST_Struct     ] <*>   [a] <*> fi b          <*> [loc]+    MetaEvalExpr    a     loc -> [AST_MetaEval   ] <*> fi a                    <*> [loc]++----------------------------------------------------------------------------------------------------++-- | Functions and function parameters can specify optional type-checking expressions. This is a+-- data type that wraps a dao-typeable expression with type information.+data TyChkExpr a o+  = NotTypeChecked{tyChkItem::a}+    -- ^ no type information was specified for this item+  | TypeChecked   {tyChkItem::a, tyChkExpr::ArithExpr o, tyChkLoc::Location}+    -- ^ type check information was specified and should be checked every time it is evaluated.+  | DisableCheck  {tyChkItem::a, tyChkExpr::ArithExpr o, typChkResult::o, tyChkLoc::Location}+    -- ^ type check information was specified but has been disabled for efficiency reasons because+    -- we have verified that the item will always return a succesfull type-check.+  deriving (Eq, Ord, Typeable, Show)++checkedExpr :: TyChkExpr a o -> a+checkedExpr o = case o of+  NotTypeChecked o       -> o+  TypeChecked    o _ _   -> o+  DisableCheck   o _ _ _ -> o++instance Functor (TyChkExpr a) where+  fmap _ (NotTypeChecked   a  ) = NotTypeChecked a+  fmap f (TypeChecked  a b c  ) = TypeChecked  a (fmap f b) c+  fmap f (DisableCheck a b c d) = DisableCheck a (fmap f b) (f c) d++fmapCheckedValueExpr :: (a -> b) -> TyChkExpr a o -> TyChkExpr b o+fmapCheckedValueExpr f a = case a of+  NotTypeChecked   a   -> NotTypeChecked (f a)+  TypeChecked  a b c   -> TypeChecked  (f a) b c+  DisableCheck a b c d -> DisableCheck (f a) b c d++instance (NFData o, NFData a) => NFData (TyChkExpr a o) where+  rnf (NotTypeChecked   a  ) = deepseq a ()+  rnf (TypeChecked  a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (DisableCheck a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance (HasNullValue o, HasNullValue a) => HasNullValue (TyChkExpr a o) where+  nullValue = NotTypeChecked nullValue+  testNull (NotTypeChecked a) = testNull a+  testNull _ = False++instance HasLocation a => HasLocation (TyChkExpr a o) where+  getLocation a     = case a of+    NotTypeChecked a         -> getLocation a+    TypeChecked    a _   loc -> getLocation a <> loc+    DisableCheck   a _ _ loc -> getLocation a <> loc+  setLocation a loc = case a of+    NotTypeChecked a       -> NotTypeChecked (setLocation a loc)+    TypeChecked    a b   _ -> TypeChecked  a b loc+    DisableCheck   a b c _ -> DisableCheck a b c loc+  delLocation a     = case a of+    NotTypeChecked a       -> NotTypeChecked (delLocation a)+    TypeChecked    a b   _ -> TypeChecked (delLocation a) (delLocation b) LocationUnknown+    DisableCheck   a b c _ -> DisableCheck a b c LocationUnknown++instance (PPrintable o, PPrintable a) => PPrintable (TyChkExpr a o) where+  pPrint a = case a of+    NotTypeChecked a        -> pPrint a+    TypeChecked    a expr _ -> pInline [pPrint a, pString ": ", pPrint expr]+    DisableCheck   a  _ _ _ -> pInline [pPrint a]++----------------------------------------------------------------------------------------------------++-- | This node can be found in a few different syntactic structures. When a name or function or+-- expression is followed by a colon and some type checking information, this node is used for that+-- purpose.+data AST_TyChk a o+  = AST_NotChecked a+  | AST_Checked    a (Com ()) (AST_Arith o) Location+  deriving (Eq, Ord, Typeable, Show)++checkedAST :: AST_TyChk a o -> a+checkedAST a = case a of { AST_NotChecked a -> a; AST_Checked a _ _ _ -> a; }++astTyChkDelLocWith :: (a -> a) -> AST_TyChk a o -> AST_TyChk a o+astTyChkDelLocWith del a = case a of+  AST_NotChecked a       -> AST_NotChecked (del a)+  AST_Checked    a b c _ -> AST_Checked    (del a) b (delLocation c) LocationUnknown++instance Functor (AST_TyChk o) where+  fmap _ (AST_NotChecked a      ) = AST_NotChecked a+  fmap f (AST_Checked    a b c d) = AST_Checked    a b (fmap f c) d++fmapCheckedValueAST :: (a -> b) -> AST_TyChk a o -> AST_TyChk b o+fmapCheckedValueAST f a = case a of+  AST_NotChecked a       -> AST_NotChecked (f a)+  AST_Checked    a b c d -> AST_Checked    (f a) b c d++instance (NFData o, NFData a) => NFData (AST_TyChk a o) where+  rnf (AST_NotChecked    a) = deepseq a ()+  rnf (AST_Checked a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance (HasNullValue o, HasNullValue a) => HasNullValue (AST_TyChk a o) where+  nullValue = AST_NotChecked nullValue+  testNull (AST_NotChecked  a  ) = testNull a+  testNull (AST_Checked _ _ a _) = testNull a++instance (PPrintable o, PPrintable a) => PPrintable (AST_TyChk a o) where+  pPrint a = case a of+    AST_NotChecked a          -> pPrint a+    AST_Checked    a coms expr _ -> pInline $+      [ pPrint a+      , pPrintComWith (\ () -> pString "::") coms+      , pPrint expr+      ]++instance HasLocation a => HasLocation (AST_TyChk a o) where+  getLocation a     = case a of+    AST_NotChecked a         -> getLocation a+    AST_Checked    a _ _ loc -> getLocation a <> loc+  setLocation a loc = case a of+    AST_NotChecked a         -> AST_NotChecked (setLocation a loc)+    AST_Checked    a b c _   -> AST_Checked a b c loc+  delLocation       = astTyChkDelLocWith delLocation++instance (HasRandGen o, HasRandGen a) => HasRandGen (AST_TyChk a o) where+  randO    = countNode $ AST_NotChecked <$> randO+  --randChoice = randChoiceList [AST_NotChecked <$> randO, return AST_Checked <*> randO <*> randO <*> randO <*> no]+  defaultO = AST_NotChecked <$> defaultO++tyChkToInterm :: (b -> [a]) -> AST_TyChk b o -> [TyChkExpr a o]+tyChkToInterm ti a = case a of+  AST_NotChecked a         -> NotTypeChecked <$> ti a+  AST_Checked    a _ b loc -> [TypeChecked] <*> ti a <*> toInterm b <*> [loc]++tyChkFromInterm :: (a -> [b]) -> TyChkExpr a o -> [AST_TyChk b o]+tyChkFromInterm fi a = case a of+  NotTypeChecked a         -> AST_NotChecked <$> fi a+  TypeChecked    a b   loc -> [AST_Checked] <*> fi a <*> [Com ()] <*> fromInterm b <*> [loc]+  DisableCheck   a b _ loc -> [AST_Checked] <*> fi a <*> [Com ()] <*> fromInterm b <*> [loc]++----------------------------------------------------------------------------------------------------++-- | A list of function parameters (arguments) to a function in an object representing a function+-- expression.+data ParamListExpr o = ParamListExpr (TyChkExpr [ParamExpr o] o) Location+  deriving (Eq, Ord, Typeable, Show)++instance Functor ParamListExpr where+  fmap f (ParamListExpr a loc) =+    ParamListExpr (fmapCheckedValueExpr (fmap (fmap f)) $ fmap f a) loc++instance NFData o => NFData (ParamListExpr o) where { rnf (ParamListExpr a b) = deepseq a $! deepseq b () }++instance HasNullValue (ParamListExpr o) where+  nullValue = ParamListExpr (NotTypeChecked []) LocationUnknown+  testNull (ParamListExpr (NotTypeChecked []) _) = True+  testNull _ = False++instance HasLocation (ParamListExpr o) where+  getLocation (ParamListExpr _ loc)     = loc+  setLocation (ParamListExpr a _  ) loc = ParamListExpr a loc+  delLocation (ParamListExpr a _  )     = ParamListExpr a LocationUnknown++instance PPrintable o => PPrintable (ParamListExpr o) where { pPrint (ParamListExpr lst _) = pPrint lst }++getTypeCheckList :: ParamListExpr o -> [ParamExpr o]+getTypeCheckList (ParamListExpr tychk _) = tyChkItem tychk ++----------------------------------------------------------------------------------------------------++-- | 'ParamExpr' is a part of the Dao language semantics, and is also used in the the 'CallableCode'+-- data type when evaluating parameters to be passed to the callable code function execution. The+-- boolean parameter here indicates whether or not the parameter should be passed by reference.+data ParamExpr o = ParamExpr Bool (TyChkExpr Name o) Location deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (ParamExpr o) where+  rnf (ParamExpr       a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasLocation (ParamExpr o) where+  getLocation (ParamExpr _ _ loc)     = loc+  setLocation (ParamExpr a b _  ) loc = ParamExpr a b loc+  delLocation (ParamExpr a b _  )     = ParamExpr a b LocationUnknown++instance PPrintable o => PPrintable (ParamExpr o) where+  pPrint (ParamExpr byRef tychk _) = when byRef (pString "$") >> pPrint tychk++instance PPrintable o => PPrintable [ParamExpr o] where { pPrint lst = pList_ "(" ", " ")" (fmap pPrint lst) }++----------------------------------------------------------------------------------------------------++data AST_Param o+  = AST_NoParams+  | AST_Param (Maybe [Comment]) (AST_TyChk Name o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_Param o) where+  rnf  AST_NoParams     = ()+  rnf (AST_Param a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue (AST_Param o) where+  nullValue = AST_NoParams+  testNull AST_NoParams = True+  testNull _ = False++instance HasLocation (AST_Param o) where+  getLocation a     = case a of+    AST_NoParams      -> LocationUnknown+    AST_Param _ _ loc -> loc+  setLocation a loc = case a of+    AST_NoParams    -> AST_NoParams+    AST_Param a b _ -> AST_Param a b loc+  delLocation a     = case a of+    AST_NoParams    -> AST_NoParams+    AST_Param a b _ -> AST_Param a (astTyChkDelLocWith delLocation b) LocationUnknown++instance PPrintable o => PPrintable (AST_Param o) where+  pPrint o = case o of+    AST_NoParams            -> return ()+    AST_Param mcoms tychk _ -> pInline $+      [ maybe (return ()) (\coms -> pString "$" >> pPrint coms) mcoms+      , pPrint tychk+      ]++instance PPrintable o => PPrintable [Com (AST_Param o)] where+  pPrint lst = pList_ "(" ", " ")" (fmap pPrint lst)++----------------------------------------------------------------------------------------------------++instance HasRandGen o => HasRandGen (AST_Param o) where+  randO    = countNode $ return AST_Param <*> randO <*> randO <*> no+  defaultO = return AST_Param <*> defaultO <*> defaultO <*> no++instance HasRandGen o => HasRandGen [Com (AST_Param o)] where+  randO    = recurse $ depthLimitedInt 8 >>= \x -> randListOf 0 x scrambO+  defaultO = defaultList 0 1++instance Intermediate (ParamExpr o) (AST_Param o) where+  toInterm   a = case a of+    AST_NoParams      -> []+    AST_Param a b loc ->+      [ParamExpr] <*> [maybe False (const True) a]     <*> tyChkToInterm   return b <*> [loc]+  fromInterm o = case o of+    ParamExpr a b loc ->+      [AST_Param] <*> [if a then Just [] else Nothing] <*> tyChkFromInterm return b <*> [loc]++instance Intermediate [ParamExpr o] [Com (AST_Param o)] where+  toInterm   ax = [ax >>= toInterm . unComment]+  fromInterm ax = [ax >>= fmap Com . fromInterm]++----------------------------------------------------------------------------------------------------++data AST_ParamList o+  = AST_ParamList (AST_TyChk [Com (AST_Param o)] o) Location+  deriving (Eq, Ord, Typeable, Show)++instance Functor AST_ParamList where+  fmap f (AST_ParamList a loc) =+    AST_ParamList (fmapCheckedValueAST (fmap (fmap (fmap f))) $ fmap f a) loc++instance NFData o => NFData (AST_ParamList o) where { rnf (AST_ParamList a b) = deepseq a $! deepseq b () }++instance HasNullValue o => HasNullValue (AST_ParamList o) where+  nullValue = AST_ParamList nullValue LocationUnknown+  testNull (AST_ParamList a _) = testNull a++instance HasLocation (AST_ParamList o) where+  getLocation (AST_ParamList _ loc)     = loc+  setLocation (AST_ParamList a _  ) loc = AST_ParamList a loc+  delLocation (AST_ParamList a _  )     = AST_ParamList (astTyChkDelLocWith (fmap delLocation) a) LocationUnknown++instance PPrintable o => PPrintable (AST_ParamList o) where+  pPrint (AST_ParamList lst _) = pInline [pPrint lst]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ParamList o) where+  randO    = countNode $ return AST_ParamList <*> randO <*> no+  defaultO = return $ AST_ParamList nullValue LocationUnknown++instance Intermediate (ParamListExpr o) (AST_ParamList o) where+  toInterm   (AST_ParamList ox loc) = [ParamListExpr] <*> tyChkToInterm   toInterm   ox <*> [loc]+  fromInterm (ParamListExpr ox loc) = [AST_ParamList] <*> tyChkFromInterm fromInterm ox <*> [loc]++----------------------------------------------------------------------------------------------------++data RuleFuncExpr o+  = LambdaExpr    (ParamListExpr o) (CodeBlock o) Location+  | FuncExpr Name (ParamListExpr o) (CodeBlock o) Location+  | RuleExpr      (RuleHeadExpr  o) (CodeBlock o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (RuleFuncExpr o) where+  rnf (LambdaExpr a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (FuncExpr   a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (RuleExpr   a b c  ) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue (RuleFuncExpr o) where+  nullValue = LambdaExpr nullValue nullValue LocationUnknown+  testNull (RuleExpr a b _) = testNull a && testNull b+  testNull _                = False++instance HasLocation (RuleFuncExpr o) where+  getLocation o = case o of+    LambdaExpr _ _   o -> o+    FuncExpr   _ _ _ o -> o+    RuleExpr   _ _   o -> o+  setLocation o loc = case o of+    LambdaExpr a b   _ -> LambdaExpr a b   loc+    FuncExpr   a b c _ -> FuncExpr   a b c loc+    RuleExpr   a b   _ -> RuleExpr   a b   loc+  delLocation o = case o of+    LambdaExpr a b   _ -> LambdaExpr (delLocation a) (delLocation b) LocationUnknown+    FuncExpr   a b c _ -> FuncExpr a (delLocation b) (delLocation c) LocationUnknown+    RuleExpr   a b   _ -> RuleExpr a (delLocation b)                 LocationUnknown++instance PPrintable o => PPrintable (RuleFuncExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++data AST_RuleFunc o+  = AST_Lambda              (Com (AST_ParamList  o)) (AST_CodeBlock o) Location+  | AST_Func [Comment] Name (Com (AST_ParamList  o)) (AST_CodeBlock o) Location+  | AST_Rule                (Com (AST_RuleHeader o)) (AST_CodeBlock o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_RuleFunc o) where+  rnf (AST_Lambda a b c    ) = deepseq a $! deepseq b $! deepseq c () +  rnf (AST_Func   a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e ()+  rnf (AST_Rule   a b c    ) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue o => HasNullValue (AST_RuleFunc o) where+  nullValue = AST_Lambda nullValue nullValue LocationUnknown+  testNull (AST_Lambda a b _) = testNull a && testNull b+  testNull _                  = False++instance HasLocation (AST_RuleFunc o) where+  getLocation o = case o of+    AST_Lambda _ _     o -> o+    AST_Func   _ _ _ _ o -> o+    AST_Rule   _ _     o -> o+  setLocation o loc = case o of+    AST_Lambda a b     _ -> AST_Lambda a b     loc+    AST_Func   a b c d _ -> AST_Func   a b c d loc+    AST_Rule   a b     _ -> AST_Rule   a b     loc+  delLocation o = case o of                            +    AST_Lambda a b     _ -> AST_Lambda (delLocation  a) (delLocation  b) LocationUnknown+    AST_Func   a b c d _ -> AST_Func a b  (delLocation  c) (delLocation  d) LocationUnknown+    AST_Rule   a b     _ -> AST_Rule   (delLocation  a) (delLocation  b) LocationUnknown++instance PPrintable o => PPrintable (AST_RuleFunc o) where+  pPrint expr = case expr of+    AST_Lambda         ccNmx   xcObjXp     _ ->+      pPrintSubBlock (pInline [pString "function", pPrintComWith pPrint ccNmx]) xcObjXp+    AST_Func     co nm ccNmx   xcObjXp     _ ->+      pClosure (pInline [pString "function ", pPrint co, pPrint nm, pPrint ccNmx]) "{" "}" [pPrint xcObjXp]+    AST_Rule           ccNmx   xcObjXp     _ -> pClosure (pPrint ccNmx) "{" "}" [pPrint xcObjXp]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RuleFunc o) where+  randO      = recurse $ countNode $ runRandChoice+  randChoice = randChoiceList $+    [ scramble $ return AST_Lambda <*> randO <*> randO <*> no+    , scramble $ return AST_Func   <*> randO <*> randO <*> randO <*> randO <*> no+    , scramble $ return AST_Rule   <*> randO <*> randO <*> no+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ scramble $ return AST_Lambda <*> defaultO <*> defaultO <*> no+    , scramble $ return AST_Func   <*> defaultO <*> defaultO <*> defaultO <*> defaultO <*> no+    , scramble $ return AST_Rule   <*> defaultO <*> defaultO <*> no+    ]++instance Intermediate (RuleFuncExpr o) (AST_RuleFunc o) where+  toInterm ast = case ast of+    AST_Lambda a b   loc -> [LambdaExpr]       <*> uc0 a <*> ti b <*> [loc]+    AST_Func _ a b c loc -> [FuncExpr] <*> [a] <*> uc0 b <*> ti c <*> [loc]+    AST_Rule   a b   loc -> [RuleExpr]         <*> uc0 a <*> ti b <*> [loc]+  fromInterm o = case o of+    LambdaExpr a b   loc -> [AST_Lambda]                <*> nc0 a <*> fi b <*> [loc]+    FuncExpr   a b c loc -> [AST_Func] <*> [[]] <*> [a] <*> nc0 b <*> fi c <*> [loc]+    RuleExpr   a b   loc -> [AST_Rule]                  <*> nc0 a <*> fi b <*> [loc]++----------------------------------------------------------------------------------------------------++data RuleHeadExpr o+  = RuleStringExpr  UStr        Location+  | RuleHeadExpr [AssignExpr o] Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance HasNullValue (RuleHeadExpr o) where+  nullValue = RuleStringExpr nil LocationUnknown+  testNull (RuleStringExpr a _) = a==nil+  testNull _ = False++instance HasLocation (RuleHeadExpr o) where+  getLocation o     = case o of+    RuleStringExpr _ o -> o+    RuleHeadExpr   _ o -> o+  setLocation o loc = case o of+    RuleStringExpr o _ -> RuleStringExpr o loc+    RuleHeadExpr   o _ -> RuleHeadExpr o loc+  delLocation o     = case o of+    RuleStringExpr o _ -> RuleStringExpr o LocationUnknown+    RuleHeadExpr   o _ -> RuleHeadExpr (fmap delLocation o) LocationUnknown++instance NFData o => NFData (RuleHeadExpr o) where+  rnf (RuleStringExpr a b) = deepseq a $! deepseq b ()+  rnf (RuleHeadExpr     a b) = deepseq a $! deepseq b ()++----------------------------------------------------------------------------------------------------++data AST_RuleHeader o+  = AST_NullRules  [Comment]  Location+  | AST_RuleString (Com UStr) Location+  | AST_RuleHeader [Com (AST_Assign o)] Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_RuleHeader o) where+  rnf (AST_NullRules  a b) = deepseq a $! deepseq b ()+  rnf (AST_RuleString a b) = deepseq a $! deepseq b ()+  rnf (AST_RuleHeader a b) = deepseq a $! deepseq b ()++instance HasNullValue (AST_RuleHeader o) where+  nullValue = AST_NullRules [] LocationUnknown+  testNull (AST_NullRules _ _) = True+  testNull _ = False++instance HasLocation (AST_RuleHeader o) where+  getLocation o     = case o of+    AST_NullRules  _ o -> o+    AST_RuleString _ o -> o+    AST_RuleHeader _ o -> o+  setLocation o loc = case o of+    AST_NullRules  a _ -> AST_NullRules  a loc+    AST_RuleString a _ -> AST_RuleString a loc+    AST_RuleHeader a _ -> AST_RuleHeader a loc+  delLocation o     = case o of+    AST_NullRules  a _ -> AST_NullRules  a LocationUnknown+    AST_RuleString a _ -> AST_RuleString a LocationUnknown+    AST_RuleHeader a _ -> AST_RuleHeader (fmap delLocation a) LocationUnknown++instance PPrintable o => PPrintable (AST_RuleHeader o) where+  pPrint o = case o of+    AST_NullRules  coms _ -> pInline [pString "rule(", pPrint coms, pString ")"]+    AST_RuleString r    _ -> pInline [pString "rule ", pPrintComWith pShow r, pString " "]+    AST_RuleHeader ruls _ -> pList (pString "rule") "(" ", " ")" (fmap pPrint ruls)++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RuleHeader o) where+  randO      = countNode $ runRandChoice+  randChoice = randChoiceList $+    [ return AST_RuleHeader <*> randList 0 3 <*> no+    , return AST_RuleString <*> randO   <*> no+    , return AST_NullRules  <*> scrambO <*> no+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ return AST_NullRules  <*> defaultO <*> no+    , return AST_RuleString <*> defaultO <*> no+    ]++instance Intermediate (RuleHeadExpr o) (AST_RuleHeader o) where+  toInterm   o = case o of+    AST_NullRules  _ loc -> [RuleHeadExpr              []     loc]+    AST_RuleString o loc -> [RuleStringExpr (unComment o)     loc]+    AST_RuleHeader o loc -> [RuleHeadExpr] <*> [o>>=uc0] <*> [loc]+  fromInterm o = case o of+    RuleHeadExpr   [] loc -> [AST_NullRules               []     loc]+    RuleStringExpr o  loc -> [AST_RuleString       (Com   o)     loc]+    RuleHeadExpr   o  loc -> [AST_RuleHeader] <*> [o>>=nc0] <*> [loc]++----------------------------------------------------------------------------------------------------++-- | Defined such that the instantiation of 'CodeBlock' into the 'Executable' class executes each+-- 'ScriptExpr' in the 'CodeBlock', one after the other. Execution does not+-- occur within a 'execNested' because many other expressions which execute 'CodeBlock's,+-- especially 'TryCatch' expressions and 'ForLoop's need to be able to choose+-- when the stack is pushed so they can define temporary local variables.+newtype CodeBlock o = CodeBlock { codeBlock :: [ScriptExpr o] }+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (CodeBlock o) where { rnf (CodeBlock a) = deepseq a () }++instance Monoid (CodeBlock o) where+  mempty      = CodeBlock []+  mappend a b = CodeBlock (mappend (codeBlock a) (codeBlock b))++instance HasNullValue (CodeBlock o) where+  nullValue = mempty+  testNull (CodeBlock []) = True+  testNull _ = False++instance HasLocation (CodeBlock o) where+  getLocation o = case codeBlock o of+    [] -> LocationUnknown+    [o] -> getLocation o+    o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox))+  setLocation o _ = o+  delLocation o = CodeBlock (fmap delLocation (codeBlock o))++instance PPrintable o => PPrintable (CodeBlock o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++-- | This node in the AST typically represents the list of 'AST_Script' expressions found between+-- curly-brackets in expressions like "if" and "else" statement, "for" statements and "while"+-- statements, "with" satements, "try" and "catch" statements and function declrataions.+newtype AST_CodeBlock o = AST_CodeBlock{ getAST_CodeBlock :: [AST_Script o] }+  deriving (Eq, Ord, Typeable, Show, Functor)+  -- A code block is never standing on it's own, it is always part of a larger expression, so there+  -- is no 'Dao.Token.Location' parameter for 'AST_CodeBlock'.++instance Monoid (AST_CodeBlock o) where+  mempty      = AST_CodeBlock []+  mappend a b = AST_CodeBlock (mappend (getAST_CodeBlock a) (getAST_CodeBlock b))++instance NFData o => NFData (AST_CodeBlock o) where { rnf (AST_CodeBlock a) = deepseq a () }++instance HasNullValue (AST_CodeBlock o) where+  nullValue = AST_CodeBlock []+  testNull (AST_CodeBlock a) = null a++instance HasLocation (AST_CodeBlock o) where                                      +  getLocation o = case getAST_CodeBlock o of+    [] -> LocationUnknown+    [o] -> getLocation o+    o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox))+  setLocation o _ = o+  delLocation o = AST_CodeBlock (fmap delLocation (getAST_CodeBlock o))++-- 'pPrintComWith' wasn't good enough for this, because the comments might occur after the header+-- but before the opening bracket.+pPrintComCodeBlock :: PPrintable o => PPrint -> Com (AST_CodeBlock o) -> PPrint+pPrintComCodeBlock header c = case c of+  Com          c    -> run [] c []+  ComBefore bx c    -> run bx c []+  ComAfter     c ax -> run [] c ax+  ComAround bx c ax -> run bx c ax+  where+    run :: PPrintable o => [Comment] -> (AST_CodeBlock o) -> [Comment] -> PPrint+    run before cx after = case getAST_CodeBlock cx of+      [] -> header >> pInline (map pPrint before) >> pString " {}" >> pInline (map pPrint after)+      cx -> do+        pClosure (header >> pInline (map pPrint before)) " { " " }" (map (pGroup True . pPrint) cx)+        pInline (map pPrint after)++pPrintSubBlock :: PPrintable o => PPrint -> (AST_CodeBlock o) -> PPrint+pPrintSubBlock header px = pPrintComCodeBlock header (Com px)++instance PPrintable o => PPrintable (AST_CodeBlock o) where { pPrint o = mapM_ pPrint (getAST_CodeBlock o) }++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_CodeBlock o) where+  randO    = countNode $ AST_CodeBlock . concat <$> sequence [return <$> scrambO, depthLimitedInt 16 >>= \x -> randList 0 x]+  defaultO = return $ AST_CodeBlock []++instance Intermediate (CodeBlock o) (AST_CodeBlock o) where+  toInterm   (AST_CodeBlock ast) = [CodeBlock     $ ast >>= toInterm  ]+  fromInterm (CodeBlock     obj) = [AST_CodeBlock $ obj >>= fromInterm]++----------------------------------------------------------------------------------------------------++data IfExpr o = IfExpr (ParenExpr o) (CodeBlock o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (IfExpr o) where { rnf (IfExpr a b c) = deepseq a $! deepseq b $! deepseq c () }++instance HasNullValue (IfExpr o) where+  nullValue = IfExpr nullValue nullValue LocationUnknown+  testNull (IfExpr a b _) = testNull a && testNull b++instance HasLocation (IfExpr o) where+  getLocation (IfExpr _ _ loc)     = loc+  setLocation (IfExpr a b _  ) loc = IfExpr a b loc+  delLocation (IfExpr a b _  )     = IfExpr (delLocation a) (delLocation b) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_If o = AST_If (Com (AST_Paren o)) (AST_CodeBlock o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_If o) where { rnf (AST_If a b c) = deepseq a $! deepseq b $! deepseq c () }++instance HasLocation (AST_If o) where+  getLocation (AST_If _ _ loc)     = loc+  setLocation (AST_If a b _  ) loc = AST_If a b loc+  delLocation (AST_If a b _  )     = AST_If (delLocation a) (delLocation b) LocationUnknown++instance HasNullValue (AST_If o) where+  nullValue = AST_If nullValue nullValue LocationUnknown+  testNull (AST_If a b _) = testNull a && testNull b++instance PPrintable o => PPrintable (AST_If o) where+  pPrint (AST_If ifn thn _) =+    pClosure (pString "if" >> pPrint ifn) "{" "}" [pPrint thn]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_If o) where+  randO    = countNode $ return AST_If <*> randO <*> randO <*> no+  defaultO = return AST_If <*> defaultO <*> defaultO <*> no++instance Intermediate (IfExpr o) (AST_If o) where+  toInterm   (AST_If a b loc) = [IfExpr] <*> uc0 a <*> ti b <*> [loc]+  fromInterm (IfExpr a b loc) = [AST_If] <*> nc0 a <*> fi b <*> [loc]++----------------------------------------------------------------------------------------------------++data ElseExpr o = ElseExpr (IfExpr o) Location deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (ElseExpr o) where { rnf (ElseExpr   a b  ) = deepseq a $! deepseq b $! () }++instance HasNullValue (ElseExpr o) where+  nullValue = ElseExpr nullValue LocationUnknown+  testNull (ElseExpr a _) = testNull a++instance HasLocation (ElseExpr o) where+  getLocation (ElseExpr _ loc)     = loc+  setLocation (ElseExpr a _  ) loc = ElseExpr a loc+  delLocation (ElseExpr a _  )     = ElseExpr (delLocation a) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_Else o = AST_Else (Com ()) (AST_If o) Location deriving (Eq, Ord, Typeable, Show, Functor)+  -- ^ @/**/ else /**/ if /**/ obj /**/ {}@++instance NFData o => NFData (AST_Else o) where { rnf (AST_Else a b c) = deepseq a $! deepseq b $! deepseq c () }++instance HasNullValue (AST_Else o) where+  nullValue = AST_Else nullValue nullValue LocationUnknown+  testNull (AST_Else a b _) = testNull a && testNull b++instance HasLocation (AST_Else o) where+  getLocation (AST_Else _ _ loc)     = loc+  setLocation (AST_Else a b _  ) loc = AST_Else a b loc+  delLocation (AST_Else a b _  )     = AST_Else a (delLocation b) LocationUnknown++instance PPrintable o => PPrintable (AST_Else o) where+  pPrint (AST_Else coms (AST_If ifn thn _) _) =+    pClosure (pPrintComWith (\ () -> pString "else ") coms >> pString "if" >> pPrint ifn) "{" "}" [pPrint thn]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Else o) where+  randO    = countNode $ return AST_Else <*> randO <*> randO <*> no+  defaultO = return AST_Else <*> defaultO <*> defaultO <*> no++instance Intermediate (ElseExpr o) (AST_Else o) where+  toInterm   (AST_Else _ a loc) = [ElseExpr]              <*> ti a <*> [loc]+  fromInterm (ElseExpr   a loc) = [AST_Else] <*> [Com ()] <*> fi a <*> [loc]++----------------------------------------------------------------------------------------------------++data IfElseExpr o = IfElseExpr (IfExpr o) [ElseExpr o] (Maybe (LastElseExpr o)) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (IfElseExpr o) where+  rnf (IfElseExpr a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (IfElseExpr o) where+  nullValue = IfElseExpr nullValue [] Nothing LocationUnknown+  testNull (IfElseExpr a [] Nothing _) = testNull a+  testNull _ = False++instance HasLocation (IfElseExpr o) where+  getLocation (IfElseExpr _ _ _ loc)     = loc+  setLocation (IfElseExpr a b c _  ) loc = IfElseExpr a b c loc+  delLocation (IfElseExpr a b c _  )     =+    IfElseExpr (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_IfElse o = AST_IfElse (AST_If o) [AST_Else o] (Maybe (AST_LastElse o)) Location+  -- ^ @if /**/ obj /**/ {} /**/ else /**/ if /**/ obj /**/ {} /**/ else {}@+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_IfElse o) where+  rnf (AST_IfElse a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasNullValue (AST_IfElse o) where+  nullValue = AST_IfElse nullValue [] Nothing LocationUnknown+  testNull (AST_IfElse a [] Nothing _) = testNull a+  testNull _ = False++instance HasLocation (AST_IfElse o) where+  getLocation (AST_IfElse _ _ _ loc)     = loc+  setLocation (AST_IfElse a b c _  ) loc = AST_IfElse a b c loc+  delLocation (AST_IfElse a b c _  )     = AST_IfElse (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown++instance PPrintable o => PPrintable (AST_IfElse o) where+  pPrint (AST_IfElse ifn els deflt _) = do+    pPrint ifn >> pNewLine+    mapM_ pPrint els >> pNewLine+    maybe (return ()) pPrint deflt++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_IfElse o) where+  randO    = countNode $ depthLimitedInt 8 >>= \x ->+    return AST_IfElse <*> randO <*> randList 0 x <*> randO <*> no+  defaultO = return AST_IfElse <*> defaultO <*> defaultList 0 1 <*> randO <*> no++instance Intermediate (IfElseExpr o) (AST_IfElse o) where+  toInterm   (AST_IfElse a b c loc) =+    [IfElseExpr] <*> ti a <*> [b>>=ti] <*> um1 c <*> [loc]+  fromInterm (IfElseExpr a b c loc) =+    [AST_IfElse] <*> fi a <*> [b>>=fi] <*> nm1 c <*> [loc]++----------------------------------------------------------------------------------------------------++data LastElseExpr o = LastElseExpr (CodeBlock o) Location+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (LastElseExpr o) where+  rnf (LastElseExpr a b) = deepseq a $! deepseq b ()++instance HasNullValue (LastElseExpr o) where+  nullValue = LastElseExpr nullValue LocationUnknown+  testNull (LastElseExpr o _) = testNull o++instance HasLocation (LastElseExpr o) where+  getLocation (LastElseExpr _ loc)     = loc+  setLocation (LastElseExpr a _  ) loc = LastElseExpr a loc+  delLocation (LastElseExpr a _  )     = LastElseExpr (delLocation a) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_LastElse o = AST_LastElse (Com ()) (AST_CodeBlock o) Location+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (AST_LastElse o) where+  rnf (AST_LastElse a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue (AST_LastElse o) where+  nullValue = AST_LastElse (Com ()) nullValue LocationUnknown+  testNull (AST_LastElse a b _) = testNull a && testNull b++instance HasLocation (AST_LastElse o) where+  getLocation (AST_LastElse _ _ loc)     = loc+  setLocation (AST_LastElse a b _  ) loc = AST_LastElse a b loc+  delLocation (AST_LastElse a b _  )     = AST_LastElse a (delLocation b) LocationUnknown++instance PPrintable o => PPrintable (AST_LastElse o) where+  pPrint (AST_LastElse coms code _) =+    pClosure (pPrintComWith (\ () -> pString "else") coms) "{" "}" [pPrint code]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_LastElse o) where+  randO         = countNode $ return AST_LastElse <*> randO <*> randO <*> no+  randChoice    = randChoiceList [randO]+  defaultO      = return AST_LastElse <*> defaultO <*> defaultO <*> no+  defaultChoice = randChoiceList [defaultO]++instance Intermediate (LastElseExpr o) (AST_LastElse o) where+  toInterm   (AST_LastElse _ o loc) = [LastElseExpr] <*>              toInterm   o <*> [loc]+  fromInterm (LastElseExpr   o loc) = [AST_LastElse] <*> [Com ()] <*> fromInterm o <*> [loc]++----------------------------------------------------------------------------------------------------++data CatchExpr o = CatchExpr (ParamExpr o) (CodeBlock o) Location+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (CatchExpr o) where+  rnf (CatchExpr a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasLocation (CatchExpr o) where+  getLocation (CatchExpr _ _ loc)     = loc+  setLocation (CatchExpr a b _  ) loc = CatchExpr a b loc+  delLocation (CatchExpr a b _  )     = CatchExpr (delLocation a) (delLocation b) LocationUnknown++----------------------------------------------------------------------------------------------------++data AST_Catch o = AST_Catch [Comment] (Com (AST_Param o)) (AST_CodeBlock o) Location+  deriving (Eq, Ord, Show, Typeable, Functor)++instance NFData o => NFData (AST_Catch o) where+  rnf (AST_Catch a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++instance HasLocation (AST_Catch o) where+  getLocation (AST_Catch _ _ _ loc)     = loc+  setLocation (AST_Catch a b c _  ) loc = AST_Catch a b c loc+  delLocation (AST_Catch a b c _  )     = AST_Catch a (delLocation b) (delLocation c) LocationUnknown++instance PPrintable o => PPrintable (AST_Catch o) where+  pPrint (AST_Catch coms param code _) = pPrint coms >>+    pClosure (pString "catch " >> pPrint param) "{" "}" [pPrint code]++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Catch o) where+  randO         = countNode $ return AST_Catch <*> randO <*> randO <*> randO <*> no+  randChoice    = randChoiceList [randO]+  defaultO      = return AST_Catch <*> defaultO <*> defaultO <*> defaultO <*> no+  defaultChoice = randChoiceList [defaultO]++instance Intermediate (CatchExpr o) (AST_Catch o) where+  toInterm   (AST_Catch _ a b loc) = [CatchExpr]          <*> uc0 a <*> ti b <*> [loc]+  fromInterm (CatchExpr   a b loc) = [AST_Catch] <*> [[]] <*> nc0 a <*> fi b <*> [loc]++----------------------------------------------------------------------------------------------------++newtype WhileExpr o = WhileExpr (IfExpr o) deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (WhileExpr o)  where { rnf (WhileExpr (IfExpr a b c)) = deepseq a $! deepseq b $! deepseq c () }++instance HasNullValue (WhileExpr o) where+  nullValue = WhileExpr nullValue+  testNull (WhileExpr a) = testNull a++instance HasLocation (WhileExpr o) where+  getLocation (WhileExpr a)     = getLocation a+  setLocation (WhileExpr a) loc = WhileExpr (setLocation a loc)+  delLocation (WhileExpr a)     = WhileExpr (delLocation a)++----------------------------------------------------------------------------------------------------++newtype AST_While o = AST_While (AST_If o) deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_While o) where { rnf (AST_While (AST_If a b c)) = deepseq a $! deepseq b $! deepseq c () }++instance HasNullValue (AST_While o) where+  nullValue = AST_While nullValue+  testNull (AST_While a) = testNull a++instance HasLocation (AST_While o) where+  getLocation (AST_While a) = getLocation a+  setLocation (AST_While a) loc = AST_While (setLocation a loc)+  delLocation (AST_While a)     = AST_While (delLocation a)++instance PPrintable o => PPrintable (AST_While o) where+  pPrint (AST_While (AST_If ifn thn _)) =+    pClosure (pInline [pString "while", pPrint ifn]) "{" "}" [pPrint thn]++instance Intermediate (WhileExpr o) (AST_While o) where+  toInterm   (AST_While a) = WhileExpr <$> ti a+  fromInterm (WhileExpr a) = AST_While <$> fi a++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_While o)  where+  randO    = AST_While <$> randO+  defaultO = AST_While <$> defaultO++----------------------------------------------------------------------------------------------------++-- | Part of the Dao language abstract syntax tree: any expression that controls the flow of script+-- exectuion.+data ScriptExpr o+  = IfThenElse   (IfElseExpr   o)+  | WhileLoop    (WhileExpr    o)+  | RuleFuncExpr (RuleFuncExpr o)+  | EvalObject   (AssignExpr   o)                                 Location -- location of the semicolon+  | TryCatch     (CodeBlock    o) [LastElseExpr  o] [CatchExpr o] Location+  | ForLoop       Name            (RefPrefixExpr o) (CodeBlock o) Location+  | ContinueExpr  Bool            (AssignExpr    o)               Location+  | ReturnExpr    Bool            (AssignExpr    o)               Location+  | WithDoc      (ParenExpr    o) (CodeBlock     o)               Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (ScriptExpr o) where+  rnf (IfThenElse   a      ) = deepseq a ()+  rnf (WhileLoop    a      ) = deepseq a ()+  rnf (RuleFuncExpr a      ) = deepseq a ()+  rnf (EvalObject   a b    ) = deepseq a $! deepseq b ()+  rnf (TryCatch     a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (ForLoop      a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (ContinueExpr a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (ReturnExpr   a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (WithDoc      a b c  ) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue o => HasNullValue (ScriptExpr o) where+  nullValue = EvalObject nullValue LocationUnknown+  testNull (EvalObject a _) = testNull a+  testNull _ = False++instance HasLocation (ScriptExpr o) where+  getLocation o = case o of+    EvalObject   _     o -> o+    IfThenElse         o -> getLocation o+    RuleFuncExpr       o -> getLocation o+    WhileLoop          o -> getLocation o+    TryCatch     _ _ _ o -> o+    ForLoop      _ _ _ o -> o+    ContinueExpr _ _   o -> o+    ReturnExpr   _ _   o -> o+    WithDoc      _ _   o -> o+  setLocation o loc = case o of+    EvalObject   a     _ -> EvalObject   a     loc+    IfThenElse   a       -> IfThenElse   (setLocation a loc)+    WhileLoop    a       -> WhileLoop    (setLocation a loc)+    RuleFuncExpr a       -> RuleFuncExpr (setLocation a loc)+    TryCatch     a b c _ -> TryCatch     a b c loc+    ForLoop      a b c _ -> ForLoop      a b c loc+    ContinueExpr a b   _ -> ContinueExpr a b   loc+    ReturnExpr   a b   _ -> ReturnExpr   a b   loc+    WithDoc      a b   _ -> WithDoc      a b   loc+  delLocation o = case o of+    EvalObject   a     _ -> EvalObject   (delLocation a)                    LocationUnknown+    IfThenElse   a       -> IfThenElse   (delLocation a)+    WhileLoop    a       -> WhileLoop    (delLocation a)+    RuleFuncExpr a       -> RuleFuncExpr (delLocation a)+    TryCatch     a b c _ -> TryCatch     (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown+    ForLoop      a b c _ -> ForLoop      a (delLocation b) (delLocation c) LocationUnknown+    ContinueExpr a b   _ -> ContinueExpr a (delLocation b)                 LocationUnknown+    ReturnExpr   a b   _ -> ReturnExpr   a (delLocation b)                 LocationUnknown+    WithDoc      a b   _ -> WithDoc      (delLocation a) (delLocation b)   LocationUnknown++----------------------------------------------------------------------------------------------------++-- | Part of the Dao language abstract syntax tree: any expression that controls the flow of script+-- exectuion.+data AST_Script o+  = AST_Comment     [Comment] +  | AST_IfThenElse  (AST_IfElse o)+  | AST_WhileLoop   (AST_While o)+  | AST_RuleFunc    (AST_RuleFunc o)+  | AST_EvalObject  (AST_Assign o)  [Comment]                                          Location+    -- ^ @some.object.expression = for.example - equations || function(calls) /**/ ;@+  | AST_TryCatch    [Comment] (AST_CodeBlock o)   [AST_LastElse  o]  [AST_Catch     o] Location+    -- ^ @try /**/ {} /**/ else /**/ {} /**/ catch /**/ errVar /**/ {}@              +  | AST_ForLoop     (Com Name)               (Com (AST_RefPrefix o)) (AST_CodeBlock o) Location+    -- ^ @for /**/ var /**/ in /**/ objExpr /**/ {}@+  | AST_ContinueExpr Bool  [Comment]         (Com (AST_Assign    o))                   Location+    -- ^ The boolean parameter is True for a "continue" statement, False for a "break" statement.+    -- @continue /**/ ;@ or @continue /**/ if /**/ objExpr /**/ ;@+  | AST_ReturnExpr   Bool                    (Com (AST_Assign    o))                   Location+    -- ^ The boolean parameter is True for a "return" statement, False for a "throw" statement.+    -- ^ @return /**/ ;@ or @return /**/ objExpr /**/ ;@+  | AST_WithDoc      (Com (AST_Paren o))          (AST_CodeBlock o)                    Location+    -- ^ @with /**/ objExpr /**/ {}@+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (AST_Script o) where+  rnf (AST_Comment      a        ) = deepseq a ()+  rnf (AST_IfThenElse   a        ) = deepseq a ()+  rnf (AST_WhileLoop    a        ) = deepseq a ()+  rnf (AST_RuleFunc     a        ) = deepseq a ()+  rnf (AST_EvalObject   a b c    ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (AST_TryCatch     a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e ()+  rnf (AST_ForLoop      a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (AST_ContinueExpr a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (AST_ReturnExpr   a b c    ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (AST_WithDoc      a b c    ) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue (AST_Script o) where+  nullValue = AST_EvalObject nullValue [] LocationUnknown+  testNull (AST_EvalObject a _ _) = testNull a+  testNull _ = False++instance HasLocation (AST_Script o) where+  getLocation o = case o of+    AST_Comment      _         -> LocationUnknown+    AST_EvalObject   _   _   o -> o+    AST_IfThenElse           o -> getLocation o+    AST_WhileLoop            o -> getLocation o+    AST_RuleFunc             o -> getLocation o+    AST_TryCatch     _ _ _ _ o -> o+    AST_ForLoop      _ _ _   o -> o+    AST_ContinueExpr _ _ _   o -> o+    AST_ReturnExpr   _ _     o -> o+    AST_WithDoc      _ _     o -> o+  setLocation o loc = case o of+    AST_Comment      a         -> AST_Comment      a+    AST_EvalObject   a b     _ -> AST_EvalObject   a b   loc+    AST_IfThenElse   a         -> AST_IfThenElse   (setLocation a loc)+    AST_WhileLoop    a         -> AST_WhileLoop    (setLocation a loc)+    AST_RuleFunc     a         -> AST_RuleFunc     (setLocation a loc)+    AST_TryCatch     a b c d _ -> AST_TryCatch     a b c d loc+    AST_ForLoop      a b c   _ -> AST_ForLoop      a b c   loc+    AST_ContinueExpr a b c   _ -> AST_ContinueExpr a b c   loc+    AST_ReturnExpr   a b     _ -> AST_ReturnExpr   a b     loc+    AST_WithDoc      a b     _ -> AST_WithDoc      a b     loc+  delLocation o = case o of+    AST_Comment      a         -> AST_Comment      a+    AST_EvalObject   a b     _ -> AST_EvalObject   (delLocation  a) b LocationUnknown+    AST_IfThenElse   a         -> AST_IfThenElse   (delLocation  a)+    AST_WhileLoop    a         -> AST_WhileLoop    (delLocation  a)+    AST_RuleFunc     a         -> AST_RuleFunc     (delLocation  a)+    AST_TryCatch     a b c d _ -> AST_TryCatch     a (delLocation b) (fmap delLocation c) (fmap delLocation d) LocationUnknown+    AST_ForLoop      a b c   _ -> AST_ForLoop      a (fmap delLocation b) (delLocation c) LocationUnknown+    AST_ContinueExpr a b c   _ -> AST_ContinueExpr a b (fmap delLocation c) LocationUnknown+    AST_ReturnExpr   a b     _ -> AST_ReturnExpr   a (fmap delLocation b) LocationUnknown+    AST_WithDoc      a b     _ -> AST_WithDoc      (fmap delLocation a) (delLocation b) LocationUnknown++instance PPrintable o => PPrintable (AST_Script o) where+  pPrint expr = pGroup True $ case expr of+    AST_Comment             coms -> mapM_ pPrint coms+    AST_EvalObject   objXp  coms                      _ ->+      pPrint objXp >> mapM_ pPrint coms >> pString ";"+    AST_IfThenElse   ifXp                          -> pPrint ifXp+    AST_WhileLoop    whileLoop                     -> pPrint whileLoop+    AST_RuleFunc     ruleOrFunc                    -> pPrint ruleOrFunc+    AST_TryCatch     coms scrpXp elsXp catchExpr _ -> do+      pClosure (pString "try" >> pPrint coms) "{" "}" [pPrint scrpXp]+      mapM_ (\o -> pPrint o >> pEndLine) elsXp+      mapM_ (\o -> pPrint o >> pEndLine) catchExpr+    AST_ForLoop      cNm      cObjXp  xcScrpXp   _ ->+      pPrintSubBlock (pString "for " >> pPrint cNm >> pString " in " >> pPrint cObjXp) xcScrpXp+    AST_ContinueExpr contin   coms    cObjXp     _ -> pWrapIndent $+      [ pString (if contin then "continue" else "break")+      , pInline (map pPrint coms)+      , case unComment cObjXp of+          AST_Eval (AST_ObjArith (AST_Object AST_Void)) -> return ()+          _ -> pString " if" >> when (precedeWithSpace cObjXp) (pString " ") >> pPrint cObjXp+      , pString ";"+      ]+    AST_ReturnExpr   retrn           cObjXp      _ -> pWrapIndent $+      [pString (if retrn then "return " else "throw "), pPrint cObjXp, pString ";"]+    AST_WithDoc      cObjXp          xcScrpXp    _ ->+      pPrintSubBlock (pString "with " >> pPrint cObjXp) xcScrpXp++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Script o) where+  randO      = countNode $ recurse $ runRandChoice+  randChoice = randChoiceList $+    [ return AST_EvalObject   <*> randO <*> randO <*> no+    , return AST_IfThenElse   <*> randO+    , return AST_WhileLoop    <*> randO+    , return AST_RuleFunc     <*> randO+    , scramble $ depthLimitedInt 4 >>= \x -> depthLimitedInt 4 >>= \y -> +        return AST_TryCatch <*> randO <*> randO <*> randList 0 x <*> randList 0 y <*> no+    , scramble $ return AST_ForLoop      <*> randO <*> randO <*> randO <*> no+    , scramble $ return AST_ContinueExpr <*> randO <*> randO <*> randO <*> no+    , scramble $ return AST_ReturnExpr   <*> randO <*> randO <*> no+    , scramble $ return AST_WithDoc      <*> randO <*> randO <*> no+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ AST_IfThenElse <$> defaultO+    , AST_WhileLoop  <$> defaultO+    , AST_RuleFunc   <$> defaultO+    , return AST_TryCatch     <*> pure []  <*> defaultO <*> defaultList 0 1 <*> defaultList 0 1 <*> no+    , return AST_ContinueExpr <*> defaultO <*> defaultO <*> defaultO <*> no+    , return AST_ReturnExpr   <*> defaultO <*> defaultO <*> no+    ]++instance PPrintable o => PPrintable (ScriptExpr o) where { pPrint = pPrintInterm }++instance Intermediate (ScriptExpr o) (AST_Script o) where+  toInterm   ast = case ast of+    AST_Comment      _           -> mzero+    AST_EvalObject   a _     loc -> [EvalObject  ] <*> ti  a                     <*> [loc]+    AST_IfThenElse   a           -> [IfThenElse  ] <*> ti  a+    AST_WhileLoop    a           -> [WhileLoop   ] <*> ti  a+    AST_RuleFunc     a           -> [RuleFuncExpr] <*> ti  a+    AST_TryCatch     _ a b c loc -> [TryCatch    ] <*> ti  a <*> mapM ti b <*> mapM ti c <*> [loc]+    AST_ForLoop      a b c   loc -> [ForLoop     ] <*> uc  a <*> uc0 b <*> ti  c <*> [loc]+    AST_ContinueExpr a _ c   loc -> [ContinueExpr] <*> [a]   <*> uc0 c           <*> [loc]+    AST_ReturnExpr   a b     loc -> [ReturnExpr  ] <*> [a]   <*> uc0 b           <*> [loc]+    AST_WithDoc      a b     loc -> [WithDoc     ] <*> uc0 a <*> ti  b           <*> [loc]+  fromInterm obj = case obj of+    EvalObject   a     loc -> [AST_EvalObject  ] <*> fi  a  <*> [[]]           <*> [loc]+    IfThenElse   a         ->  AST_IfThenElse    <$> fi  a+    WhileLoop    a         ->  AST_WhileLoop     <$> fi  a+    RuleFuncExpr a         ->  AST_RuleFunc      <$> fi  a+    TryCatch     a b c loc -> [AST_TryCatch    ] <*> [[]]   <*> fi  a <*> mapM fi b <*> mapM fi c <*> [loc]+    ForLoop      a b c loc -> [AST_ForLoop     ] <*> nc  a  <*> nc0 b <*> fi  c <*> [loc]+    ContinueExpr a b   loc -> [AST_ContinueExpr] <*>    [a] <*> [[]]  <*> nc0 b <*> [loc]+    ReturnExpr   a b   loc -> [AST_ReturnExpr  ] <*>    [a] <*> nc0 b           <*> [loc]+    WithDoc      a b   loc -> [AST_WithDoc     ] <*> nc0 a  <*> fi  b           <*> [loc]+                         +----------------------------------------------------------------------------------------------------++data AttributeExpr+  = AttribDotNameExpr DotLabelExpr+  | AttribStringExpr  UStr        Location+  deriving (Eq, Ord, Show, Typeable)++instance NFData AttributeExpr where+  rnf (AttribDotNameExpr a  ) = deepseq a ()+  rnf (AttribStringExpr  a b) = deepseq a $! deepseq b ()++instance HasNullValue AttributeExpr where+  nullValue = AttribStringExpr nil LocationUnknown+  testNull (AttribStringExpr a _) = a==nil+  testNull _ = False++instance HasLocation AttributeExpr where+  getLocation o     = case o of+    AttribDotNameExpr   o   -> getLocation o+    AttribStringExpr  _ loc -> loc+  setLocation o loc = case o of+    AttribDotNameExpr o     -> AttribDotNameExpr (setLocation o loc)+    AttribStringExpr  o _   -> AttribStringExpr o loc+  delLocation o     = case o of+    AttribDotNameExpr o     -> AttribDotNameExpr (delLocation o)+    AttribStringExpr  o _   -> AttribStringExpr o LocationUnknown++instance PPrintable AttributeExpr where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++data AST_Attribute+  = AST_AttribDotName AST_DotLabel+  | AST_AttribString  UStr        Location+  deriving (Eq, Ord, Show, Typeable)++instance NFData AST_Attribute where+  rnf (AST_AttribDotName a  ) = deepseq a ()+  rnf (AST_AttribString  a b) = deepseq a $! deepseq b ()++instance HasNullValue AST_Attribute where+  nullValue = AST_AttribString nil LocationUnknown+  testNull (AST_AttribString a _) = a==nil+  testNull _ = False++instance HasLocation AST_Attribute where+  getLocation o     = case o of+    AST_AttribDotName   o   -> getLocation o+    AST_AttribString  _ loc -> loc+  setLocation o loc = case o of+    AST_AttribDotName o     -> AST_AttribDotName (setLocation o loc)+    AST_AttribString  o _   -> AST_AttribString o loc+  delLocation o     = case o of+    AST_AttribDotName o     -> AST_AttribDotName (delLocation o)+    AST_AttribString  o _   -> AST_AttribString o LocationUnknown++instance PPrintable AST_Attribute where+  pPrint o = case o of+    AST_AttribDotName nm    -> pPrint nm+    AST_AttribString  str _ -> pPrint str++instance HasRandGen AST_Attribute where+  randChoice = randChoiceList $+    [ AST_AttribDotName <$> randO+    , return AST_AttribString  <*> randO <*> no+    ]+  randO    = countNode $ runRandChoice+  defaultO = randO+  defaultChoice = randChoiceList [defaultO]++instance Intermediate AttributeExpr AST_Attribute where+  toInterm o   = case o of+    AST_AttribDotName a     -> AttribDotNameExpr <$> ti a+    AST_AttribString  a loc -> [AttribStringExpr a loc]+  fromInterm o = case o of+    AttribDotNameExpr a     -> AST_AttribDotName <$> fi a+    AttribStringExpr  a loc -> [AST_AttribString  a loc]++----------------------------------------------------------------------------------------------------++data TopLevelEventType+  = BeginExprType | EndExprType | ExitExprType+  deriving (Eq, Ord, Typeable, Enum)++instance Show TopLevelEventType where+  show t = case t of+    BeginExprType -> "BEGIN"+    EndExprType   -> "END"+    ExitExprType  -> "EXIT"++instance Read TopLevelEventType where+  readsPrec _ str = map (\t -> (t, "")) $ case str of+    "BEGIN" -> [BeginExprType]+    "END"   -> [EndExprType]+    "EXIT"  -> [ExitExprType]+    _       -> []++instance NFData TopLevelEventType where { rnf a = seq a () }++instance HasRandGen TopLevelEventType where+  randO = fmap toEnum (nextInt 3)+  defaultO = randO++----------------------------------------------------------------------------------------------------++-- | A 'TopLevelExpr' is a single declaration for the top-level of the program file. A Dao 'SourceCode'+-- is a list of these directives.+data TopLevelExpr o+  = RequireExpr AttributeExpr                   Location+  | ImportExpr  AttributeExpr     NamespaceExpr Location+  | TopScript   (ScriptExpr o)                  Location+  | EventExpr   TopLevelEventType (CodeBlock o) Location+  deriving (Eq, Ord, Typeable, Show, Functor)++instance NFData o => NFData (TopLevelExpr o) where+  rnf (RequireExpr a b  ) = deepseq a $! deepseq b ()+  rnf (ImportExpr  a b c) = deepseq a $! deepseq b $! deepseq c ()+  rnf (TopScript   a b  ) = deepseq a $! deepseq b ()+  rnf (EventExpr   a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue o => HasNullValue (TopLevelExpr o) where+  nullValue = TopScript nullValue LocationUnknown+  testNull (TopScript a LocationUnknown) = testNull a+  testNull _ = False++isAttribute :: TopLevelExpr o -> Bool+isAttribute toplevel = case toplevel of { RequireExpr{} -> True; ImportExpr{} -> True; _ -> False; }++instance HasLocation (TopLevelExpr o) where+  getLocation o = case o of+    RequireExpr _   o -> o+    ImportExpr  _ _ o -> o+    TopScript   _   o -> o+    EventExpr   _ _ o -> o+  setLocation o loc = case o of+    RequireExpr a    _ -> RequireExpr a loc+    ImportExpr  a b  _ -> ImportExpr  a b loc+    TopScript   a    _ -> TopScript   a   loc+    EventExpr   a b  _ -> EventExpr   a b loc+  delLocation o = case o of+    RequireExpr a    _ -> RequireExpr (delLocation a) LocationUnknown+    ImportExpr  a b  _ -> ImportExpr  (delLocation a) (delLocation b) LocationUnknown+    TopScript   a    _ -> TopScript   (delLocation a) LocationUnknown+    EventExpr   a b  _ -> EventExpr a (delLocation b) LocationUnknown++instance PPrintable o => PPrintable (TopLevelExpr o) where { pPrint = pPrintInterm }++----------------------------------------------------------------------------------------------------++-- | A 'AST_TopLevel' is a single declaration for the top-level of the program file. A Dao 'SourceCode'+-- is a list of these directives.+data AST_TopLevel o+  = AST_Require    (Com AST_Attribute)                       Location+  | AST_Import     (Com AST_Attribute)         AST_Namespace Location+  | AST_TopScript  (AST_Script o)                            Location+  | AST_Event      TopLevelEventType [Comment] (AST_CodeBlock o) Location+  | AST_TopComment [Comment]+  deriving (Eq, Ord, Typeable, Show, Functor)++instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_TopLevel o) where+  randO      = countNode $ runRandChoice+  randChoice = randChoiceList $+    [ return AST_Require   <*> randO                     <*> no+    , return AST_Import    <*> randO <*> randO           <*> no+    , return AST_TopScript <*> randO                     <*> no+    , return AST_Event     <*> randO <*> randO <*> randO <*> no+    , AST_TopComment <$> defaultO+    ]+  defaultO      = runDefaultChoice+  defaultChoice = randChoiceList $+    [ return AST_Import    <*> defaultO <*> defaultO              <*> no+    , return AST_Require   <*> defaultO                           <*> no+    , return AST_TopScript <*> defaultO                           <*> no+    , return AST_Event     <*> defaultO <*> defaultO <*> defaultO <*> no+    ]++instance Intermediate (TopLevelExpr o) (AST_TopLevel o) where+  toInterm   ast = case ast of+    AST_Require   a     loc -> [RequireExpr] <*> uc0 a           <*> [loc]+    AST_Import    a   b loc -> [ImportExpr ] <*> uc0 a  <*> ti b <*> [loc]+    AST_TopScript a     loc -> [TopScript  ] <*> ti  a           <*> [loc]+    AST_Event     a _ b loc -> [EventExpr  ] <*>    [a] <*> ti b <*> [loc]+    AST_TopComment     _loc -> mzero+  fromInterm obj = case obj of+    RequireExpr a   loc -> [AST_Require  ] <*> nc0 a                    <*> [loc]+    ImportExpr  a b loc -> [AST_Import   ] <*> nc0 a           <*> fi b <*> [loc]+    TopScript   a   loc -> [AST_TopScript] <*> fi  a                    <*> [loc]+    EventExpr   a b loc -> [AST_Event    ] <*>    [a] <*> [[]] <*> fi b <*> [loc]++isAST_Attribute :: AST_TopLevel o -> Bool+isAST_Attribute o = case o of { AST_Require{} -> True; AST_Import{} -> True; _ -> False; }++-- | Split a list of 'AST_TopLevel' items into a tripple, the "require" statements, the "import"+-- statements. This function scans the list lazily and returns as soon as an 'AST_TopLevel' item in+-- the list is found that is not one of 'AST_Require', 'AST_Import' or 'AST_TopComment'.+-- +-- Notice that this function takes an 'AST_TopLevel' and returns a list of 'AttributeExpr's, not a+-- list of 'AST_Attribute's. This is because this function is designed for assisting in evaluation+-- of the import statements of a Dao script file, specifically in order to generate a dependency+-- graph.+getRequiresAndImports :: [AST_TopLevel o] -> ([AttributeExpr], [(AttributeExpr, NamespaceExpr)])+getRequiresAndImports = loop [] [] where+  loop requires imports ox = case ox of+    AST_Require a   _ : ox -> loop (requires ++ uc0 a) imports ox+    AST_Import  a b _ : ox -> loop requires (imports ++ (pure (,) <*> uc0 a <*> toInterm b)) ox+    AST_TopComment{}  : ox -> loop requires imports ox+    _                      -> (requires, imports)++instance NFData o => NFData (AST_TopLevel o) where+  rnf (AST_Require    a b    ) = deepseq a $! deepseq b ()+  rnf (AST_Import     a b c  ) = deepseq a $! deepseq b $! deepseq c ()+  rnf (AST_TopScript  a b    ) = deepseq a $! deepseq b ()+  rnf (AST_Event      a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()+  rnf (AST_TopComment a      ) = deepseq a ()++instance HasNullValue (AST_TopLevel o) where+  nullValue = AST_TopScript nullValue LocationUnknown+  testNull (AST_TopScript a _) = testNull a+  testNull _ = False++instance HasLocation (AST_TopLevel o) where+  getLocation o = case o of+    AST_Require    _     o -> o+    AST_Import     _ _   o -> o+    AST_TopScript  _     o -> o+    AST_Event      _ _ _ o -> o+    AST_TopComment _       -> LocationUnknown+  setLocation o loc = case o of+    AST_Require    a      _ -> AST_Require    a       loc+    AST_Import     a b    _ -> AST_Import     a b     loc+    AST_TopScript  a      _ -> AST_TopScript  a       loc+    AST_Event      a b c  _ -> AST_Event      a b c   loc+    AST_TopComment a        -> AST_TopComment a+  delLocation o = case o of+    AST_Require    a      _ -> AST_Require    (delLocation a) LocationUnknown+    AST_Import     a b    _ -> AST_Import     (delLocation a) (delLocation b) LocationUnknown+    AST_TopScript  a      _ -> AST_TopScript  (delLocation a) LocationUnknown+    AST_Event      a b c  _ -> AST_Event      a b (delLocation c) LocationUnknown+    AST_TopComment a        -> AST_TopComment a  ++instance PPrintable o => PPrintable (AST_TopLevel o) where+  pPrint o = case o of+    AST_Require   a      _ -> pWrapIndent [pString "require ", pPrint a, pString ";"]+    AST_Import    a b    _ -> pWrapIndent [pString "import  ", pPrint a, pPrint b, pString ";"]+    AST_TopScript a      _ -> pPrint a+    AST_Event     a b c  _ -> pClosure (pShow a >> mapM_ pPrint b) " { " " }" (map pPrint (getAST_CodeBlock c))+    AST_TopComment a       -> mapM_ (\a -> pPrint a >> pNewLine) a++----------------------------------------------------------------------------------------------------++-- | A program is just a list of 'TopLevelExpr's. It serves as the 'Intermediate'+-- representation of a 'AST_SourceCode'.+newtype Program o = Program { topLevelExprs :: [TopLevelExpr o] } deriving (Eq, Ord, Typeable)++instance Show o => Show (Program o) where { show (Program o) = unlines (map show o) }++instance HasNullValue (Program o) where+  nullValue = Program []+  testNull (Program p) = null p++instance HasLocation (Program o) where+  getLocation o = case topLevelExprs o of+    [] -> LocationUnknown+    [o] -> getLocation o+    o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox))+  setLocation o _ = o+  delLocation o = Program (fmap delLocation (topLevelExprs o))++----------------------------------------------------------------------------------------------------++-- | A 'SourceCode' is the structure loaded from source code. An 'ExecUnit' object is constructed from+-- 'SourceCode'.+data AST_SourceCode o+  = AST_SourceCode+    { sourceModified :: Int+    , sourceFullPath :: UStr+      -- ^ the URL (full file path) from where this source code was received.+    , directives     :: [AST_TopLevel o]+    }+  deriving (Eq, Ord, Typeable)++instance NFData o => NFData (AST_SourceCode o) where+  rnf (AST_SourceCode a b c) = deepseq a $! deepseq b $! deepseq c ()++instance HasNullValue (AST_SourceCode o) where+  nullValue = (AST_SourceCode 0 nil [])+  testNull (AST_SourceCode 0 a []) | a==nil = True+  testNull _ = False++instance PPrintable o => PPrintable (AST_SourceCode o) where+  pPrint sc = do+    let (attrs, dirs) = span isAST_Attribute (directives sc)+    mapM_ pPrint attrs+    pForceNewLine+    mapM_ (\dir -> pPrint dir >> pForceNewLine) dirs++instance Intermediate (Program o) (AST_SourceCode o) where+  toInterm   ast = [Program $ directives ast >>= toInterm]+  fromInterm obj = return $+    AST_SourceCode+    { sourceModified = 0+    , sourceFullPath = nil+    , directives     = topLevelExprs obj >>= fromInterm+    }+
+ src/Dao/Interpreter/Parser.hs view
@@ -0,0 +1,831 @@+-- "src/Dao/Interpreter/Parser.hs" makes use of "Dao.Parser" to parse+-- parse 'Dao.Interpreter.AST' expressions.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE MultiParamTypeClasses #-}++module Dao.Interpreter.Parser where++import           Dao.String+import           Dao.Token+import           Dao.PPrint+import           Dao.Interpreter     hiding (opt)+import           Dao.Interpreter.AST+import           Dao.Interpreter.Tokenizer+import           Dao.Predicate+import           Dao.Parser++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Error+import           Control.Monad.State++import           Data.Monoid+import           Data.Maybe+import           Data.List+import           Data.Char+import           Data.Ratio+import           Data.Complex++maxYears :: Integer+maxYears = 99999++type DaoParser    a = Parser     DaoParState DaoTT a+type DaoTableItem a = TableItem  DaoTT (DaoParser a)+type DaoPTable    a = PTable     DaoTT (DaoParser a)+type DaoParseErr    = ParseError DaoParState DaoTT++----------------------------------------------------------------------------------------------------++data DaoParState+  = DaoParState+    { bufferedComments :: Maybe [Comment]+    , nonHaltingErrors :: [DaoParseErr]+    , internalState    :: Maybe (TokStreamState DaoParState DaoTT)+    }++instance Monoid DaoParState where+  mappend a b =+     b{ bufferedComments = bufferedComments a >>= \a -> bufferedComments b >>= \b -> return (a++b)+      , nonHaltingErrors = nonHaltingErrors a ++ nonHaltingErrors b+      , internalState    = internalState b+      }+  mempty =+    DaoParState+    { bufferedComments = Nothing+    , nonHaltingErrors = []+    , internalState = Nothing+    }++instance PPrintable DaoParState where { pPrint _ = return () }++setCommentBuffer :: [Comment] -> DaoParser ()+setCommentBuffer coms = modify $ \st ->+  st{ bufferedComments = (if null coms then mzero else return coms) <> bufferedComments st }++failLater :: String -> Location -> DaoParser ()+failLater msg loc = catchError (fail msg) $ \err -> modify $ \st ->+  st{nonHaltingErrors =+      nonHaltingErrors st ++ [err{parseStateAtErr=Nothing, parseErrLoc=loc}]}++----------------------------------------------------------------------------------------------------++spaceComPTab :: DaoPTable [Comment]+spaceComPTab = table $+  [ tableItem SPACE      (return . const [] . as0)+  , tableItem INLINECOM  (\c -> return [InlineComment  $ asUStr c])+  , tableItem ENDLINECOM (\c -> return [EndlineComment $ asUStr c])+  ]++-- | Parses an arbitrary number of space and comment tokens, comments are returned. Backtracks if+-- there are no comments.+space :: DaoParser [Comment]+space = do+  st <- Control.Monad.State.get+  case bufferedComments st of+    Just coms -> put (st{bufferedComments=mempty}) >> return coms+    Nothing   -> fmap concat $ many (joinEvalPTable spaceComPTab)++-- The 'space' parser backtracks if there are no spaces, which is important to prevent infinite+-- recursion in some situations. The 'optSpace' evalautes 'space' but returns an empty list of+-- 'space' backtracks, so 'optSpace' never backtracks.+optSpace :: DaoParser [Comment]+optSpace = mplus space (return [])++-- | Evaluates a 'DaoParser' within a cluster of optional spaces and comments, returning the result+-- of the parser wrapped in a 'Dao.Interpreter.Com' constructor. If the given 'DaoParser' backtracks, the+-- comments that were parsed before the 'DaoParser' was evaluated are buffered so a second call two+-- successive calls to this function return immediately. For example in an expression like:+-- > 'Control.Monad.msum' ['commented' p1, 'commented' p2, ... , 'commented' pN]+-- The spaces and comments occurring before the parsers @p1@, @p2@, ... , @pN@ are only being parsed+-- once, no matter how many parser are tried.+commented :: DaoParser a -> DaoParser (Com a)+commented parser = do+  before <- mplus space (return [])+  flip mplus (setCommentBuffer before >> mzero) $ do+    result <- parser+    after  <- mplus space (return [])+    return (com before result after)++-- Take comments of the stream, but do not return them, instead just buffer them. This is a good way+-- to do a look-ahead past comments without deleting comments. If the next parser evaluated+-- immediately after this one is 'commented', the comments buffered by this function will be+-- returned with the object parsed by 'commented'. This is necessary in parse tables where the table+-- needs an operator token to select the next parser in the table, but the returned operator token+-- must be preceeded by possible comments.+bufferComments :: DaoParser ()+bufferComments = mplus (space >>= setCommentBuffer) (return ())++----------------------------------------------------------------------------------------------------++rationalFromString :: Int -> Rational -> String -> Maybe Rational+rationalFromString maxValue base str =+  if b<1 then fmap (b*) (fol (reverse str)) else fol str where+    b = abs base+    maxVal = abs maxValue+    fol = foldl shiftAdd (return 0)+    shiftAdd result nextChar = do+      x <- result+      y <- convertChar nextChar+      if y>=maxVal then mzero else return (x*b + (toInteger y % 1))+    convertChar a = case a of+      a | isDigit a -> return (ord a - ord '0')+      a | isLower a -> return (ord a - ord 'a' + 10)+      a | isUpper a -> return (ord a - ord 'A' + 10)+      _             -> mzero++numberFromStrs :: Int -> String -> Maybe String -> Maybe String -> Maybe String -> DaoParser Object+numberFromStrs base int maybFrac maybPlusMinusExp maybTyp = do+  let frac         = maybe "" id (maybFrac >>= stripPrefix ".")+      strprfx      = foldl (\f s t -> f (maybe t id (stripPrefix s t))) id . words+      plusMinusExp = fromMaybe "" (fmap (strprfx ".e .E e E") maybPlusMinusExp)+      typ          = fromMaybe "" maybTyp+      (exp, hasMinusSign) = case plusMinusExp of+        ""             -> ("" , False)+        p:exp | p=='+' -> (exp, False)+              | p=='-' -> (exp, True )+        exp            -> (exp, False)+      b = toInteger base % 1+      rational = do+        x   <- rationalFromString base b int+        y   <- rationalFromString base (recip b) frac+        exp <- fmap (round . abs) (rationalFromString base b exp) :: Maybe Integer+        let ibase  = if hasMinusSign then recip b else b+            result = (x+y)*(ibase^^exp)+        return (round result % 1 == result, result)+  (_r_is_an_integer, r) <- case rational of+    Nothing -> fail ("incorrect digits used to form a base-"++show base++" number")+    Just  r -> return r+  case typ of+    "U" -> return $ OWord (round r)+    "I" -> return $ OInt  (round r)+    "L" -> return $ OLong (round r)+    "R" -> return $ ORatio r+    "F" -> return $ OFloat (fromRational r)+    "f" -> return $ OFloat (fromRational r)+    "i" -> return $ OComplex $ Complex $ 0 :+ fromRational r+    "j" -> return $ OComplex $ Complex $ 0 :+ fromRational r+    "s" -> return $ ORelTime (fromRational r)+    ""  ->+      return (OInt (round r))+--    if r_is_an_integer && null frac+--      then+--        let i = round r+--        in  if fromIntegral (minBound::T_int) <= i && i <= fromIntegral (maxBound::T_int)+--              then  return $ OInt $ fromIntegral i+--              else  return $ OLong i+--      else return (ORatio r)+    typ -> fail ("unknown numeric type "++show typ)++----------------------------------------------------------------------------------------------------++-- | Compute diff times from strings representing days, hours, minutes, and seconds. The seconds+-- value may have a decimal point.+diffTimeFromStrs :: String -> DaoParser T_diffTime+diffTimeFromStrs time = do+  let [hours,minutes,secMils] = split [] time+      (seconds, dot_mils) = break (=='.') secMils+      miliseconds = dropWhile (=='.') dot_mils+  hours   <- check "hours"             24   hours+  minutes <- check "minutes"           60   minutes+  let sec =  check "seconds"           60+  seconds <-+    if null miliseconds+      then  sec seconds+      else  do+        seconds <- sec seconds+        return (seconds + rint miliseconds % (10 ^ length miliseconds))+  return $ fromRational (60*60*hours + 60*minutes + seconds)+  where+    split buf str       = case break (==':') str of+      (t, ""     ) -> reverse $ take 3 $ (t:buf) ++ repeat ""+      (t, ':':str) -> split (t:buf) str+      (_, _      ) -> error "unexpected character while parsing time-literal expression"+    rint str            = if null str then 0 else (read str :: Integer)+    integerToRational s = s % 1 :: Rational+    check :: String -> Integer -> String -> DaoParser Rational+    check typ maxVal  s = do+      let i    = rint s+          zero = return (0%1)+          ok   = return (integerToRational i)+          err  = fail $ concat ["time value expression with ", s, " ", typ, " is invalid"]+      if null s then zero else if i<maxVal then ok else err++----------------------------------------------------------------------------------------------------++numberPTabItems :: [DaoTableItem (AST_Literal Object)]+numberPTabItems = +  [ base 16 BASE16+  , base  2 BASE2+  , tableItem BASE10    $ \tok -> do+      frac <- optional (token DOTBASE10 id)+      exp  <- optional (token EXPONENT  id)+      typ  <- optional (token NUMTYPE   id)+      done tok 10 (asString tok) (mstr frac) (mstr exp) (mstr typ) (return (asLocation tok) <> mloc frac <> mloc exp <> mloc typ)+  , tableItem DOTBASE10 $ \tok -> do+      exp  <- optional (token EXPONENT id)+      typ  <- optional (token NUMTYPE  id)+      done tok 10 "" (Just (asString tok)) (mstr exp) (mstr typ) (return (asLocation tok) <> mloc exp <> mloc typ)+  , tableItemBy "date" $ \startTok ->+      expect "date/time value expression after \"date\" statement" $ do+        token SPACE as0+        date <- token DATE id+        let optsp tok = optional $+              token SPACE id >>= \s -> mplus (token tok id) (unshift s >> mzero)+        time <- optsp TIME+        zone <- optsp LABEL+        let loc = asLocation startTok <>+                maybe LocationUnknown id (fmap asLocation time <> fmap asLocation zone)+            astr = (' ':) . asString+            timeAndZone = maybe " 00:00:00" astr time ++ maybe "" astr zone+        case readsPrec 0 (asString date ++ timeAndZone) of+          [(o, "")] -> return (AST_Literal (OAbsTime o) loc)+          _         -> fail "invalid UTC-time expression"+  , tableItemBy "time" $ \startTok -> expect "UTC-time value after \"time\" statement" $ do+      token SPACE as0+      tok  <- token TIME id+      time <- diffTimeFromStrs (asString tok)+      return (AST_Literal (ORelTime time) (asLocation startTok <> asLocation tok))+  ]+  where+    mloc = fmap asLocation+    mstr = fmap asString+    base b t = tableItem t $ \tok -> do+      typ <- optional (token NUMTYPE id)+      done tok b (drop 2 (asString tok)) Nothing Nothing (mstr typ) (return (asLocation tok) <> mloc typ)+    done tok base int frac exp typ loc = do+      num <- numberFromStrs base int frac exp typ+      let endLoc = asLocation tok+      return (AST_Literal num (maybe endLoc id loc))++numberPTab :: DaoPTable (AST_Literal Object)+numberPTab = table numberPTabItems++-- | Parsing numerical literals+number :: DaoParser (AST_Literal Object)+number = joinEvalPTable numberPTab++singletonPTab :: DaoPTable (AST_Literal Object)+singletonPTab = table singletonPTabItems++parenPTabItem :: DaoTableItem (AST_Paren Object)+parenPTabItem = tableItemBy "(" $ \tok -> do+  o <- commented assignment+  expect "closing parentheses" $ do+    endloc <- tokenBy ")" asLocation+    return (AST_Paren o (asLocation tok <> endloc))++paren :: DaoParser (AST_Paren Object)+paren = joinEvalPTableItem parenPTabItem++metaEvalPTabItem :: DaoTableItem (AST_Object Object)+metaEvalPTabItem = tableItemBy "${" $ \startTok -> expect "object expression after open ${ meta-eval brace" $ do+  scrp <- fmap (AST_CodeBlock . concat) (many script)+  expect "closing } for meta-eval brace" $ do+    endLoc <- tokenBy "}" asLocation+    return (AST_MetaEval scrp (asLocation startTok <> endLoc))++singletonPTabItems :: [DaoTableItem (AST_Literal Object)]+singletonPTabItems = numberPTabItems +++  [ tableItem STRINGLIT (literal $ OString . read     . asString)+  , tableItem CHARLIT   (literal $ OChar   . read     . asString)+  , trueFalse "null" ONull, trueFalse "false" ONull, trueFalse "true" OTrue+  , reserved "operator", reserved "public", reserved "private"+  ]+  where+    literal constr tok = return (AST_Literal (constr tok) (asLocation tok))+    trueFalse lbl obj = tableItemBy lbl $ \tok -> return (AST_Literal obj (asLocation tok))+    reserved key = tableItemBy key $ fail $+      "keyword "++show key++" is reserved for future use, not implemented in this version of Dao"++-- Objects that are parsed as a single value, which includes all literal expressions and equtions in+-- parentheses.+singleton :: DaoParser (AST_Literal Object)+singleton = joinEvalPTable singletonPTab++-- Returns an AST_ObjList, which is a constructor that contains leading whitespace/comments. However+-- this function is a 'DaoTableItem' parser, which means the first token parsed must be the opening+-- bracket. In order to correctly parse the leading whitespace/comments while also correctly+-- identifying the opening bracket token, it is expected that you have called 'bufferComments'+-- immediately before this function is evaluated.+commaSepdObjList :: String -> String -> String -> DaoTableItem (AST_ObjList Object)+commaSepdObjList msg open close = tableItemBy open $ \startTok -> do+  let startLoc = asLocation startTok+  coms <- optSpace -- the comments must have been buffered by this point, otherwise the parser behaves strangely.+  (lst, endLoc) <- commaSepd ("arguments to "++msg) close (return . com [] nullValue) assignment id+  return (AST_ObjList coms lst (startLoc<>endLoc))++ruleFuncPTab :: DaoPTable (AST_RuleFunc Object)+ruleFuncPTab = table $+  [ tableItemBy "rule" $ \startTok ->+      expect "list of strings after \"rule\" statement" $ do+        lst <- commented $ joinEvalPTable $ table $+          [ tableItem STRINGLIT $ \str -> return $ AST_RuleString (Com $ read $ uchars $ asUStr str) (asLocation str)+          , fmap (\ (AST_ObjList coms lst loc) ->+                  if null lst then AST_NullRules coms loc else AST_RuleHeader lst loc+              ) <$> commaSepdObjList "rule header" "(" ")"+          ]+        expect "bracketed expression after rule header" $ do+          (scrpt, endLoc) <- bracketed ("script expression for \"rule\" statement")+          return $ AST_Rule lst scrpt (asLocation startTok <> endLoc)+  , lambdaFunc "func", lambdaFunc "function"+  ]+  where+    lambdaFunc lbl = tableItemBy lbl $ \startTok ->+      expect ("parameters and bracketed script after \""++lbl++"\" statement") $ do+        constr <- mplus (pure AST_Func <*> optSpace <*> token LABEL asName) (return AST_Lambda)+        params <- commented paramList+        (scrpt, endLoc) <- bracketed ("script expression after \""++lbl++"\" statement")+        return $ constr params scrpt (asLocation startTok <> endLoc)++ruleFunc :: DaoParser (AST_RuleFunc Object)+ruleFunc = joinEvalPTable ruleFuncPTab++-- Objects that are parsed as a single value but which are constructed from other object+-- expressions. This table excludes 'singletonPTab'.+containerPTab :: DaoPTable (AST_Object Object)+containerPTab = table [metaEvalPTabItem]++-- None of the functions related to parameters and type checking parse with tables because there is+-- simply no need for it according to the Dao language syntax.+typeCheckParser :: a -> DaoParser (AST_TyChk a Object)+typeCheckParser a = flip mplus (return (AST_NotChecked a)) $ do+  com1 <- commented (tokenBy "::" id)+  let startLoc = asLocation (unComment com1)+  expect "type expression after colon operator" $ arithmetic >>= \obj -> return $+    AST_Checked a (fmap as0 com1) obj (startLoc <> getLocation obj)++typeCheckedName :: DaoParser (AST_TyChk Name Object)+typeCheckedName = token LABEL id >>= \tok ->+  fmap (\tychk -> setLocation tychk (asLocation tok <> getLocation tychk)) $+    typeCheckParser (asName tok)++parameter :: DaoParser (AST_Param Object)+parameter = msum $+  [ do  startLoc <- tokenBy "$" asLocation+        coms     <- optional space+        item     <- typeCheckedName+        return $ AST_Param coms item (startLoc <> getLocation item)+  , typeCheckedName >>= \nm -> return $ AST_Param Nothing nm (getLocation nm)+  ]++paramList :: DaoParser (AST_ParamList Object)+paramList = do+  startLoc   <- tokenBy "(" asLocation+  (lst, loc) <- commaSepd "parameter value" ")" (return . com [] AST_NoParams) parameter id+  lst        <- typeCheckParser lst+  return (AST_ParamList lst (startLoc <> loc))++singletonOrContainerPTab :: DaoPTable (AST_Object Object)+singletonOrContainerPTab = fmap (fmap AST_ObjLiteral) singletonPTab <> containerPTab++singletonOrContainer :: DaoParser (AST_Object Object)+singletonOrContainer = joinEvalPTable singletonOrContainerPTab++----------------------------------------------------------------------------------------------------++commaSepd :: (UStrType str, UStrType errmsg) =>+  errmsg -> str -> ([Comment] -> b) -> DaoParser a -> ([Com a] -> b) -> DaoParser (b, Location)+commaSepd errMsg close voidVal parser constr =+  msum [commented parser >>= loop . (:[]), parseComEmpty, parseClose [] [], err] where+    parseComEmpty = space >>= parseClose []+    parseClose stack c = do+      loc <- tokenBy close asLocation+      return (if null stack && null c then constr stack else if null c then constr stack else voidVal c, loc)+    loop stack = flip mplus (parseClose stack []) $ do+      token COMMA as0+      o <- commented (expect errMsg parser)+      loop (stack++[o])+    err = fail $ "unknown token while parsing list of items for "++uchars errMsg++-- More than one parser has need of 'commaSepd' as a parameter to 'commented', but passing+-- 'commaSped' to 'commented' will return a value of type:+-- > 'Dao.Interpreter.Com' (['Dao.Interpreter.Com'], 'Dao.Parser.Location')+-- which is not useful for constructors of the abstract syntax tree. This function takes the+-- comments around the pair and maps the first item of the pair to the comments, returning an+-- uncommented pair.+commentedInPair :: DaoParser (a, Location) -> DaoParser (Com a, Location)+commentedInPair parser = do+  comntd <- commented parser+  let (a, loc) = unComment comntd+  return (fmap (const a) comntd, loc)++-- You MUST have evaluated 'bufferComments' before evaluating any of the parsers in this table.+-- 'refSuffix' does this.+refSuffixPTabItems :: [DaoTableItem (AST_RefSuffix Object)]+refSuffixPTabItems =+  [ tableItemBy "." $ \tok -> do+      comBefore <- optSpace -- get comments before dot that were buffered by 'bufferComments'+      comAfter  <- optSpace -- get comments after the dot+      expect "valid identifier after dot token" $ do+        name      <- token LABEL id+        suf       <- refSuffix+        let loc = asLocation tok <> getLocation suf+        return $ AST_DotRef (com comBefore () comAfter) (asName name) suf loc+  , p "subscript expression"     "[" "]" AST_Subscript+  , p "function call expression" "(" ")" AST_FuncCall+  ]+  where+    p msg open close constr = bindPTableItem (commaSepdObjList msg open close) $ \olst ->+      refSuffix >>= \suf -> return $ constr olst suf++refSuffixPTab :: DaoPTable (AST_RefSuffix Object)+refSuffixPTab = table refSuffixPTabItems++refSuffix :: DaoParser (AST_RefSuffix Object)+refSuffix = bufferComments >> joinEvalPTable refSuffixPTab <|> return AST_RefNull++referencePTabItems :: [DaoTableItem (AST_Reference Object)]+referencePTabItems =+  [ p "local" LOCAL, p "const" CONST, p "static" STATIC, p "global" GLOBAL, p "." GLODOT+  , tableItem LABEL $ \name -> do+      suf <- refSuffix+      return $ AST_Reference UNQUAL [] (asName name) suf (asLocation name)+  , bindPTableItem parenPTabItem $ \o -> refSuffix >>= \suf -> return $+      AST_RefObject o suf (getLocation o <> getLocation suf)+  ]+  where+    p opstr op = tableItemBy opstr $ \tok ->+      expect ("reference expression after "++show opstr++" qualifier") $ do+        coms <- optSpace+        name <- token LABEL id+        suf  <- refSuffix+        return $ AST_Reference op coms (asName name) suf (asLocation tok <> asLocation name)++referencePTab :: DaoPTable (AST_Reference Object)+referencePTab = table referencePTabItems++referenceParser :: DaoParser (AST_Reference Object)+referenceParser = joinEvalPTable referencePTab++refPrefixPTabItems :: [DaoTableItem (AST_RefPrefix Object)]+refPrefixPTabItems = [p "$" REF, p "@" DEREF] where+  p opstr op = tableItemBy opstr $ \tok ->+    expect ("reference expression after"++show opstr++" token") $ do+      coms <- optSpace+      ref  <- refPrefixParser+      return $ AST_RefPrefix op coms ref (asLocation tok <> getLocation ref)++refPrefixPTab :: DaoPTable (AST_RefPrefix Object)+refPrefixPTab = table refPrefixPTabItems <> (fmap (\o -> AST_PlainRef o) <$> referencePTab)++refPrefixParser :: DaoParser (AST_RefPrefix Object)+refPrefixParser = joinEvalPTable refPrefixPTab++initPTab :: DaoPTable (AST_Object Object)+initPTab = bindPTable refPrefixPTab $ \o -> let single = return (AST_ObjSingle o) in case o of+  AST_PlainRef ref -> case refToDotLabelAST ref of+    Just (ref, inits) -> (bufferComments>>) $ flip mplus single $ do+      olst <- joinEvalPTableItem $ commaSepdObjList "initializing expression" "{" "}"+      coms <- optSpace+      return $ AST_Init ref (AST_OptObjList coms inits) olst (getLocation o <> getLocation olst)+    Nothing           -> single+  AST_RefPrefix{}  -> single++structPTabItems :: [DaoTableItem (AST_Object Object)]+structPTabItems = (:[]) $ tableItem HASHLABEL $ \nameTok -> do+  bufferComments+  let name = fromUStr $ ustr $ tail $ asString nameTok+  let startLoc = asLocation nameTok+  flip mplus (return $ AST_Struct name nullValue startLoc) $ do+    objList <- joinEvalPTableItem $ commaSepdObjList "data structure initializer" "{" "}"+    let objListLoc = getLocation objList+    return $ AST_Struct name (AST_OptObjList [] (Just objList)) (startLoc<>objListLoc)++structPTab :: DaoPTable (AST_Object Object)+structPTab = table structPTabItems++arithPrefixPTab :: DaoPTable (AST_Object Object)+arithPrefixPTab = table $ (logicalNOT:) $ flip fmap ["~", "-", "+"] $ \pfxOp ->+  tableItemBy pfxOp $ \tok -> optSpace >>= \coms -> object >>= \o ->+    return (AST_ArithPfx (fromUStr (tokTypeToUStr (asTokType tok))) coms o (asLocation tok))+  where+    logicalNOT = tableItemBy "!" $ \op -> do+      coms <- optSpace+      o <- object+      return $ AST_ArithPfx (fromUStr $ tokTypeToUStr $ asTokType op) coms o (asLocation op)++-- This table extends the 'funcCallArraySubPTab' table with the 'arithPrefixPTab' table. The+-- 'containerPTab' is also included at this level. It is the most complicated (and therefore lowest+-- prescedence) object expression that can be formed without making use of infix operators.+objectPTab :: DaoPTable (AST_Object Object)+objectPTab = mconcat [singletonOrContainerPTab, arithPrefixPTab, structPTab, initPTab]++-- Evaluates 'objectPTab' to a 'DaoParser'.+object :: DaoParser (AST_Object Object)+object = joinEvalPTable objectPTab++-- A constructor that basically re-arranges the arguments to the 'Dao.Interpreter.AST.AST_Eval'+-- constructor such that this function can be used as an argument to 'Dao.Parser.sinpleInfixed'+-- or 'Dao.Parser.newOpTableParser'.+arithConstr :: AST_Arith Object -> (Location, Com InfixOp) -> AST_Arith Object -> DaoParser (AST_Arith Object)+arithConstr left (loc, op) right = return $ AST_Arith left op right loc++-- Parses a sequence of 'object' expressions interspersed with arithmetic infix opreators.+-- All infixed logical operators are included, assignment operators are not. The only prefix logical+-- operator. Logical NOT @(!)@ is not parsed here but in the 'arithmetic' function.+arithOpTable :: OpTableParser DaoParState DaoTT (Location, Com InfixOp) (AST_Arith Object)+arithOpTable =+  newOpTableParser "arithmetic expression" False+    (\tok -> do+        op <- commented (shift (fromUStr . tokTypeToUStr . asTokType))+        return (asLocation tok, op)+    )+    (object >>= \o -> bufferComments >> return (AST_Object o))+    arithConstr+    ( opRight ["->"] arithConstr+    : opRight ["**"] arithConstr+    : fmap (\ops -> opLeft (words ops) arithConstr)+        ["* / %", "+ -", "<< >>", "&", "^", "|", "< <= >= >", "== !="]+    ++ [opRight ["&&"] arithConstr, opRight [ "||"] arithConstr]+    )++arithmeticPTab :: DaoPTable (AST_Arith Object)+arithmeticPTab = bindPTable objectPTab $ \o ->+  evalOpTableParserWithInit (bufferComments >> return (AST_Object o)) arithOpTable++-- Evalautes the 'arithOpTable' to a 'DaoParser'.+arithmetic :: DaoParser (AST_Arith Object)+arithmetic = joinEvalPTable arithmeticPTab++objTestPTab :: DaoPTable (AST_ObjTest Object)+objTestPTab = mappend (fmap AST_ObjRuleFunc <$> ruleFuncPTab) $ bindPTable arithmeticPTab $ \a -> do+  bufferComments+  flip mplus (return $ AST_ObjArith a) $ do+    qmark <- commented (tokenBy "?" as0)+    expect "arithmetic expression after (?) operator" $ do+      b <- arithmetic+      expect "(:) operator and arithmetic expression after (?) operator" $ do+        coln <- commented (tokenBy ":" as0)+        expect "arithmetic expression after (:) operator" $ do+          c <- arithmetic+          return $ AST_ObjTest a qmark b coln c (getLocation a <> getLocation c)++objTest :: DaoParser (AST_ObjTest Object)+objTest = joinEvalPTable objTestPTab++assignmentWithInit :: DaoParser (AST_Assign Object) -> DaoParser (AST_Assign Object)+assignmentWithInit init = +  simpleInfixedWithInit "object expression for assignment operator" rightAssoc+    (\left (loc, op) right -> return $ case left of+        AST_Eval left -> AST_Assign left op right loc+        left          -> left+    )+    (bufferComments >> init)+    (fmap AST_Eval objTest)+    (pure (,) <*> look1 asLocation <*> commented (joinEvalPTable opTab))+  where+    opTab :: DaoPTable UpdateOp+    opTab = table $+      fmap (flip tableItemBy (return . fromUStr . tokTypeToUStr . asTokType)) (words allUpdateOpStrs)++assignmentPTab :: DaoPTable (AST_Assign Object)+assignmentPTab = bindPTable objTestPTab (assignmentWithInit . return . AST_Eval)++-- | Evaluates a sequence arithmetic expressions interspersed with assignment operators.+assignment :: DaoParser (AST_Assign Object)+assignment = joinEvalPTable assignmentPTab++----------------------------------------------------------------------------------------------------++bracketed :: String -> DaoParser (AST_CodeBlock Object, Location)+bracketed msg = do+  startLoc <- tokenBy "{" asLocation+  scrps    <- concat <$> (many script <|> return [])+  expect ("curly-bracket to close "++msg++" statement") $ do+    _ <- look1 id+    endLoc <- tokenBy "}" asLocation+    return (AST_CodeBlock scrps, startLoc<>endLoc)++script :: DaoParser [AST_Script Object]+script = joinEvalPTable scriptPTab++ifWhilePTabItem :: String -> (AST_If Object -> a) -> DaoTableItem a+ifWhilePTabItem keyword constr = tableItemBy keyword $ \tok -> do+  o <- commented paren+  (thn, loc) <- bracketed keyword+  return $ constr $ AST_If o thn (asLocation tok <> loc)++whilePTabItem :: DaoTableItem (AST_While Object)+whilePTabItem = ifWhilePTabItem "while" AST_While++ifPTabItem :: DaoTableItem (AST_If Object)+ifPTabItem = ifWhilePTabItem "if" id++ifStatement :: DaoParser (AST_If Object)+ifStatement = joinEvalPTableItem ifPTabItem++lastElseParser :: DaoParser (AST_LastElse Object)+lastElseParser = do+  comTok <- commented $ tokenBy "else" asLocation+  (els, endLoc) <- bracketed "else statement"+  return $ AST_LastElse (fmap (const ()) comTok) els (unComment comTok <> endLoc)++catchExprParser :: DaoParser (AST_Catch Object)+catchExprParser = do+  bufferComments+  startLoc <- tokenBy "catch" asLocation+  expect "parameter variable name/type after \"catch\" statement" $ do+    coms  <- optSpace+    param <- commented parameter+    (scrpt, endLoc) <- bracketed "\"catch\" statement"+    return $ AST_Catch coms param scrpt (startLoc <> endLoc)++ifElsePTabItem :: DaoTableItem (AST_IfElse Object)+ifElsePTabItem = bindPTableItem ifPTabItem (loop []) where+  loop elsx ifExpr = msum $+    [ do  com1   <- optSpace+          elsLoc <- tokenBy "else" asLocation+          expect "bracketed expression, or another \"if\" expression after \"else\" statement" $ do+            com2 <- optSpace+            msum $+              [ do  nextIf <- ifStatement+                    loop (elsx++[AST_Else (com com1 () com2) nextIf (elsLoc <> getLocation nextIf)]+                          ) ifExpr+              , do  (els, endLoc) <- bracketed "else statement"+                    return $+                      AST_IfElse ifExpr elsx+                        (Just $ AST_LastElse (com com1 () com2) els (getLocation els <> endLoc))+                        (getLocation ifExpr <> endLoc)+              ]+    , return (AST_IfElse ifExpr elsx Nothing (getLocation ifExpr))+    ]++scriptPTab :: DaoPTable [AST_Script Object]+scriptPTab = comments <> objExpr <> table exprs where+  -- Object expressions should end with a semi-colon. An exception to this rule is made for rule and+  -- function constant expressions.+  objExpr = bindPTable assignmentPTab $ \o -> case o of+    AST_Eval (AST_ObjRuleFunc o) ->+      flip mplus (return [AST_RuleFunc o]) $ do+        coms <- optSpace+        loc  <- mappend (getLocation o) <$> tokenBy ";" asLocation+        return [AST_EvalObject (AST_Eval $ AST_ObjRuleFunc o) coms loc]+    o -> do+      coms <- optSpace+      expect "semicolon after object expression" $ do+        endLoc <- tokenBy ";" asLocation+        return [AST_EvalObject o coms (getLocation o <> endLoc)]+  comments = bindPTable spaceComPTab $ \c1 -> optSpace >>= \c2 ->+    let coms = c1++c2 in if null coms then return [] else return [AST_Comment coms]+  exprs =+    [ fmap (fmap (return . AST_WhileLoop)) whilePTabItem +    , fmap (fmap (return . AST_IfThenElse)) ifElsePTabItem+    , returnExpr "return"   True+    , returnExpr "throw"    False+    , continExpr "continue" True+    , continExpr "break"    False+    , tableItemBy "try" $ \tok -> expect "bracketed script after \"try\" statement" $ do+        coms <- optSpace+        (try, endLoc) <- bracketed "\"try\" statement"+        elsExprs   <- many lastElseParser+        catchExprs <- many catchExprParser+        let finalLoc :: forall a . HasLocation a => [a] -> Location+            finalLoc = foldl (\_ a -> getLocation a) endLoc+        let loc = asLocation tok <> finalLoc elsExprs <> finalLoc catchExprs+        return [AST_TryCatch coms try elsExprs catchExprs loc]+    , tableItemBy "for"   $ \tok -> expect "iterator label after \"for statement\"" $ do+        comName <- commented (token LABEL asName)+        expect "\"in\" statement after \"for\" statement" $ do+          tokenBy "in" as0+          expect "object expression over which to iterate of \"for-in\" statement" $ do+            o <- commented refPrefixParser+            expect "bracketed script after \"for-in\" statement" $ do+              (for, endLoc) <- bracketed "\"for\" statement"+              return [AST_ForLoop comName o for (asLocation tok <> endLoc)]+    , tableItemBy "with"  $ \tok -> expect "reference expression after \"with\" statement" $ do+        o <- commented paren+        expect "bracketed script after \"with\" statement" $ do+          (with, endLoc) <- bracketed "\"with\" statement"+          return [AST_WithDoc o with (asLocation tok <> endLoc)]+    ]+  semicolon = tokenBy ";" asLocation+  returnExpr key isReturn = tableItemBy key $ \tok -> do+    o <- commented (assignment <|> return nullValue)+    expect ("semicolon after \""++key++"\" statement") $ do+      endLoc <- semicolon+      return [AST_ReturnExpr isReturn o (asLocation tok <> endLoc)]+  continExpr key isContin = tableItemBy key $ \tok -> do+    let startLoc = asLocation tok+    let msg e = concat [e, " after \"", key, "-if\" statement"]+    coms <- optSpace+    msum $+      [do endLoc <- semicolon+          return [AST_ContinueExpr isContin coms (Com nullValue) (startLoc<>endLoc)]+      ,do tokenBy "if" as0+          expect (msg "conditional expression") $ do+            o <- commented assignment+            expect (msg "semicolon") $ do+              endLoc <- semicolon+              return [AST_ContinueExpr isContin coms o (startLoc<>endLoc)]+      , fail (msg "expecting optional object expression followed by a semicolon")+      ]++----------------------------------------------------------------------------------------------------++dotName :: DaoParser AST_DotName+dotName = return AST_DotName <*> commented (tokenBy "." as0) <*> token LABEL asName++dotLabelTableItem :: DaoTableItem AST_DotLabel+dotLabelTableItem = tableItem LABEL $ \tok ->+  return (AST_DotLabel (asName tok)) <*> many dotName <*> pure (asLocation tok)++attributePTab :: DaoPTable AST_Attribute+attributePTab = table $+  [ fmap AST_AttribDotName <$> dotLabelTableItem+  , tableItem STRINGLIT $ \tok -> return $ AST_AttribString (asUStr tok) (asLocation tok)+  ]++attribute :: DaoParser AST_Attribute+attribute = joinEvalPTable attributePTab++namespace :: DaoParser AST_Namespace+namespace = do+  tokenBy "as" as0+  nm <- commented $ token LABEL id+  return $ AST_Namespace (fmap asName nm) (unComment $ fmap asLocation nm)++----------------------------------------------------------------------------------------------------++toplevelPTab :: DaoPTable [AST_TopLevel Object]+toplevelPTab = table expr <> comments <> scriptExpr where+  comments = bindPTable spaceComPTab $ \c1 -> optSpace >>= \c2 -> return $+    let coms = c1++c2 in if null coms then [] else [AST_TopComment (c1++c2)]+  scriptExpr = bindPTable scriptPTab $ return . map (\o -> AST_TopScript o (getLocation o))+  expr =+    [ event  "BEGIN"  , event  "END"   , event  "EXIT"+    , tableItemBy "require" $ \startTok -> needAttrib "require" $ do+        attrib <- commented attribute+        endTok <- needSemicolon "require"+        return [AST_Require attrib $ asLocation startTok <> endTok]+    , tableItemBy "import" $ \startTok -> needAttrib "import" $ do+        attrib <- commented attribute+        mplus+          (do namesp <- namespace+              endTok <- needSemicolon "import"+              return [AST_Import attrib namesp $ asLocation startTok <> endTok]+          )+          (return . AST_Import attrib nullValue .+            mappend (asLocation startTok) <$> needSemicolon "import")+    ]+  needSemicolon msg =+    expect ("expecting semicolon after \""++msg++"\" statement") $ tokenBy ";" asLocation+  needAttrib msg =+    expect ("expect string literal or logical module name after \""++msg++"\" statement")+  event   lbl = tableItemBy lbl $ \tok -> do+    let exprType = show (asTokType tok)+    coms <- optSpace+    expect ("bracketed script after \""++exprType++"\" statement") $ do+      (event, endLoc) <- bracketed ('"':exprType++"\" statement")+      return [AST_Event (read lbl) coms event (asLocation tok <> endLoc)]++toplevel :: DaoParser [AST_TopLevel Object]+toplevel = joinEvalPTable toplevelPTab++----------------------------------------------------------------------------------------------------++daoParser :: DaoParser (AST_SourceCode Object)+daoParser = do+  let loop dx = msum+        [ isEOF >>= guard >> return dx+        , toplevel >>= \d -> loop (dx++d)+        , fail "syntax error on token"+        ]+  src <- loop []+  return (AST_SourceCode{sourceModified=0, sourceFullPath=nil, directives=src})++daoGrammar :: Language DaoParState DaoTT (AST_SourceCode Object)+daoGrammar = newLanguage 4 $ mplus daoParser $ fail "Parser backtracked without taking all input."++----------------------------------------------------------------------------------------------------++testDaoLexer :: String -> IO ()+testDaoLexer = testLexicalAnalysis (tokenDBLexer daoTokenDB) 4++testDaoParser :: String -> IO ()+testDaoParser input = case parse daoGrammar mempty input of+  OK      a -> putStrLn ("Parser succeeded:\n"++prettyShow a)+  Backtrack -> testDaoLexer input >> putStrLn "---- PARSER BACKTRACKED ----\n"+  PFail err -> do+    testDaoLexer input+    putStrLn ("---- PARSER FAILED ----\n" ++ show err)+    let st = parseStateAtErr err >>= internalState+    putStrLn ("recentTokens = "++show (tokenQueue <$> st))+    putStrLn ("getLines     = "++show (getLines   <$> st))+
+ src/Dao/Interpreter/Tokenizer.hs view
@@ -0,0 +1,136 @@+-- "src/Dao/Interpreter/Tokenizer.hs" defines the+-- tokenizer for the Dao programming language.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE MultiParamTypeClasses #-}++module Dao.Interpreter.Tokenizer where++import           Dao.String+import           Dao.Interpreter.AST+import           Dao.Parser++import           Control.Monad.Error hiding (Error)++import           Data.Monoid+import           Data.Ix++----------------------------------------------------------------------------------------------------++newtype DaoTT = DaoTT{ unwrapDaoTT :: TT } deriving (Eq, Ord, Ix)+instance TokenType  DaoTT where { unwrapTT = unwrapDaoTT; wrapTT = DaoTT }+instance HasTokenDB DaoTT where { tokenDB  = daoTokenDB }+instance MetaToken DaoTokenLabel DaoTT  where { tokenDBFromMetaValue _ = tokenDB }+instance Show DaoTT where { show = deriveShowFromTokenDB daoTokenDB }++type DaoLexer       = Lexer DaoTT ()++daoTokenDB :: TokenDB DaoTT+daoTokenDB = makeTokenDB daoTokenDef++data DaoTokenLabel+  = SPACE | INLINECOM | ENDLINECOM | COMMA | LABEL | HASHLABEL | STRINGLIT | CHARLIT | DATE | TIME+  | BASE10 | DOTBASE10 | NUMTYPE | EXPONENT | BASE16 | BASE2+  deriving (Eq, Enum, Show, Read)+instance UStrType DaoTokenLabel where { toUStr = derive_ustr; fromUStr = derive_fromUStr; }++daoTokenDef :: LexBuilder DaoTT+daoTokenDef = do+  ------------------------------------------ WHITESPACE -------------------------------------------+  let spaceRX = rxRepeat1(map ch "\t\n\r\f\v ")+  space        <- emptyToken SPACE      $ spaceRX+  +  ------------------------------------------- COMMENTS --------------------------------------------+  closeInliner <- fullToken  INLINECOM  $ rxRepeat1(ch '*') . rx '/'+  inlineCom    <- fullToken  INLINECOM  $ rx "/*" .+    fix (\loop -> closeInliner <> rxRepeat1(invert[ch '*']) . loop)+  endlineCom   <- fullToken  ENDLINECOM $ rx "//" . rxRepeat(invert[ch '\n'])+  +  -------------------------------------------- LABELS ---------------------------------------------+  let alpha = [from 'A' to 'Z', from 'a' to 'z', ch '_']+      labelRX = rxRepeat1 alpha . rxRepeat(from '0' to '9' : alpha)+  label        <- fullToken  LABEL      $ labelRX+  hashlabel    <- fullToken  HASHLABEL  $ rx '#' . labelRX+  +  ---------------------------------------- NUMERICAL TYPES ----------------------------------------+  let from0to9  = from '0' to '9'+      plusMinus = rx[ch '+', ch '-']+      dot       = rx '.'+      number    = rxRepeat1 from0to9+  base10       <- fullToken  BASE10     $ number+  dotBase10    <- fullToken  DOTBASE10  $ dot . base10+  exponent     <- fullToken  EXPONENT   $ rx[ch 'e', ch 'E'] .+    cantFail "expecting exponent value after 'e' or 'E' character" . opt plusMinus . base10+  base2        <- fullToken  BASE2      $ (rx "0b" <> rx "0B") . base10+  base16       <- fullToken  BASE16     $ (rx "0x" <> rx "0X") .+    rxRepeat[from0to9, from 'A' to 'F', from 'a' to 'f']+  numType      <- fullToken  NUMTYPE    $ rx (map ch "UILRFfijs")+  let base10Parser = mconcat $+        [ dotBase10 . opt exponent . opt numType+        , base10 . opt dotBase10 . opt exponent . opt numType+        , base10 . dot . exponent . opt numType+        , base10 . opt exponent . opt numType+        ]+  ---------------------------------------- STRING  LITERAL ----------------------------------------+  let litExpr op =  rx op . (fix $ \loop ->+        rxRepeat(invert [ch op, ch '\\']) . (rx "\\" . rx anyChar . loop <> rx op))+  stringLit    <- fullToken  STRINGLIT $ litExpr '"'+  charLit      <- fullToken  CHARLIT   $ litExpr '\''+  -------------------------------------- KEYWORDS AND GROUPING ------------------------------------+  openers      <- operatorTable $ words "( [ { ${"+  comma        <- emptyToken COMMA (rx ',')+  daoKeywords  <- keywordTable LABEL labelRX $ words $ unwords $+    [ "local const static global"+    , "null false true date time function func rule"+    , "if else for in while with try catch continue break return throw"+    , "BEGIN END EXIT import require"+    , "struct union operator public private" -- other reserved keywords, but they don't do anything yet.+    ]+  let withKeyword key func = do+        tok <- getTokID key :: LexBuilderM DaoTT+        return (rx key . (label <> rxEmptyToken tok . func))+  closers <- operatorTable $ words "} ] )"+  +  ------------------------------------------- OPERATORS -------------------------------------------+  operators    <- operatorTable $ words $ unwords $+    [allUpdateOpStrs, allPrefixOpStrs, allInfixOpStrs, ": ;"]+  +  ------------------------------------ DATE/TIME SPECIAL SYNTAX -----------------------------------+  -- makes use of token types that have already been created above+  let year = rxLimitMinMax 4 5 from0to9+      dd   = rxLimitMinMax 1 2 from0to9+      col  = rx ':'+      hy   = rx '-'+      timeRX = dd . col . dd . col . dd . opt(dot . number)+  timeExpr <- fullToken TIME timeRX+  -- time <- withKeyword "time" $ cantFail "time expression" . space . timeExpr+  time <- withKeyword "time" $ space . timeExpr+  dateExpr <- fullToken DATE $ year . hy . dd . hy . dd+  -- date <- withKeyword "date" $ cantFail "date expression" .+  date <- withKeyword "date" $ space . dateExpr . opt(space . timeExpr) . opt(space . label)+  +  ------------------------------------------- ACTIVATE --------------------------------------------+  -- activate $+  return $ regexToTableLexer $+    [ space, inlineCom, endlineCom, comma+    , stringLit, charLit, base16, base2, base10Parser+    , openers, hashlabel, operators, closers+    , date, time, daoKeywords+    ]+
+ src/Dao/Interval.hs view
@@ -0,0 +1,910 @@+-- "src/Dao/SetM.hs"  defines the Interval data type used to denote+-- a possibly infinite subset of contiguous elements of an Enum data type.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++-- | This module provides what I believe to be a better implementation of mathematical intervals+-- than what is provided by the "interval" and "data-interval" packages, although more work has yet+-- to be done instantiating all of the classes in the "latices" package.+--+-- This module improves on the concept of intervals by making them more general, specifically in+-- that intervals need only instantiate 'Prelude.Enum' rather than 'Prelude.Num'. This means+-- 'Prelude.Char' can now be used to create intervals, which is highly useful for constructing and+-- reasoning about regular expressions and parsers.+--+-- Another improvement provided by this module over other interval modules is that non-contiguous+-- interval sets can be constructed. Thus there are two data types, 'Interval' which is never empty+-- and can be used to construct 'Set's, and 'Set's which may or may not be empty or infinite, and do+-- the work of what the @Data.Interval.Interval@ data type would otherwise do.+module Dao.Interval+  ( -- * The 'Inf' data type+    Inf(NegInf, PosInf, Finite)+  , stepDown, stepUp, toPoint, enumIsInf+  , InfBound, minBoundInf, maxBoundInf+    -- * the 'Interval' data type+  , Interval, startPoint, endPoint, segment, single, wholeInterval, negInfTo, toPosInf, enumInfSeg+  , toBounded, toBoundedPair, segmentMember, singular, plural, segmentNub, segmentInvert+    -- * Predicates on 'Interval's+  , containingSet, numElems, isWithin, segmentHasEnumInf, segmentIsInfinite+    -- * The 'SetM' monadic data type+  , SetM, infiniteM, fromListM, rangeM, pointM+  , toListM, defaultM, memberM, lookupM, nullM, isSingletonM+    -- * Set Operators for monadic 'SetM's+  , sieveM, invertM, setXUnionM, unionM, intersectM, deleteM+  , setToSetM, setMtoSet+    -- * The 'Set' non-monadic data type+  , Set, whole, fromList, fromPairs, range, point+  , toList, elems, member, Dao.Interval.null, isSingleton+    -- * Set Operators for non-monadic 'Set's+  , Dao.Interval.invert, setXUnion, Dao.Interval.union, Dao.Interval.intersect, Dao.Interval.delete+    -- * Miscelaneous+  , upperTriangular, nonAssociativeProduct+  )+  where++import           Data.Monoid+import           Data.List+import           Data.Ratio++import           Control.Monad+import           Control.Applicative+import           Control.DeepSeq++-- | Like 'Prelude.Bounded', except the bounds might be infiniteM, and return 'NegInf' or+-- 'PosInf' for the bounds. Using the GHC "flexible instances" and "undecidable instances"+-- feature, any data type that is an instance of 'Prelude.Bounded' is also a memberM of 'BoundInf'.+class InfBound c where+  minBoundInf :: Inf c+  maxBoundInf :: Inf c++instance InfBound ()              where { minBoundInf = Finite (); maxBoundInf = Finite (); }+instance InfBound Int             where { minBoundInf = Finite minBound; maxBoundInf = Finite maxBound; }+instance InfBound Char            where { minBoundInf = Finite minBound; maxBoundInf = Finite maxBound; }+instance InfBound Integer         where { minBoundInf = NegInf; maxBoundInf = PosInf; }+instance InfBound (Ratio Integer) where { minBoundInf = NegInf; maxBoundInf = PosInf; }+instance InfBound Float           where { minBoundInf = NegInf; maxBoundInf = PosInf; }+instance InfBound Double          where { minBoundInf = NegInf; maxBoundInf = PosInf; }++-- | Enumerable elements with the possibility of infinity.+data Inf c+  = NegInf -- ^ negative infinity+  | PosInf -- ^ positive infinity+  | Finite c -- ^ a single pointM+  deriving Eq++enumIsInf :: Inf c -> Bool+enumIsInf c = case c of+  NegInf -> True+  PosInf -> True+  _          -> False++instance Ord c => Ord (Inf c) where+  compare a b = f a b where+    f a b | a == b = EQ+    f NegInf _ = LT+    f _ NegInf = GT+    f PosInf _ = GT+    f _ PosInf = LT+    f (Finite a) (Finite b) = compare a b++instance Show c => Show (Inf c) where+  show e = case e of+    Finite c -> show c+    NegInf  -> "-infnt"+    PosInf  -> "+infnt"++instance Functor Inf where+  fmap f e = case e of+    NegInf  -> NegInf+    PosInf  -> PosInf+    Finite e -> Finite (f e)++-- | Increment a given value, but if the value is 'Prelude.maxBound', return 'PosInf'. In some+-- circumstances this is better than incrementing with @'Data.Functor.fmap' 'Prelude.succ'@ because+-- 'Prelude.succ' evaluates to an error when passing 'Prelude.maxBound' as the argument. This+-- function will never evaluate to an error.+stepUp :: (Eq c, Enum c, InfBound c) => Inf c -> Inf c+stepUp x = if x==maxBoundInf then PosInf else fmap succ x++-- | Decrement a given value, but if the value is 'Prelude.minBound', returns 'NegInf'. In some+-- circumstances this is better than incrementing @'Data.Functor.fmap' 'Prelude.pred'@ because+-- 'Prelude.pred' evaluates to an error when passing 'Prelude.maxBound' as the argument. This+-- function will never evaluate to an error.+stepDown :: (Eq c, Enum c, InfBound c) => Inf c -> Inf c+stepDown x = if x==minBoundInf then NegInf else fmap pred x++-- | Retrieve the value contained in an 'Inf', if it exists.+toPoint :: Inf c -> Maybe c+toPoint c = case c of+  Finite c -> Just c+  _           -> Nothing++-- | A enumInfSeg of 'Inf' items is a subset of consectutive items in the set of all @c@ where @c@+-- is any type satisfying the 'Prelude.Ix' class. To construct a 'Interval' object, use 'enumInfSeg'.+data Interval c+  = Single  { startPoint :: Inf c }+  | Interval { startPoint :: Inf c, endPoint :: Inf c }+  deriving Eq+  -- NOTE: the constructor for this data type is not exported because all of the functions in this+  -- module that operate on 'Interval's make the assumption that the first parameter *less than* the+  -- second parameter. To prevent anyone from screwing it up, the constructor is hidden and+  -- constructing a 'Interval' must be done with the 'enumInfSeg' function which checks the parameters.++instance Ord c => Ord (Interval c) where+  compare x y = case x of+    Single    a    -> case y of+      Single  b      -> compare a b+      Interval b  _   -> if a==b then LT else compare a b+    Interval   a  b -> case y of+      Single  a'     -> if a==b then GT else compare a a'+      Interval a' b'  -> if a==a' then compare b' b else compare a a'++-- not exported+mkSegment :: Eq c => Inf c -> Inf c -> Interval c+mkSegment a b+  | a==b      = Single  a+  | otherwise = Interval a b++-- | If the 'Interval' was constructed with 'single', return the pointM (possibly 'PosInf' or+-- 'NegInf') value used to construct it, otherwise return 'Data.Maybe.Nothing'.+singular :: Interval a -> Maybe (Inf a)+singular seg = case seg of+  Interval _ _ -> mzero+  Single  a   -> return a++-- | If the 'Interval' was constructed with 'segment', return a pair of points (possibly 'PosInf'+-- or 'NegInf') value used to construct it, otherwise return 'Data.Maybe.Nothing'.+plural :: Interval a -> Maybe (Inf a, Inf a)+plural a = case a of+  Interval a b -> return (a, b)+  Single  _   -> mzero++showSegment :: Show c => Interval c -> String+showSegment seg = case seg of+  Single  a   -> "at "++show a+  Interval a b -> "from "++show a++" to "++show b++-- | This gets rid of as many infiniteM elements as possible. All @'Single' 'PosInf'@ and+-- @'Single' 'NegInf'@ points are eliminated, and if an 'NegInf' or 'PosInf' can be+-- replaced with a corresponding 'minBoundInf' or 'maxBoundInf', then it is. This function is+-- intended to be used as a list monadic function, so use it like so:+-- @let myListOfSegments = [...] in myListOfSegments >>= 'delInfPoints'@+canonicalSegment :: (Eq c, InfBound c) => Interval c -> [Interval c]+canonicalSegment seg = nonInf seg >>= \seg -> case seg of+  Single  a   -> [Single a]+  Interval a b -> nonInf (mkSegment (bounds a) (bounds b))+  where+    nonInf seg = case seg of+      Single  NegInf -> []+      Single  PosInf -> []+      Single  a          -> [Single  a  ]+      Interval a b        -> [Interval a b]+    bounds x = case x of+      NegInf -> minBoundInf+      PosInf -> maxBoundInf+      x          -> x++instance Show c =>+  Show (Interval c) where { show seg = showSegment seg }++-- | A predicate evaluating whether or not a segment includes an 'PosInf' or 'NegInf' value.+-- This should not be confused with a predicate evaluating whether the set of elements included by+-- the rangeM is infiniteM, because types that are instances of 'Prelude.Bounded' may also contain+-- 'PosInf' or 'NegInf' elements, values of these types may be evaluated as "infintie" by+-- this function, even though they are 'Prelude.Bounded'. To check if a segment is infiniteM, use+-- 'segmentIsInfinite' instead.+segmentHasEnumInf :: Interval c -> Bool+segmentHasEnumInf seg = case seg of+  Single  c   -> enumIsInf c+  Interval a b -> enumIsInf a || enumIsInf b++-- | A predicate evaluating whether or not a segment is infiniteM. Types that are 'Prelude.Bounded'+-- are always finite, and thus this function will always evaluate to 'Prelude.False' for these+-- types.+segmentIsInfinite :: InfBound c => Interval c -> Bool+segmentIsInfinite seg = case [Single minBoundInf, Single maxBoundInf, seg] of+  [Single a, Single b, c] | enumIsInf a || enumIsInf b -> case c of+    Single  c   -> enumIsInf c+    Interval a b -> enumIsInf a || enumIsInf b+  _ -> False++-- | Construct a 'Interval' from two 'Inf' items. /NOTE/ if the 'Inf' type you are+-- constructing is an instance of 'Prelude.Bounded', use the 'boundedSegment' constructor instead of+-- this function.+enumInfSeg :: (Ord c, Enum c, InfBound c) => Inf c -> Inf c -> Interval c+enumInfSeg a b = seg a b where+  seg a b = construct (ck minBoundInf NegInf a) (ck maxBoundInf PosInf b)+  ck infnt subst ab = if infnt==ab then subst else ab+  construct a b+    | a == b    = Single  a+    | a < b     = Interval a b+    | otherwise = Interval b a++-- | Construct a 'Interval' from two values.+segment :: Ord c => c -> c -> Interval c+segment a b = mkSegment (Finite (min a b)) (Finite (max a b))++-- | Construct a 'Interval' that is only a single unit, i.e. it starts at X and ends at X.+single :: Ord c => c -> Interval c+single a = segment a a++-- | Construct a 'Interval' from negative infinity to a given value.+negInfTo :: InfBound c => c -> Interval c+negInfTo a = Interval minBoundInf (Finite a)++-- | Construct a 'Interval' from a given value to positive infinity.+toPosInf :: InfBound c => c -> Interval c+toPosInf a = Interval (Finite a) maxBoundInf++-- | Construct the infiniteM 'Interval'+wholeInterval :: Interval c+wholeInterval = Interval NegInf PosInf++-- | Tests whether an element is a memberM is enclosed by the 'Interval'.+segmentMember :: Ord c => Interval c -> c -> Bool+segmentMember seg c = case seg of+  Single  (Finite d) -> c == d+  Interval lo hi         -> let e = Finite c in lo <= e && e <= hi+  _                     -> False++-- | Construct a 'Interval', like the 'enumInfSeg' constructor above, however does not require 'Inf'+-- parameters as inputs. This function performs the additional check of testing whether or not a+-- value is equivalent to 'Prelude.minBound' or 'Prelude.maxBound', and if it is, replaces that+-- value with 'NegInf' or 'PosInf' respectively. In other words, you can use+-- 'Prelude.minBound' in place of NegInf and 'Prelude.maxBound' in place of 'PosInf' without+-- changing the semantics of the data structure as it is used throughout the program.+-- boundedSegment :: (Ord c, Enum c, Bounded c) => c -> c -> Interval c+-- boundedSegment a b = if a>b then co b a else co a b where+--    co a b = enumInfSeg (f a minBound NegInf) (f b maxBound PosInf)+--    f x bound infnt = if x==bound then infnt else Finite x++-- | If an 'Inf' is also 'Prelude.Bounded' then you can convert it to some value in the set of+-- 'Prelude.Bounded' items. 'NegInf' translates to 'Prelude.minBound', 'PosInf' translates+-- to 'Prelude.maxBound', and 'Finite' translates to the value at that pointM.+toBounded :: Bounded c => Inf c -> c+toBounded r = case r of+  NegInf  -> minBound+  PosInf  -> maxBound+  Finite c -> c++-- | Like 'toBounded', but operates on a segment and returns a pair of values.+toBoundedPair :: (Enum c, Bounded c) => Interval c -> (c, c)+toBoundedPair r = case r of+  Single  c   -> (toBounded c, toBounded c)+  Interval c d -> (toBounded c, toBounded d)++enumBoundedPair :: (Enum c, Bounded c) => Interval c -> [c]+enumBoundedPair seg = let (lo, hi) = toBoundedPair seg in [lo..hi]++-- | Computes the minimum 'Interval' that can contain the list of all given 'EnumRanges'.+-- 'Data.Maybe.Nothing' indicates the empty set.+containingSet :: (Ord c, Enum c, InfBound c) => [Interval c] -> Maybe (Interval c)+containingSet ex = foldl fe Nothing ex where+  fe Nothing a  = Just a+  fe (Just a) c = Just $ case a of+    Single  a   -> case c of+      Single   c   -> enumInfSeg (min a c) (max a c)+      Interval  c d -> enumInfSeg (min a c) (max a d)+    Interval a b -> case c of+      Single   c   -> enumInfSeg (min a b) (max b c)+      Interval  c d -> enumInfSeg (min a c) (max b d)++-- | Evaluates to the number of elements covered by this region. Returns 'Prelude.Nothing' if there+-- are an infiniteM number of elements. For data of a type that is not an instance of 'Prelude.Num',+-- for example @'Interval' 'Data.Char.Char'@, it is recommended you first convert to the type+-- @'Interval' 'Data.Int.Int'@ using @'Control.Functor.fmap' 'Prelude.fromEnum'@ before using this+-- function, then convert the result back using @'Control.Functor.fmap' 'Prelude.toEnum'@ if+-- necessary.+numElems :: (Integral c, Enum c) => Interval c -> Maybe Integer+numElems seg = case seg of+  Single  (Finite _)               -> Just 1+  Interval (Finite a) (Finite b) -> Just (fromIntegral a - fromIntegral b + 1)+  _                                   -> Nothing++-- | Tests whether an 'Inf' is within the enumInfSeg. It is handy when used with backquote noation:+-- @enumInf `isWithin` enumInfSeg@+isWithin :: (Ord c, Enum c) => Inf c -> Interval c -> Bool+isWithin pointM seg = case seg of+  Single x              -> pointM == x+  Interval NegInf hi -> pointM <= hi+  Interval lo PosInf -> lo <= pointM+  Interval lo hi         -> lo <= pointM && pointM <= hi++-- | Returns true if two 'Interval's are intersecting.+areIntersecting :: (Ord c, Enum c) => Interval c -> Interval c -> Bool+areIntersecting a b = case a of+  Single  aa  -> case b of+    Single  bb    -> aa == bb+    Interval _  _  -> aa `isWithin` b+  Interval x y -> case b of+    Single  bb    -> bb `isWithin` a+    Interval x' y' -> x' `isWithin` a || y' `isWithin` a || x `isWithin` b || y `isWithin` b++-- | Returns true if two 'Interval's are consecutive, that is, if the end is the 'Prelude.pred'essor+-- of the start of the other.+areConsecutive :: (Ord c, Enum c, InfBound c) => Interval c -> Interval c -> Bool+areConsecutive a b = case a of+  Single  a   -> case b of+    Single  b+      | a < b     -> consec a  b+      | otherwise -> consec b  a+    Interval x  y+      | a < x     -> consec a  x+      | otherwise -> consec y  a+  Interval x y -> case b of    +    Single  a+      | a < x     -> consec a  x+      | otherwise -> consec y  a+    Interval x' y'+      | y < x'    -> consec y  x'+      | otherwise -> consec y' x+  where { consec a b = stepUp a == b || a == stepDown b }++-- | Performs a set union on two 'Interval's of elements to create a new enumInfSeg. If the elements of+-- the new enumInfSeg are not contiguous, each enumInfSeg is returned separately and unchanged. The first+-- item in the pair of items returned is 'Prelude.True' if any of the items were modified.+segmentUnion :: (Ord c, Enum c, InfBound c) => Interval c -> Interval c -> (Bool, [Interval c])+segmentUnion a b+  | areIntersecting a b = case a of+      Single  _   -> case b of+        Single  _      -> (True, [a])+        Interval _  _   -> (True, [b])+      Interval x y -> case b of+        Single  _      -> (True, [a])+        Interval x' y'  -> (True, [enumInfSeg (min x x') (max y y')])+  | areConsecutive a b = case a of+      Single  aa  -> case b of+        Single  bb     -> (True, [enumInfSeg      aa         bb   ])+        Interval x  y   -> (True, [enumInfSeg (min aa x) (max aa y)])+      Interval x y -> case b of+        Single  bb     -> (True, [enumInfSeg (min bb x) (max bb y)])+        Interval x' y'  -> (True, [enumInfSeg (min x x') (max y y')])+  | otherwise = (False, [a, b])++-- | Performs a set intersection on two 'Interval's of elements to create a new enumInfSeg. If the+-- elements of the new enumInfSeg are not contiguous, this function evaluates to an empty list.+segmentIntersect :: (Ord c, Enum c, InfBound c) => Interval c -> Interval c -> (Bool, [Interval c])+segmentIntersect a b = if areIntersecting a b then joined else (False, []) where+  joined = case a of+    Single  aa    -> case b of+      Single  aa    -> (True, [Single aa])+      Interval _  _  -> (True, [Single aa])+    Interval x  y  -> case b of+      Single  aa    -> (True, [Single aa])+      Interval x' y' -> (True, [enumInfSeg (max x x') (min y y')]) ++-- | Performs a set "delete" operation, deleteing any elements selected by the first enumInfSeg if+-- they are contained in the second enumInfSeg. This operation is not associative, i.e.+-- @'segmentDelete' a b /= 'segmentDelete' b a@.+segmentDelete :: (Ord c, Enum c, InfBound c) =>+  Interval c -> Interval c -> (Bool, [Interval c])+segmentDelete a b = if not (areIntersecting a b) then (False, [a]) else del where+  del = case a of+    Single  _   -> case b of+      Single  _     -> (True, [])+      Interval _  _  -> (True, [])+    Interval x y -> case b of+      Single  x'+        | x==x'     -> (True, [enumInfSeg (stepUp x)  y ])+        | y==x'     -> (True, [enumInfSeg x (stepDown y)])+        | otherwise -> (True, [enumInfSeg x (stepDown x'), enumInfSeg (stepUp x') y])+      Interval x' y'+        | x' >  x && y' <  y -> (True, [enumInfSeg x (stepDown x'), enumInfSeg (stepUp y') y])+        | x' <= x && y' >= y -> (True, [])+        | x' <= x && y' <  y -> (True, [enumInfSeg (stepUp y') y])+        | x' >  x && y' >= y -> (True, [enumInfSeg x (stepDown x')])+        | otherwise          -> error "segmentDelete"++-- | Evaluates to the set of all elements not selected by the given 'Interval'.+segmentInvert :: (Ord c, Enum c, InfBound c) => Interval c -> [Interval c]+segmentInvert seg = canonicalSegment =<< case seg of+  Single  x   -> case x of+    NegInf  -> [] -- [Single PosInf]+    PosInf  -> [] -- [Single NegInf]+    Finite _ -> [mkSegment NegInf (stepDown x), mkSegment (stepUp x) PosInf]+  Interval x y -> case x of+    NegInf  -> case y of+      NegInf  -> [] -- [Single  PosInf]+      PosInf  -> [] -- []+      Finite _ -> [mkSegment (stepUp y) PosInf]+    PosInf  -> case y of+      PosInf  -> [] -- [Single  NegInf]+      NegInf  -> [] -- []+      Finite _ -> [mkSegment NegInf (stepDown y)]+    Finite _ -> case y of+      NegInf  -> [mkSegment (stepUp x) PosInf  ]+      PosInf  -> [mkSegment NegInf (stepDown x)]+      Finite _ ->+        [ mkSegment NegInf (min (stepDown x) (stepDown y))+        , mkSegment (max (stepUp x) (stepUp y))  PosInf+        ]++-- | Eliminate overlapping and duplicate 'Interval's from a list of segments.+segmentNub :: (Ord c, Enum c, InfBound c) => [Interval c] -> [Interval c]+segmentNub = toList . fromList++----------------------------------------------------------------------------------------------------++-- | This function is used by 'associativeProduct' to generate the list of pairs on which to execute the+-- inner production function. It is a general function that may come in handy, but otherwise does+-- not specifically relate to 'SetM' or 'Interval' types.+--+-- What it does is, Given two lists of items, returns every possible unique combination of two+-- items. For example the pair (1,2) and (2,1) are considered to be the same combination, so only+-- (1,2) is selected. The selected items are returned as a list. The name of this function derives+-- from a similar matrix operation were all possible pairs are placed in a matrix and the+-- upper-triangluar elements are selected and returned. Pass 'Prelude.True' as the first parameter+-- to select items on the main diagonal of the matrix. Passing 'Prelude.False' is handy when you are+-- trying to evaluate a function on every possible 2-element combination of elements from a single+-- list, but don't need to evaluate each element with itself.+upperTriangular :: Bool -> [a] -> [b] -> [(a, b)]+upperTriangular mainDiag ax bx = do+  let iter bx = if Data.List.null bx then [] else bx : iter (tail bx)+  (a, bx) <- zip ax (if mainDiag then iter bx else if Data.List.null bx then [] else iter (tail bx))+  map (\b -> (a, b)) bx++-- Used by the various set operations, including 'unionWithM', 'intersectWithM', and 'deleteWithM', to+-- compute a new set from two parameter sets and a single operation on the compnent 'Interval's. What+-- it does is, given two lists of elements, the largest possible upper triangular matrix (using+-- 'upperTriangular') of all possible pairs of elements from a and b is formed, and on each pair a+-- given inner product function is executed. The first parameter, the product function, is intended+-- to be a function like 'segmentUnion', 'segmentIntersect', or 'segmentDelete'.+associativeProduct+  :: (Ord c, Enum c, InfBound c)+  => (Interval c -> Interval c -> (Bool, [Interval c]))+  -> [Interval c] -> [Interval c] -> [Interval c]+associativeProduct reduce a b =+  let f a b = upperTriangular True a b >>= snd . uncurry reduce+  in  segmentNub (if length b > length a then f a b else f b a)++-- not for export+-- This equation assumes list arguments passed to it are already sorted list. This alrorithm works+-- in O(log (n^2)) time. Pass two functions, a function for combining intersecting items, and a+-- function for converting non-intersecting items in the list of @a@ to the list of @b@.+exclusiveProduct :: (a -> b -> (Bool, [a])) -> [a] -> [b] -> [a]+exclusiveProduct product ax bx = ax >>= loop False bx where+  loop hitOne bx a = case bx of+    []   -> if hitOne then [] else [a]+    b:bx ->+      let (hit, ax) = product a b+      in  if hit+            then  ax >>= loop False bx+            else  if hitOne then [] else loop False bx a+   -- The logic is this: we are deleting or XOR-ing items bounded by segments in B from items+   -- bounded by segments in A. Both A and B are sorted. For every segment 'a' in A, the following+   -- evaluations take place: every element 'b' in B is checked against 'a' until we find a segment+   -- 'b[first]' that hits (intersects with) 'a'. The 'hitOne' boolean is set to True as soon as+   -- 'b[first]' is found.  Now we continue with every 'b' segment after 'b[first]' until we find a+   -- segment 'b[missed]' that does not hit (intersect with) 'a'. Since 'b[missed]' does not+   -- intersect, every element 'b' above 'b[missed]' will also miss (not intersect with) 'a',+   -- assuming 'b' elements are sorted. Therefore, we can stop scanning for further elements in B,+   -- we know they will all miss (not intersect). If every element in B misses (does not intersect+   -- with) 'a', then the segment 'a' is returned unmodified (because of the definition of XOR).+   -- However if even one segment in B hit this 'a', the only the segments produced by+   -- 'segmentDelete' are returned.++-- | Unlike inner product, which works with associative operators, 'segmentExclusive'+-- works with non-associative operators, like 'segmentDelete' and 'segmentXOR'. Lists of elements+-- passed to this function are sorted. Lists that are already sorted can be multiplied in+-- in O(log (n*m)) time. The product function you pass will return @(Prelude.True, result)@ if the+-- two arguments passed to it "react" with each other, that is, if they can be multiplied to a+-- non-null or non-zero result. This function is used to implement set deletion.+nonAssociativeProduct :: Ord c => (c -> c -> (Bool, [c])) -> [c] -> [c] -> [c]+nonAssociativeProduct product ax bx = exclusiveProduct product (sort ax) (sort bx)++----------------------------------------------------------------------------------------------------++-- | A set-union of serveral 'Interval's, each segment being paired with a list of arbitrary value+-- @x@. It is like an extension of the list monad, except lists may be divided up and assigned to+-- ranges of integral values (or any type that instantiates 'InfBound').+data SetM c x+  = EmptySetM    +  | InfiniteM{ setValue :: [x] }+  | SetM     { setSegmentsM :: [(Interval c, [x])], setValue :: [x] }+  deriving Eq+instance (Ord c, Enum c, InfBound c, Monoid x) =>+  Monoid (SetM c x) where+    mempty      = EmptySetM    +    mappend a b = foldValueSetM mappend (unionM a b)+instance+  Functor (SetM c) where+    fmap f a = case a of+      EmptySetM   -> EmptySetM+      InfiniteM x -> InfiniteM       (fmap f x)+      SetM    a x -> SetM (fmap (fmap (fmap f)) a) (fmap f x)+instance (Ord c, Enum c, InfBound c) =>+  Monad (SetM c) where+    return = InfiniteM . (:[])+    a >>= b = case a of+      EmptySetM   -> EmptySetM+      InfiniteM x -> msum (map b x)+      SetM    a x -> msum (map segs a ++ map deflts x) where+        segs (a, x) = msum (map (sieveM a . b) x)+        deflts x = case b x of+          EmptySetM   -> EmptySetM+          InfiniteM x -> InfiniteM x+          SetM    _ x -> InfiniteM x+instance (Ord c, Enum c, InfBound c) =>+  MonadPlus (SetM c) where { mzero = EmptySetM; mplus = unionM; }+instance (Ord c, Enum c, InfBound c) =>+  Applicative (SetM c) where { pure = return; (<*>) = ap; }+instance (Ord c, Enum c, InfBound c) =>+  Alternative (SetM c) where { empty = mzero; (<|>) = mplus; }++-- | Remove any component segment within the set that does not intersect with the given segment.+sieveM :: (Ord c, Enum c, InfBound c) => Interval c -> SetM c x -> SetM c x+sieveM b a = case a of+  EmptySetM   -> EmptySetM+  InfiniteM x -> SetM [(b, x)] []+  SetM    a x -> case filter (areIntersecting b . fst) a of+    []                -> EmptySetM+    [(a, x)] | a==wholeInterval -> InfiniteM x+    a                 -> SetM    a x++-- | 'SetM' monads contain values accumulate into lists. This function will reduce these lists to a+-- single element using a folding function.+foldValueSetM :: (x -> x -> x) -> SetM c x -> SetM c x+foldValueSetM f s = case s of+  EmptySetM   -> EmptySetM+  InfiniteM x -> InfiniteM (fol x)+  SetM    s x ->+    SetM+    { setSegmentsM = map (\ (s, x) -> (s, fol x)) s+    , setValue = fol x+    }+  where+    fol x = case x of+      (a:b:x) -> [foldl f a (b:x)]+      [x]     -> [x]+      []      -> []++-- not for export+-- Used to create a function useful to 'unionM' and 'intersectM' when those functions call+-- 'exclusiveProduct' to determine which component segments are overlaping, and what to do with 1.+-- segments on the low end do not overlap, 2. segments that overlap, and 3. segments on the high end+-- that do not overlap. The first parameter to this function is a function that takes three lists+-- for each of (1) (2) and (3), and returns a new list that combines the three. In the case of+-- 'intersectionM', (1) and (3) (the non-overlapping parts) are disgarded and only (2) (the+-- overlapping part) is returned. In the case of 'unionM', (1) (2) and (3) are simply concatenated.+joinSegments+  :: (Ord c, Enum c, InfBound c)+  => ([(Interval c, [x])] -> [(Interval c, [x])] -> [(Interval c, [x])] -> [(Interval c, [x])])+  ->  (Interval c, [x])  ->  (Interval c, [x])+  -> (Bool, [(Interval c, [x])])+joinSegments joiner (a, ax) (b, bx) =+  let (isecting, andAB) = segmentIntersect a b+      (_       , delAB) = segmentDelete    a b+      (_       , delBA) = segmentDelete    b a+      newA  = map (\s -> (s,   ax  )) delAB+      newAB = map (\s -> (s, ax++bx)) andAB+      newB  = map (\s -> (s,   bx  )) delBA+  in  if not isecting+        then (False, [(a, ax), (b, bx)])+        else (,) True $ case (newA, newB) of+                ([], [lo, hi]) -> joiner [lo] newAB [hi]+                ([lo, hi], []) -> joiner [lo] newAB [hi]+                ([lo],   [hi]) -> joiner [lo] newAB [hi]+                _              -> error "joinSegments"++unionM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x+unionM a b = case a of+  EmptySetM    -> b+  InfiniteM ax -> case b of+    EmptySetM    -> InfiniteM ax+    InfiniteM bx -> InfiniteM (ax++bx)+    SetM    b bx -> SetM b (ax++bx)+  SetM    a ax -> case b of+    EmptySetM    -> SetM a  ax+    InfiniteM bx -> SetM a (ax++bx)+    SetM    b bx ->+      SetM (exclusiveProduct (joinSegments (\lo mid hi -> lo++mid++hi)) a b) (ax++bx)++intersectM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x+intersectM a b = case a of+  EmptySetM    -> b+  InfiniteM ax -> case b of+    EmptySetM    -> InfiniteM  ax+    InfiniteM bx -> InfiniteM (ax++bx)+    SetM    b bx -> SetM b (ax++bx)+  SetM    a ax -> case b of+    EmptySetM    -> SetM a  ax+    InfiniteM bx -> SetM a (ax++bx)+    SetM    b bx ->+      SetM (exclusiveProduct (joinSegments (\_ mid _ -> mid)) a b) (ax++bx)++deleteM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x+deleteM a b = case a of+  EmptySetM    -> EmptySetM+  InfiniteM ax -> case b of+    EmptySetM    -> InfiniteM ax+    InfiniteM _  -> EmptySetM+    SetM    b _  -> invertM (SetM b []) ax+  SetM    a ax -> case b of+    EmptySetM    -> SetM a ax+    InfiniteM _  -> EmptySetM+    SetM    b _  -> flip SetM ax $ nubBy (\a b -> fst a == fst b) $+      exclusiveProduct (joinSegments (\lo _ hi -> lo++hi)) a b++setXUnionM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x+setXUnionM a b = unionM (deleteM a b) (deleteM b a)++invertM :: (Ord c, Enum c, InfBound c) => SetM c x -> [y] -> SetM c y+invertM a y = case a of+  EmptySetM   -> InfiniteM y+  InfiniteM _ -> EmptySetM+  SetM    a _ ->+    SetM (map (flip (,) y) $ toList $ invert $ fromList $ map fst a) []++-- | Initialize a new intinite 'SetM', that is, the set that contains all possible elements.+infiniteM :: (Ord c, Enum c, InfBound c) => [x] -> SetM c x+infiniteM = InfiniteM++-- | Initialize a new 'SetM' object with a list of 'Interval's, which are 'segmentUnion'ed+-- together to create the set.+fromListM :: (Ord c, Enum c, InfBound c) => [Interval c] -> [x] -> SetM c x+fromListM a ax = case segmentNub a of+  [a] | a==wholeInterval -> InfiniteM ax+  []           -> EmptySetM+  a            -> SetM (map (flip (,) ax) a) []++-- | Create a set with a single rangeM of elements, no gaps.+rangeM :: (Ord c, Enum c, InfBound c) => c -> c -> [x] -> SetM c x+rangeM a b x = SetM [(segment a b, x)] []++-- | Create a set with a single element.+pointM :: (Ord c, Enum c, InfBound c) => c -> [x] -> SetM c x+pointM c x = rangeM c c x++-- | Tests if an element is a memberM of the set.+memberM :: Ord c => SetM c x -> c -> Bool+memberM a c = case a of+  EmptySetM   -> False+  InfiniteM _ -> True+  SetM    a _ -> or (map (flip segmentMember c . fst) a)++-- | Test if a set encompases only one element, and if so, returns that one element.+isSingletonM :: (Ord c, Enum c, InfBound c) => SetM c x -> Maybe (c, [x])+isSingletonM a = case a of+  SetM a _ -> case a of+    [(Single (Finite a), x)] -> Just (a, x)+    _                       -> Nothing+  _        -> Nothing++-- | Tests if a set is empty.+nullM :: SetM c x -> Bool+nullM a = case a of+  EmptySetM  -> True+  SetM  [] _ -> True+  _          -> False++lookupM :: (Ord c, Enum c, InfBound c) => SetM c x -> c -> [x]+lookupM a c = case a of+  EmptySetM   -> []+  InfiniteM x -> x+  SetM    a x -> case concatMap snd (filter (isWithin (Finite c) . fst) a) of { [] -> x; x -> x; }++toListM :: SetM c x -> [(Interval c, [x])]+toListM set = case set of+  EmptySetM   -> []+  InfiniteM _ -> []+  SetM    a _ -> a++defaultM :: SetM c x -> [x]+defaultM set = case set of+  EmptySetM   -> []+  InfiniteM x -> x+  SetM    _ x -> x++setToSetM :: (Ord c, Enum c, InfBound c) => Set c -> [x] -> SetM c x+setToSetM a x = case a of+  EmptySet     -> EmptySetM+  InfiniteSet  -> InfiniteM x+  InverseSet a -> setToSetM (forceInvert a) x+  Set        a -> SetM (map (flip (,) x) a) []++setMtoSet :: SetM c x -> Set c+setMtoSet a = case a of+  EmptySetM   -> EmptySet+  InfiniteM _ -> InfiniteSet+  SetM    a _ -> Set (map fst a)++----------------------------------------------------------------------------------------------------++data Set c+  = EmptySet    +  | InfiniteSet+  | InverseSet  (Set c)+  | Set         [Interval c]+instance (Ord c, Enum c, InfBound c) => Eq (Set c) where+  a == b = case a of+    EmptySet     -> case b of+      EmptySet      -> True+      Set        [] -> True+      _             -> False+    InfiniteSet  -> case b of+      InfiniteSet                  -> True+      Set [s] | s==wholeInterval -> True+      _                            -> False+    InverseSet a -> case b of+      InverseSet b -> a==b+      _            -> forceInvert a == b+    Set        a -> case b of+      Set        b -> a==b+      _            -> False++instance (Ord c, Enum c, InfBound c) => Monoid (Set c) where+  mempty  = EmptySet+  mappend = Dao.Interval.union++instance Show c => Show (Set c) where+  show s = case s of+    EmptySet     -> "enumSet()"+    InfiniteSet  -> "enumSet(-Inf to +Inf)"+    InverseSet s -> "!enumSet("++show s++")"+    Set        s -> "enumSet("++intercalate ", " (map show s)++")"++whole :: Set c+whole = InfiniteSet++-- not exported, creates a list from segments, but does not clean it with 'segmentNub'+fromListNoNub :: (Ord c, Enum c, InfBound c) => [Interval c] -> Set c+fromListNoNub a =+  if Data.List.null a+    then EmptySet    +    else if a==[wholeInterval] then InfiniteSet else Set a++fromList :: (Ord c, Enum c, InfBound c) => [Interval c] -> Set c+fromList a = if Data.List.null a then EmptySet     else fromListNoNub a++fromPairs :: (Ord c, Enum c, InfBound c) => [(c, c)] -> Set c+fromPairs = fromList . map (uncurry segment)++range :: (Ord c, Enum c, InfBound c) => c -> c -> Set c+range a b = Set [segment a b]++point :: (Ord c, Enum c, InfBound c) => c -> Set c+point a = Set [single a]++toList :: (Ord c, Enum c, InfBound c) => Set c -> [Interval c]+toList s = case s of+  EmptySet     -> []+  InfiniteSet  -> [wholeInterval]+  InverseSet s -> toList (forceInvert s)+  Set        s -> s++elems :: (Ord c, Enum c, Bounded c, InfBound c) => Set c -> [c]+elems = concatMap enumBoundedPair . toList++member :: (Ord c, InfBound c) => Set c -> c -> Bool+member s b = case s of+  EmptySet     -> False+  InfiniteSet  -> True+  InverseSet s -> not (member s b)+  Set       [] -> False+  Set        s -> or (map (flip segmentMember b) s)++null :: Set c -> Bool+null s = case s of+  EmptySet     -> True+  InfiniteSet  -> False+  InverseSet s -> not (Dao.Interval.null s)+  Set       [] -> True+  Set        _ -> False++isSingleton :: (Ord c, Enum c, InfBound c) => Set c -> Maybe c+isSingleton s = case s of+  InverseSet   s -> isSingleton (forceInvert s)+  Set [Single c] -> toPoint c+  _              -> mzero++invert :: (Ord c, Enum c, InfBound c) => Set c -> Set c+invert s = case s of+  EmptySet     -> InfiniteSet+  InfiniteSet  -> EmptySet    +  InverseSet s -> s+  Set        s -> InverseSet (Set s)++-- not for export+forceInvert :: (Ord c, Enum c, InfBound c) => Set c -> Set c+forceInvert s = case s of+  EmptySet     -> InfiniteSet+  InfiniteSet  -> EmptySet    +  InverseSet s -> s+  Set      []  -> InfiniteSet+  Set     [s] | s==wholeInterval -> EmptySet    +  Set       s  -> fromListNoNub (loop NegInf s >>= canonicalSegment) where+    loop mark s = case s of+      []                   -> [mkSegment (stepUp mark) PosInf]+      [Interval a PosInf]   -> [mkSegment (stepUp mark) (stepDown a)]+      Interval NegInf b : s -> loop b s+      Interval a      b : s -> mkSegment (stepUp mark) (stepDown a) : loop b s+      Single  a        : s -> mkSegment (stepUp mark) (stepDown a) : loop a s++setXUnion :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c+setXUnion a b = Dao.Interval.delete (Dao.Interval.union a b) (Dao.Interval.intersect a b)++union :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c+union a b = case a of+  EmptySet     -> b+  InfiniteSet  -> InfiniteSet+  InverseSet a -> Dao.Interval.union (forceInvert a) b+  Set       [] -> b+  Set        a -> case b of+    EmptySet     -> Set a+    InfiniteSet  -> InfiniteSet+    InverseSet b -> Dao.Interval.union (Set a) (forceInvert b)+    Set       [] -> Set a+    Set        b -> fromListNoNub (associativeProduct segmentUnion a b)++intersect :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c+intersect a b = case a of+  EmptySet     -> EmptySet    +  InfiniteSet  -> b+  InverseSet a -> Dao.Interval.intersect (forceInvert a) b+  Set       [] -> EmptySet    +  Set        a -> case b of+    EmptySet     -> EmptySet    +    InfiniteSet  -> Set a+    InverseSet b -> Dao.Interval.intersect (Set a) (forceInvert b)+    Set       [] -> EmptySet    +    Set        b -> fromListNoNub (associativeProduct segmentIntersect a b)++delete :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c+delete a b = case b of+  EmptySet     -> a+  InfiniteSet  -> EmptySet    +  InverseSet b -> Dao.Interval.delete a (forceInvert b)+  Set       [] -> a+  Set        b -> case a of+    EmptySet     -> EmptySet    +    InfiniteSet  -> forceInvert (Set b)+    InverseSet a -> Dao.Interval.delete (forceInvert a) (Set b)+    Set       [] -> EmptySet    +    Set        a -> fromList (exclusiveProduct segmentDelete a b)+      -- Here we call 'fromList' instead of 'fromListNoNub' because an additional 'segmentNub'+      -- operation is required.++----------------------------------------------------------------------------------------------------++instance NFData a =>+  NFData (Inf a) where+    rnf  NegInf   = ()+    rnf  PosInf   = ()+    rnf (Finite c) = deepseq c ()++instance NFData a =>+  NFData (Interval a) where+    rnf (Single  a  ) = deepseq a ()+    rnf (Interval a b) = deepseq a $! deepseq b ()++instance (NFData a, NFData x) =>+  NFData (SetM a x) where+    rnf a = case a of+      EmptySetM    -> ()+      InfiniteM ax -> deepseq ax ()+      SetM    a ax -> deepseq a $! deepseq ax ()++instance NFData a => NFData (Set a) where+  rnf EmptySet       = ()+  rnf InfiniteSet    = ()+  rnf (Set a)        = deepseq a ()+  rnf (InverseSet a) = deepseq a ()+
+ src/Dao/Lib/Array.hs view
@@ -0,0 +1,165 @@+-- "src/Dao/Lib/Array.hs"  built-in array object+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++-- | This module provides the Dao programming language implementation of the 'Array' built-in data+-- type. 'Array's can be indexed from zero to (n-1) where n is the number of elements in the array.+-- Reads and updates are O(n). Resizing an array is not possible.+module Dao.Lib.Array where++import           Dao.String+import           Dao.Predicate+import           Dao.Interpreter++import           Control.Applicative+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.State++import           Data.Array.IO+import           Data.Monoid+import           Data.Typeable++import qualified Data.IntMap          as I++----------------------------------------------------------------------------------------------------++-- | The Dao programming language wrapper around Haskell's 'Data.Array.IO.IOArray' data type.+-- To inspect elements of the array outside of the IO monad, the only way for pure functions like+-- 'Dao.PPrint.PPrint' and 'Dao.Binary.Put' to work without being unsafe is to lazily evaluate these+-- functions after every update to the array. These functions are evaluated extra-lazily to ensure+-- that nothing actually happens until it becomes absolutely necessary to use them, if it ever is+-- necessary.+newtype Array = Array { toObjArray :: IOArray Int Object } deriving (Eq, Typeable)++arrayFromList :: Int -> [(Int, Object)] -> IO Array+arrayFromList len ox = do+  arr <- newArray (0, len) ONull+  forM_ ox $ \ (i, o) -> writeArray arr i o+  return $ Array{ toObjArray=arr }++arraySize :: Array -> IO Int+arraySize arr = uncurry subtract <$> getBounds (toObjArray arr)++arrayElems :: Array -> IO [Object]+arrayElems = getElems . toObjArray++arrayCheckIndex :: Array -> Int -> IO (Predicate ExecControl ())+arrayCheckIndex arr i = do+  bounds <- getBounds (toObjArray arr)+  return $+    if inRange bounds i+    then OK ()+    else PFail $ newError{ execErrorMessage=ustr "array index out of bounds" }++arrayLookup :: Array -> Int -> IO (Predicate ExecControl Object)+arrayLookup arr i = arrayCheckIndex arr i >>= \result -> case result of+  PFail err -> return (PFail err)+  Backtrack -> return Backtrack+  OK     () -> OK <$> readArray (toObjArray arr) i++arrayUpdate :: Array -> Int -> Object -> IO (Predicate ExecControl ())+arrayUpdate arr i o = arrayCheckIndex arr i >>= \result -> case result of+  PFail err -> return $ PFail err+  Backtrack -> return Backtrack+  OK     () -> OK <$> writeArray (toObjArray arr) i o++instance ReadIterable Array Object where+  readForLoop (Array arr) f = liftIO (getBounds arr) >>=+    flip execForM_ (liftIO . readArray arr >=> f) . range++instance UpdateIterable Array (Maybe Object) where+  updateForLoop a@(Array arr) f = do+    let err = "for loop iteration attempted to delete an item from an Array"+    liftIO (getBounds arr) >>=+      flip execForM_ (\i -> liftIO (readArray arr i) >>= f . Just >>=+              maybe (fail err) return >>= liftIO . writeArray arr i) . range+    return a++instance ObjectFunctor Array Int where+  objectFMap f = do+    arr <- get+    let a = toObjArray arr+    (bounds, elems) <- liftIO $ return (,) <*> getBounds a <*> getElems a+    forM_ (zip (range bounds) elems) $ \ (i, o) -> focalPathSuffix (Subscript [obj i] NullRef) $+      withInnerLens [] (f i o) >>= \ (_, (changed, ox)) ->+        when changed $ forM_ ox (liftIO . uncurry (writeArray $ toObjArray arr))++instance ObjectFunctor Array  Object  where { objectFMap f = objectFMap (\i -> f (obj i)) }+instance ObjectFunctor Array [Object] where { objectFMap f = objectFMap (\i -> f [obj i]) }++_objToInt :: [Object] -> Exec Int+_objToInt ix = case ix of+  [i] -> (derefObject i >>= xmaybe . fromObj) <|>+    throwBadTypeError "Array index value cannot be cast to integer" i []+  ix  -> throwArityError "Array index is not one-dimensional" 1 ix []++arrayFromArgs :: [Object] -> IO Array+arrayFromArgs lists =+  forM lists+    (\o -> maybe (return (1, [o])) id $ msum $+        [ fromObj o >>= \ox  -> Just $ return (length ox, ox)+        , fromObj o >>= \arr -> Just $ return (,) <*> arraySize arr <*> arrayElems arr+        ]+    ) >>= uncurry arrayFromList . (\ (ix, ox) -> (sum ix, zip [0..] $ concat ox)) . unzip++loadLibrary_Array :: DaoSetup+loadLibrary_Array = do+  daoClass (haskellType::Array)+  daoFunction "Array" $+    daoFunc+    { funcAutoDerefParams=True+    , daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj) . liftIO . arrayFromArgs+    }++instance ObjectClass Array where { obj=new; fromObj=objFromHata; }++instance HataClass Array where+  haskellDataInterface = interface "Array" $ do+    autoDefEquality >> autoDefReadIterable >> autoDefUpdateIterable >> autoDefTraverse+    defSizer (fmap OInt . liftIO . arraySize)+    defIndexer $ \arr i -> _objToInt i >>= liftIO . arrayLookup arr >>= predicate+    defIndexUpdater $ \i f -> focusLiftExec (_objToInt i) >>= \i -> do+      arr <- get+      (_arr, (changed, o)) <- focusLiftExec (liftIO (arrayLookup arr i) >>= predicate) >>=+        flip withInnerLens f . Just+      case o of+        Nothing -> fail "cannot delete items from array"+        Just  o -> when changed (liftIO $ writeArray (toObjArray arr) i o) >> return (Just o)+    let init ox = case ox of -- initializer list in round-brackets must be empty+          [] -> return (Array $ error "uninitialized Array") -- SUCCESS: return an uninitialized Array+          _  -> execThrow "cannot initialize array with parameters" ExecErrorUntyped [] -- FAIL+    let fromList m i maxbnd arr ox = case ox of+          []   -> liftIO $ arrayFromList maxbnd (I.assocs m)+          o:ox -> case o of+            InitAssign ref op o -> do+              i <- derefObject ref >>= _objToInt . return+              if i<0+              then execThrow "assigned to negative index value" op [(assertFailed, OInt i)]+              else do+                ref <- pure $ fromObj ref <|> Just (RefObject ref NullRef)+                o <- evalUpdateOp ref op o (I.lookup i m)+                case o of+                  Just  o -> do+                    a <- fromList (I.insert i o m) (i+1) (max i maxbnd) arr ox+                    return $ arr{ toObjArray=toObjArray a }+                  Nothing -> execThrow "index to Array evaluated to void" op $+                    maybe [] (\ref -> [(errOfReference, obj ref)]) ref+            InitSingle o -> fromList (I.insert i o m) (i+1) (max i maxbnd) arr ox+    defInitializer init (fromList mempty 0 0)+
+ src/Dao/Lib/File.hs view
@@ -0,0 +1,208 @@+-- "src/Dao/Lib/File.hs"  built-in plain file object+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++module Dao.Lib.File where++import           Dao.String+import           Dao.Predicate+import           Dao.PPrint+import qualified Dao.Binary as B+import           Dao.Interpreter++import qualified Data.ByteString.Lazy as B+import qualified Data.Map.Lazy        as M+import           Data.Typeable++import           Control.Applicative+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.State++import           System.IO++data File = File { filePath :: UStr, fileHandle :: Maybe Handle } deriving Typeable++instance Eq File where { a==b = filePath a == filePath b }++instance Ord File where { compare a b = compare (filePath a) (filePath b) }++instance Show File where { show a = "File("++show (filePath a)++")" }++instance HasNullValue File where+  nullValue = File{ filePath=nil, fileHandle=Nothing }+  testNull (File{ filePath=name, fileHandle=Nothing }) = nil==name+  testNull (File{}) = False++instance PPrintable File where { pPrint = pShow }++instance B.Binary File MethodTable where+  get    = return File <*> B.get <*> pure Nothing+  put f = B.put (filePath f)++errFilePath :: Name+errFilePath = ustr "filePath"++_openParamFail :: String -> [Object] -> Exec ig+_openParamFail func ox =+  throwArityError "expecting a file path as the only parameter" 1 ox [(errInFunc, obj (ustr func :: Name))]++_paramPath :: String -> [Object] -> Exec UStr+_paramPath func ox = case ox of+  [path] -> xmaybe (fromObj path <|> (filePath <$> fromObj path)) <|> _openParamFail func ox+  ox     -> _openParamFail func ox++_catchIOException :: String -> File -> IO a -> Exec a+_catchIOException func file f = execCatchIO (liftIO f) $+  [ newExecIOHandler $ \e -> execThrow "" (ExecIOException e) $+      [(errInFunc, obj (ustr func :: Name)), (errFilePath, obj $ filePath file)]+  ]++_openFile :: String -> File -> IOMode -> Exec File+_openFile func file mode = _catchIOException func file $+  (\o -> file{ fileHandle=Just o}) <$> openFile (uchars $ filePath file) mode++_getHandle :: String -> File -> Exec Handle+_getHandle func file = case fileHandle file of+  Just  h -> return h+  Nothing ->+    execThrow "function evaluated on a file handle which has not been opened" ExecErrorUntyped+      [(errInFunc, obj (ustr func :: Name)), (errFilePath, obj $ filePath file)]++_withClosedHandle :: String -> File -> Exec ()+_withClosedHandle func file = case fileHandle file of+  Nothing -> return ()+  Just  _ -> execThrow "function cannot operate on open file handle" ExecErrorUntyped+    [(errInFunc, obj (ustr func :: Name)), (errFilePath, obj $ filePath file)]++_withContents :: (String -> IO Object) -> DaoFunc File+_withContents f =+  daoFunc+  { daoForeignFunc = \file ox -> case ox of+      [] -> do+        _withClosedHandle "read" file+        _catchIOException "read" file $ fmap (flip (,) file . Just) $ readFile (uchars $ filePath file) >>= f+      ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "read" :: Name))]+  }++gGetErrToExecError :: B.GGetErr -> ExecControl+gGetErrToExecError (B.GetErr{ B.gGetErrOffset=offset, B.gGetErrMsg=msg }) =+  newError+  { execErrorMessage = msg+  , execErrorInfo    = M.fromList [(ustr "byteOffset", OLong (toInteger offset))]+  }++loadLibrary_File :: DaoSetup+loadLibrary_File = do+  let fileOpener func mode = daoFunction func $+        daoFunc+        { daoForeignFunc = \ () ->+            _paramPath func >=> fmap (flip (,) () . Just . obj) . flip (_openFile func . flip File Nothing) mode+        }+  fileOpener "readFile"   ReadMode+  fileOpener "writeFile"  WriteMode+  fileOpener "appendFile" AppendMode+  daoClass (haskellType::File)+  daoFunction "File" $+    daoFunc+    { daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj . flip File Nothing) . _paramPath "File"+    }++instance ObjectClass File where { obj=new; fromObj=objFromHata; }++instance HataClass File where+  haskellDataInterface = interface "File" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest+    autoDefPPrinter >> autoDefBinaryFmt+    let fileOpener func mode = defMethod func $+          daoFunc+          { funcAutoDerefParams = False+          , daoForeignFunc = \file ox ->+              case ox of+                [] -> do+                  _withClosedHandle func file+                  f <- _openFile func file mode+                  return (Just $ obj f, f)+                ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "File" :: Name))]+          }+    fileOpener "openRead"   ReadMode+    fileOpener "openWrite"  WriteMode+    fileOpener "openAppend" AppendMode+    defMethod "close" $+      daoFunc+      { funcAutoDerefParams = False+      , daoForeignFunc = \file ox -> fmap (flip (,) (file{ fileHandle=Nothing })) $ do+          case ox of+            [] -> _getHandle "close" file >>=+              _catchIOException "close" file . liftIO . hClose >> return Nothing+            ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "close" :: Name))]+      }+    defMethod "writeBinary" $+      daoFunc+      { daoForeignFunc = \file ox -> do+          mtab  <- gets globalMethodTable+          handl <- _getHandle "writeBinary" file+          forM_ ox $ \o -> do+            bin <- execCatchIO (liftIO $ return (B.encode mtab o)) $+              [ newExecIOHandler $ \e -> execThrow "while encoding object" (ExecHaskellError e) $+                  [ (errInFunc, obj (ustr "writeBinary" :: Name))+                  , (errFilePath, obj $ filePath file)+                  ]+              ]+            _catchIOException "writeBinary" file (B.hPutStr handl bin)+          return (Nothing, file)+      }+    defMethod "readBinary" $+      daoFunc+      { daoForeignFunc = \file ox -> case ox of+          [] -> do+            _withClosedHandle "readBinary" file+            mtab   <- gets globalMethodTable+            bin    <- _catchIOException "readBinary" file (liftIO $ B.readFile $ uchars $ filePath file)+            result <- execCatchIO (return $ fmapPFail gGetErrToExecError $ B.decode mtab bin) $+              [ newExecIOHandler $ \e -> execThrow "while decoding object" (ExecHaskellError e) $+                  [(errInFunc, obj (ustr "readBinary" :: Name)), (errFilePath, obj $ filePath file)]+              ]+            predicate result+          ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "readBinary" :: Name))]+      }+    let writeFunc func putstr = defMethod func $+          daoFunc+          { daoForeignFunc = \file ox -> do+              ox <- requireAllStringArgs func ox+              handl <- _getHandle func file+              forM_ ox $ _catchIOException "write" file . putstr handl . uchars+              return (Nothing, file)+          }+    writeFunc "write" hPutStr+    defMethod "read" $ _withContents (return . obj)+    defMethod "readAllLines" $ _withContents (return . obj . fmap obj . lines)+    writeFunc "writeLine" hPutStrLn+    defMethod "readLine" $+      daoFunc+      { daoForeignFunc = \file ox -> case ox of+          [] -> do+            handl <- _getHandle "readLine" file+            _catchIOException "readLine" file (flip (,) file . Just . obj <$> hGetLine handl)+          ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "readLine" :: Name))]+      }+    let defPrinter func print = defMethod func $+          makePrintFunc $ \file str -> _getHandle func file >>= \h -> liftIO (print h str)+    defPrinter "print"   hPutStr+    defPrinter "println" hPutStrLn+
+ src/Dao/Lib/ListEditor.hs view
@@ -0,0 +1,222 @@+-- "src/Dao/Lib/ListEditor.hs"  built-in object for Dao programs that can+-- functions like a line editor, but for arbitrary types, not just strings.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++-- | This is a line-editor object, but it works with arbitrary lists of objects, but this will work+-- for editing arbitrary lists. You could use it to create an ordinary line editor by representing a+-- file as be a list of strings representing a file. each string could further be converted to a+-- StepList containing characters to edit the line. +module Dao.Lib.ListEditor where++import           Dao.String+import           Dao.StepList+import           Dao.Predicate+import           Dao.PPrint+import qualified Dao.Binary as B+import           Dao.Interpreter+import           Dao.Interpreter.AST++import           Control.Applicative+import           Control.Monad+import           Control.Monad.State++import           Data.Monoid+import qualified Data.IntMap as I+import           Data.Typeable++----------------------------------------------------------------------------------------------------++newtype ListEditor = ListEditor { listEditor :: StepList Object } deriving (Eq, Ord, Show, Typeable)++loadLibrary_ListEditor :: DaoSetup+loadLibrary_ListEditor = do+  daoClass (haskellType::ListEditor)++instance Monoid ListEditor where+  mempty = ListEditor mempty+  mappend (ListEditor a) (ListEditor b) = ListEditor (a<>b)++instance HasNullValue ListEditor where+  nullValue = mempty+  testNull (ListEditor sl) = slNull sl++instance ToDaoStructClass ListEditor where+  toDaoStruct = renameConstructor "ListEditor" $ do+    "left"  .=@ slLeftOfCursor  . listEditor+    "right" .=@ slRightOfCursor . listEditor++instance FromDaoStructClass ListEditor where+  fromDaoStruct = do+    constructor "ListEditor"+    left  <- optList "left"+    right <- optList "right"+    return $ ListEditor $ slFromLeftRight left right++instance PPrintable ListEditor where { pPrint = pPrintStructForm }++instance B.Binary ListEditor MethodTable where+  put (ListEditor sl) = B.put (slCursor sl) >> B.put (slLeftOfCursor sl ++ slRightOfCursor sl)+  get = B.get >>= \cur ->+    ListEditor . slCursorTo cur . uncurry slFromLeftRight . splitAt cur <$> B.get++instance ReadIterable ListEditor Object where+  readForLoop (ListEditor sl) = execForM_ (slToList sl)++instance UpdateIterable ListEditor (Maybe Object) where+  updateForLoop (ListEditor sl) = fmap (ListEditor . slFromList (slCursor sl) .+    concatMap (maybe [] return)) . execForM (fmap Just $ slToList sl)++instance ObjectClass ListEditor where { obj=new; fromObj=objFromHata; }++_getIndex :: [Object] -> Predicate err Int+_getIndex ix = case ix of+  [i] -> xmaybe (fromObj i)+  _   -> fail "must index ListEditor with a 1-dimentional integer value"++_withRange :: String -> (Int -> Int -> Exec a) -> [Object] -> Exec a+_withRange func f ox = do+  let err = throwArityError "expecting one or two integer parameters" 2 ox $+        [(errInFunc, obj (ustr func :: Name))]+  case ox of+    []  -> err+    [a] -> do+      a <- xmaybe (fromObj a) <|>+        throwBadTypeError "index parameter received is not an integer value" a+          [(errInFunc, obj (ustr func :: Name))]+      f (min 0 a) (max 0 a)+    [a, b] -> do+      let param n a = xmaybe (fromObj a) <|>+            (throwBadTypeError "in range to ListEditor" a $+              [(errInConstr, obj (ustr func :: Name)), (argNum, OInt n)]+            )+      param 1 a >>= \a -> param 2 b >>= \b -> f (min a b) (max a b)+    _ -> err++instance ObjectLens ListEditor Int where+  updateIndex i f = do+    sl <- slCursorTo i . listEditor <$> get+    (o, right) <- pure $ case slRightOfCursor sl of+      []   -> (Nothing, [])+      o:ox -> (Just  o, ox)+    (result, (changed, o)) <- withInnerLens o f+    when changed $ put $ ListEditor $ case o of+      Nothing -> sl{slRightOfCursor=right, slLength=slLength sl - 1}+      Just  o -> sl{slRightOfCursor=o:right }+    return result++instance ObjectFunctor ListEditor Int where+  objectFMap f = do+    (ListEditor sl) <- get+    o <- mapM (fmap snd . withInnerLens [] . uncurry f) $ concat $+        [ reverse $+            if slCursor sl > 0+            then zip (map negate [1..slCursor sl]) (slLeftOfCursor sl)+            else []+        , zip [0..] (slRightOfCursor sl)+        ]+    (changed, o) <- return $ unzip o+    when (or changed) $+      put $ ListEditor $ slCursorTo (slCursor sl) $ slFromIntMap $ I.fromList $ concat o++instance ObjectFunctor ListEditor [Object] where { objectFMap f = objectFMap (\i -> f [obj i]) }++instance Sizeable ListEditor where { getSizeOf = return . obj . slLength . listEditor }++instance HataClass ListEditor where+  haskellDataInterface = interface "ListEditor" $ do+    autoDefEquality >> autoDefOrdering >> autoDefNullTest+    autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct+    autoDefSizeable >> return ()+    autoDefReadIterable >> autoDefUpdateIterable >> autoDefTraverse+    defIndexer $ \ (ListEditor sl) -> fmap (flip slIndex sl) . predicate . _getIndex >=> xmaybe+    defIndexUpdater (\ix f -> predicate (_getIndex ix) >>= flip updateIndex f)+    defInitializer+      (\ox -> +        if null ox+        then return mempty+        else predicate $ (\i -> ListEditor $ mempty{ slCursor=i }) <$> _getIndex ox+      )+      (\ (ListEditor sl) ox -> do+          let loop im ox = case ox of+                [] -> return $ ListEditor $ slCursorTo (slCursor sl) $ slFromIntMap im+                (i, o):ox -> case o of+                  InitSingle        o -> loop (I.insert i o im) ox+                  InitAssign ref op o -> do+                    i <- (fromObj <$> derefObject ref >>= xmaybe) <|>+                      (throwBadTypeError "ListEditor constructor assigns value to non-integer type" ref $+                        [(errInFunc, obj (ustr "ListEditor" :: Name))]+                      )+                    o <- evalUpdateOp (Just $ RefObject ref NullRef) op o (I.lookup i im)+                    loop (I.alter (const o) i im) ox+          loop mempty (zip [(slCursor sl)..] ox)+      )+    let deref sl = case slRightOfCursor sl of { [] -> Nothing; o:_ -> Just o; }+    defDeref (return . deref . listEditor)+    defInfixOp SHL $ \ _ (ListEditor sl) o -> case o of+      OList ox -> return $ obj $ ListEditor (ox<++sl)+      o        -> return $ obj $ ListEditor (o <| sl)+    defInfixOp SHR $ \ _ (ListEditor sl) o -> case o of+      OList ox -> return $ obj $ ListEditor (ox++>sl)+      o        -> return $ obj $ ListEditor (o  |>sl)+    defInfixOp ADD $ \ _ (ListEditor a) o -> do+      (ListEditor b) <- xmaybe (fromObj o) <|> fail "added ListEditor object to non-ListEditor object"+      return $ obj $ ListEditor (a<>b)+    defMethod "insertLeft" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) ox -> pure (snd (objConcat ox) <++ sl) >>= \sl -> return $+          (Just $ obj $ ListEditor sl, ListEditor sl)+      }+    defMethod "insertRight" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) ox -> pure (snd (objConcat ox) ++> sl) >>= \sl -> return $+          (Just $ obj $ ListEditor sl, ListEditor sl)+      }+    defMethod "cursorTo" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) ox -> predicate (_getIndex ox) >>= \i ->+          pure (slCursorTo i sl) >>= \sl -> return (deref sl, ListEditor sl)+      }+    defMethod "shift" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) ox -> predicate (_getIndex ox) >>= \i ->+          pure (slCursorShift i sl) >>= \sl -> return (deref sl, ListEditor sl)+      }+    defMethod "copy" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) -> _withRange "copy" $ \a b -> return $+          (Just $ obj $ ListEditor $ slCopyRelRange (a, b) sl, ListEditor sl)+      }+    defMethod "cut" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) -> _withRange "cut" $ \a b -> return $+          (Just $ obj $ ListEditor $ slCopyRelRange (a, b) sl, ListEditor $ slDeleteRelRange (a, b) sl)+      }+    defMethod "copyRange" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) -> _withRange "copyRange" $ \a b -> return $+          (Just $ obj $ ListEditor $ slCopyAbsRange (a, b) sl, ListEditor sl)+      }+    defMethod "cutRange" $+      daoFunc+      { daoForeignFunc = \ (ListEditor sl) -> _withRange "cut" $ \a b -> return $+          (Just $ obj $ ListEditor $ slCopyAbsRange (a, b) sl, ListEditor $ slDeleteAbsRange (a, b) sl)+      }+    defInfixOp ADD $ \ _ (ListEditor sl) ->+      xmaybe . fromObj >=> \ (ListEditor o) -> return (obj $ ListEditor $ sl <> o)+
+ src/Dao/PPrint.hs view
@@ -0,0 +1,358 @@+-- "src/Dao/PPrintM.hs"  a pretty-printer designed especially for+-- printing Dao script code.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Dao.PPrint where++import           Dao.String+import qualified Dao.Tree as T++import qualified Data.Map as M++import           Control.Monad.State++import           Data.List+import           Data.Char+import           Data.Monoid++----------------------------------------------------------------------------------------------------++-- | This is the function you will probably care about most: take a value of any data type that+-- instantiates 'PPrintable', and a maximum text-wrapping width value, and a tab string, and will+-- convert that value to a 'Prelude.String'.+prettyPrint :: PPrintable a => Int -> String -> a -> String+prettyPrint maxWidth tab = showPPrint maxWidth tab . pPrint++-- | Calls 'prettyPrint' with the default values @80@ for the text-wrapping width, and a tab string+-- consisting of four single-space characters (four ASCII @0x20@ characters).+prettyShow :: PPrintable a => a -> String+prettyShow = prettyPrint 80 "    "++----------------------------------------------------------------------------------------------------++-- | Remove trailing whitespace, I stole the idea from the Perl language.+chomp :: String -> String+chomp = foldl (\ out (spc, str) -> if null str then out else out++spc++str) "" . spcstr where+  spcstr cx = case cx of+    "" -> []+    cx -> (spc, str) : spcstr cx' where+      (spc, more) = span  isSpace cx+      (str, cx' ) = break isSpace more++-- | like 'Prelude.map', but doesn't touch the last item in the list.+mapAlmost :: (a -> a) -> [a] -> [a]+mapAlmost fn ax = case ax of+  [] -> []+  [a] -> [a]+  a:ax -> fn a : mapAlmost fn ax++-- | like 'Prelude.map', but doesn't touch the first item in the list.+mapTail :: (a -> a) -> [a] -> [a]+mapTail fn ax = case ax of+  []   -> []+  a:ax -> a : map fn ax++----------------------------------------------------------------------------------------------------++class PPrintable a where { pPrint :: a -> PPrintM () }+type PPrint = PPrintM ()++-- | Put a new line regardless of whether or not we are aleady on a new line.+pNewLine :: PPrint+pNewLine = modify $ \st ->+  st{ printerCol = 0+    , printerBuf = ""+    , printerOut = printerOut st ++ [printerOutputTripple st]+    , lineCount  = lineCount st + 1+    , printerTab = nextTab st+    }++-- | Like 'pNewLine' but also indicates that there *must* be a new line here (like after a comment)+-- to prevent lines from being joined.+pForceNewLine :: PPrint+pForceNewLine = modify (\st -> st{forcedNewLine=True})++-- | Place a new line unless we are already on a new line.+pEndLine :: PPrint+pEndLine = gets printerCol >>= \col ->+  if col==0 then modify (\st -> st{printerTab=nextTab st}) else pNewLine+    ++pIndent :: PPrint -> PPrint+pIndent indentedPrinter = do+  tab <- gets nextTab+  modify (\st -> st{nextTab=tab+1})+  indentedPrinter+  modify (\st -> st{nextTab=tab})++instance PPrintable ()   where { pPrint = return }+instance PPrintable UStr where { pPrint = pUStr }+instance PPrintable Name where { pPrint = pUStr . toUStr }+instance PPrintable t => PPrintable (T.Tree Name t) where+  pPrint t = case t of+    T.Void            -> pString "tree"+    T.Leaf       o    -> leaf o+    T.Branch       ox -> pList (pString "tree") "{ " ", " " }" (branch ox)+    T.LeafBranch o ox -> pList (leaf o) " { " ", " " }" (branch ox)+    where+      leaf o = pWrapIndent [pString "tree(", pPrint o, pString ")"]+      branch = map (\ (lbl, o) -> pMapAssoc (lbl, o)) . M.assocs++instance PPrintable Base16String where { pPrint = pShow }+instance PPrintable Base64String where { pPrint = pShow }++pMapAssoc :: (PPrintable a, PPrintable o) => (a, o) -> PPrint+pMapAssoc (a, o) = pWrapIndent [pPrint a, pString " = ", pPrint o]++-- not for export+appendString :: Int -> String -> PPrint+appendString len str = modify $ \st ->+  st{ printerCol = printerCol st + len+    , printerBuf = printerBuf st ++ str+    , charCount  = charCount  st + len+    }++-- | Print a 'Dao.String.UStr' as a single line.+pUStr :: UStr -> PPrint+pUStr u = if nil==u then return () else appendString (ulength u) (uchars u)++-- | Print a 'Prelude.String' as a single line.+pString :: String -> PPrint+pString s = if null s then return () else appendString (length s) s++-- | Print any value that instantiates 'Prelude.Show'.+pShow :: Show a => a -> PPrint+pShow = pString . show++-- | Shortcut for @('pPrint' . 'Data.List.concat')@+pConcat :: [String] -> PPrint+pConcat = pString . concat++-- | Just keep printing items along the line without wrapping until a 'pNewLine' or 'pEndLine'+-- occurs. Actually, this function simply a synonym for 'Control.Monad.sequence_'.+pNoWrap :: [PPrint] -> PPrint+pNoWrap = sequence_++-- | Try to print with the given function, but if the printed text runs past the 'maxWidth', or if+-- the printed text results in multiple lines of output, end the current line of text before+-- placing the text from the given function.+pWrap :: PPrint -> PPrint+pWrap fn = do+  st <- get+  let trySt = execState fn (subprint st)+  if printerCol st + charCount trySt > maxWidth st then pEndLine else return ()+  appendState trySt++-- | Evaluate the 'PPrintM' printer, and every line of output will be used as an item in a list and+-- printed across a line, wrapping on to the next line if the line goes past the width limit.+pInline :: [PPrint] -> PPrint+pInline = sequence_ . map pWrap++-- | Like 'pInline' but if the line wraps, every line after the first will be indented.+pWrapIndent :: [PPrint] -> PPrint+pWrapIndent px = do+  st <- get+  let trySt = execState (pInline px) (subprint st)+  case printerOut trySt of+    []   -> appendState trySt+    p:px ->+      let ind (tab, len, str) = (tab+1, len, str)+      in  appendState (trySt{printerOut = p : map ind px, printerTab = printerTab trySt + 1})++-- | Will evaluate a 'PPrintM' function to create a block of text, and if the block of text can be+-- fit into a single line, it will be placed inline with the text precceding and succeeding it.+-- If it cannot be placed into a single line, it will be preceeded and succeeded by a 'pEndLine'.+-- Passing 'Prelude.False' as the first parameter means 'pEndLine' will not succeed the block of+-- text, which can come in handy (for example) when you need to follow an item with a closing+-- punctuation mark like a comma or semicolon, and you don't want that closing punctuation on the+-- next line.+pGroup :: Bool -> PPrint -> PPrint+pGroup after fn = do+  st <- get+  let trySt = execState (pEndLine >> fn) (subprint st)+  if charCount trySt > maxWidth st || forcedNewLine trySt+    then  pEndLine >> appendState trySt >> (if after then pEndLine else return ())+    else  appendState (stateJoinLines trySt)++pList :: PPrint -> String -> String -> String -> [PPrint] -> PPrint+pList header open separator close px = do+  let sep = ustr separator+  pGroup False $ do+    header >> pString open >> pEndLine+    pIndent $ pInline $ map (pGroup True) $ mapAlmost (>>(pUStr sep)) px+    pEndLine >> pString close++-- | Like 'pList' but there is no need to pass the first @'PPrintM' ()@ header parameter, this+-- parameter is set to @'Prelude.return' ()@.+pList_ :: String -> String -> String -> [PPrint] -> PPrint+pList_ = pList (return ())++pClosure :: PPrint -> String -> String -> [PPrint] -> PPrint+pClosure header open close px = do+  st <- get+  let content = do+        header >> pString open >> pEndLine+        pIndent (sequence_ $ mapAlmost (>>pEndLine) px)+        pEndLine >> pString close+      trySt = execState content (subprint st)+  if charCount trySt + printerCol st > maxWidth st then pEndLine else return ()+  appendState trySt++-- | A commonly used pattern, like 'pClosure' but the contents of it is always a list of items which+-- can be pretty-printed by the given @(o -> 'PPrintM' ())@ function.+pContainer :: String -> (o -> PPrint) -> [o] -> PPrint+pContainer label prin ox = pList (pString label) "{ " ", " " }" (map prin ox)++----------------------------------------------------------------------------------------------------++type PPrintM a = State Printer a+type POutput = (Int, Int, UStr)++-- not for export+data Printer+  = Printer+    { printerTab    :: Int -- how many indentation marks should preceed this line+    , printerCol    :: Int -- how many non-indentation characters are in the buffer+    , printerOut    :: [POutput] -- all lines before the current line in the buffer+    , printerBuf    :: String -- buffers the current line+    , nextTab       :: Int+    , lineCount     :: Int -- how many lines have been printed+    , charCount     :: Int -- how many characters have been printed+    , maxWidth      :: Int+    , forcedNewLine :: Bool+    }++initPrinter :: Int -> Printer+initPrinter width =+  Printer+  { printerTab    = 0+  , printerCol    = 0+  , printerOut    = []+  , printerBuf    = ""+  , maxWidth      = width+  , lineCount     = 0+  , charCount     = 0+  , nextTab       = 0+  , forcedNewLine = False+  }++printerOutputTripple :: Printer -> (Int, Int, UStr)+printerOutputTripple st = (printerTab st, printerCol st, ustr (printerBuf st))++instance Monoid Printer where+  mempty = initPrinter 80+  mappend origSt st = case printerOut st of+    []                ->+      (combine origSt st)+      { printerBuf = printerBuf origSt ++ printerBuf st+      , printerCol = printerCol origSt +  printerCol st+      }+    (_, col, buf):out ->+      (combine origSt st)+      { printerOut = printerOut origSt +++          (printerTab origSt, printerCol origSt + col, ustr (printerBuf origSt ++ uchars buf)) : out+      , printerBuf = printerBuf st+      , printerCol = printerCol st+      }+    where+      combine origSt st = +        origSt+        { charCount     = charCount origSt + charCount st+        , lineCount     = lineCount origSt + lineCount st+        , maxWidth      = maxWidth  origSt+        , printerTab    = printerTab st+        , nextTab       = nextTab st+        , forcedNewLine = forcedNewLine origSt || forcedNewLine st+        }++-- | Force a string into the 'printerBuf' buffer without modifying anything else. This should allow+-- you to put markers into the output without effecting any of the metrics used to control how the+-- output is indented or wrapped.+pDebug :: (Printer -> String) -> PPrint+pDebug fn = do+  st <- get+  let msg = "["++fn st++"]"+  put (st{printerBuf=printerBuf st ++ seq msg msg})++stateJoinLines :: Printer -> Printer+stateJoinLines st =+  st{printerBuf = str ++ printerBuf st, printerCol = len + printerCol st, printerOut=[]} where+    (len, str) = foldl joinln (0, "") (printerOut st)+    joinln (len0, str0) (_, len1, str1) = (len0+len1, str0 ++ uchars str1)++appendState :: Printer -> PPrint+appendState = modify . flip mappend++-- | A kind of pre-conversion, the 'PPrintState' is broken into a list of strings, each string+-- preceeded by it's indentation factor.+linesFromPPrintState :: Int -> PPrint -> [(Int, String)]+linesFromPPrintState maxWidth ps = end (execState ps (initPrinter maxWidth)) where+  end st = flip map (printerOut st ++ [printerOutputTripple st]) $ \ (a, _, b) ->+    (a, dropWhile isSpace (chomp (uchars b)))++printAcross :: [PPrint] -> PPrint+printAcross px = case px of+  []   -> return ()+  p:px -> do+    st <- get+    st <- return (st{printerBuf = printerBuf st})+    let trySt = execState p (subprint st)+    if withinMaxWidth st trySt+      then put (mappend st trySt)+      else pEndLine >> modify (\st -> mappend st trySt)+    printAcross px++withinMaxWidth :: Printer -> Printer -> Bool+withinMaxWidth st trySt = null (printerOut trySt) && printerCol st + printerCol trySt <= maxWidth st++subprint :: Printer -> Printer+subprint st = st{printerBuf="", printerCol=0, printerOut=[], charCount=0, lineCount=0}++tabAll :: Bool -> [POutput] -> [POutput]+tabAll alsoTabFinalLine ax = case ax of+  []                 -> []+  [(tab, len, str)]  -> if alsoTabFinalLine then [(tab+1, len, str)] else [(tab, len, str)]+  (tab, len, str):ax -> (tab+1, len, str) : tabAll alsoTabFinalLine ax++-- | Given a list of strings, each prefixed with an indentation count, and an indentation string,+-- concatenate all strings into a one big string, with each string being indented and on it's own+-- line.+linesToString :: String -> [(Int, String)] -> String+linesToString indentStr = intercalate "\n" .+  map (\ (indentCount, content) -> concat (replicate indentCount indentStr) ++ content)++-- Given an indentation string and a maximum width value, construct a string from the 'PPrintState'.+-- The maximum width value is used to call 'linesFromPPrintState', and the indentation string is+-- used to call 'linesToString'.+showPPrint :: Int -> String -> PPrint -> String+showPPrint maxWidth indentStr ps = linesToString indentStr (linesFromPPrintState maxWidth ps)++----------------------------------------------------------------------------------------------------++-- | Statements like "if" or "while" take a condition, and the Dao languages does not require these+-- conditions be enclosed in parenthases. The question is, should there be a space after the "if" or+-- "while" statement? This function resolves that question by checking if an object expression+-- already is enclosed in parentheses, and if so, does not put a space. Otherwise, a space will be+-- printed between the "if" tag or "while" tag and the condition.+class PrecedeWithSpace a where { precedeWithSpace :: a -> Bool }+instance PrecedeWithSpace Name where { precedeWithSpace _ = True }+
+ src/Dao/Parser.hs view
@@ -0,0 +1,1927 @@+-- "src/Dao/Parser.hs"  a parser for defining general context-free+-- grammars that are parsed in two phases: the lexical and the+-- syntactic analysis phases.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++module Dao.Parser where++import           Dao.String+import           Dao.Token+import           Dao.Predicate+import qualified Dao.Interval  as Iv++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Cont+import           Control.Monad.State+import           Control.Monad.Error.Class++import           Data.Data+import           Data.Tuple+import           Data.Monoid+import           Data.Maybe+import           Data.Word+import           Data.Char  hiding (Space)+import           Data.List+import           Data.Array.IArray+import qualified Data.Map    as M++----------------------------------------------------------------------------------------------------+-- $Lexer_builder+-- When defining a computer language, one essential step will be to define your keywords and+-- operators, and define tokens for these keywords and operators.+--+-- However, it might be more convenient if there was a way to simply declare to your program "here+-- are my keywords, here are my operators, here is how you lex comments, here is how you lex white+-- spaces", stated simply using Haskell functions, and then let the token types be derived from+-- these declarations. The functions in this section intend to provide you with this ability.++-- | Here is class that allows you to create your own token type from a Haskell newtype, like so:+-- > newtype MyToken = MyToken{ unwrapMyToken :: TT }+-- > instance TokenType MyToken where+-- >     'wrapTT' = MyToken+-- >     'unwrapTT' = unwrapMyToken+-- > +-- > myTokenDB = 'makeTokenDB' $ do+-- >     ....+class (Ix a, Show a) => TokenType a where { wrapTT :: TT -> a; unwrapTT :: a -> TT; }+instance TokenType TT where { wrapTT = id; unwrapTT = id; }++-- | An actual value used to symbolize a type of token is a 'TT'. For example, an integer token+-- might be assigned a value of @('TT' 0)@ a keyword might be @('TT' 1)@, an operator might be+-- @('TT' 2)@, and so on. You do not define the numbers representing these token types, these+-- numbers are defined automatically when you construct a 'LexBuilderM'.+--+-- A 'TT' value is just an integer wrapped in an opaque newtype and deriving 'Prelude.Eq',+-- 'Prelude.Ord', 'Prelude.Show', and 'Data.Ix.Ix'. The constructor for 'TT' is not exported, so you+-- can rest assured any 'TT' objects in your program can only be generated during construction of a+-- 'LexBuilderM'.+-- +-- It is also a good idea to wrap this 'TT' type in your own newtype and define your parser over+-- your newtype, which will prevent you from confusing the same 'TT' type in two different parsers.+-- For example:+-- > newtype MyToken { myTokenTT :: TT }+-- > myLexer :: 'Lexer' MyToken ()+-- > myLexer = ...+-- If you instantiate your newtype into the 'TokenType' class, you can also very easily instantiate+-- 'Prelude.Read' and 'Prelude.Show' for your tokens.+newtype TT = MkTT{ intTT :: Int } deriving (Eq, Ord, Ix, Typeable)+instance Show TT where { show (MkTT tt) = "TT"++show tt }++-- Not for export, wouldn't want people making arbitrary 'TT's now, would we?+enumTTFrom :: TT -> TT -> [TT]+enumTTFrom (MkTT a) (MkTT b) = map MkTT [a..b]++-- | The data type constructed from the 'LexBuilderM' monad, used to build a 'Lexer' for your+-- programming language, and also can be used to define the 'Prelude.Show' instance for your token+-- type using 'deriveShowFromTokenDB'.+data TokenDB tok =+  TokenDB+  { tableTTtoUStr :: Array TT UStr+  , tableUStrToTT :: M.Map UStr TT+  , tokenDBLexer  :: Lexer tok ()+  }++-- | A state for the 'LexBuilderM' monad, used to declaring the regular expressions for a lexer. This+-- state is converted to a 'TokenDB' which is used by the parser to identify tokens.+-- > myTokens :: 'LexBuilderM'+-- > myTokens = do+-- >     let keyword = 'stringTable' . 'Prelude.unwords'+-- >     keyword "if then else case of let in where"+-- >     key "() == /= -> \\ : :: ~ @"+-- >     lexer "string.literal"  'lexStringLiteral'+-- >     lexer "comment.endline" 'lexEndlineC_Comment'+-- >     lexer "comment.inline"  'lexInlineC_Comment'+-- >     -- (The dots in the token type name do not mean anything, it just looks nicer.)+data LexBuilderState+  = LexBuilderState+    { regexItemCounter :: TT+    , stringToIDTable  :: M.Map UStr TT+      -- ^ contains all simple lexers which do not establish loops. This would be any lexer that+      -- takes a keyword or operator, or a lexer constructed from a 'Regex' (which might or might+      -- not loop) but produces only one kind of token.+    }++newtype LexBuilderM a = LexBuilderM{ runLexBuilder :: State LexBuilderState a }+type LexBuilder tok = LexBuilderM (Lexer tok ())++instance Monad LexBuilderM where+  return = LexBuilderM . return+  (LexBuilderM a) >>= b = LexBuilderM (a >>= runLexBuilder . b)+instance Functor     LexBuilderM where { fmap f (LexBuilderM m) = LexBuilderM (fmap f m) }+instance Applicative LexBuilderM where { pure = return; (<*>) = ap; }+instance Monoid a =>+  Monoid (LexBuilderM a) where { mempty = return mempty; mappend = liftM2 mappend; }++-- | This class exists to make 'emptyToken', 'fullToken', and 'activate' functions polymorphic over+-- two different types: the 'RegexBaseType's and 'Regex' and @['Regex']@ types.+class RegexType rx where { toRegex :: rx -> Regex }+instance RegexType  Char          where { toRegex = rx }+instance RegexType  String        where { toRegex = rx }+instance RegexType  UStr          where { toRegex = rx }+instance RegexType (Iv.Set Char)  where { toRegex = rx }+instance RegexType [Iv.Set Char]  where { toRegex = rx }+instance RegexType  Regex         where { toRegex = id }+instance RegexType [Regex]        where { toRegex = mconcat }+instance RegexType (Char, Char)   where { toRegex = rx }+instance RegexType [(Char, Char)] where { toRegex = rx }++-- example :: Regex+-- example = regex 'a' "hello" ('0', '9')++-- not for export+initLexBuilder :: LexBuilderState+initLexBuilder = LexBuilderState (MkTT 1) mempty++-- not for export+newTokID :: UStr -> State LexBuilderState TT+newTokID u = do+  tok <- fmap (M.lookup u) (gets stringToIDTable)+  case tok of+    Nothing  -> do+      tok <- gets regexItemCounter+      modify $ \st ->+        st{ regexItemCounter = MkTT (intTT tok + 1)+          , stringToIDTable = M.insert u tok (stringToIDTable st)+          }+      return tok+    Just tok -> return tok++-- not for export+makeRegex :: RegexType rx => Bool -> UStr -> rx -> LexBuilderM Regex+makeRegex keep u re = LexBuilderM $ newTokID u >>= \tok ->+  return (toRegex re . (if keep then rxToken else rxEmptyToken) tok)++-- | The 'tokenHold' function creates a token ID and associates it with a type that is used to+-- construct a 'Regex', and returns the 'Regex' to the 'LexBuilderM' monad. However this does not+-- actually 'activate' the 'Regex', it simply allows you to use the returned 'Regex' in more+-- complex expressions that might construct multiple tokens. You can 'tokenHold' expressions in any+-- order, ordering is not important.+fullToken :: (UStrType str, RegexType rx) => str -> rx -> LexBuilderM Regex+fullToken s = makeRegex True (toUStr s)++-- | 'token' has identical behavior as 'tokenHold', except the 'Regex' created will produce an empty+-- token, that is, a token that only indicates it's type and contains none of the string that+-- matched the regular expression. This can be done when it is clear (or you do not care) what+-- string was lexed when the token was created just by knowing the type of the token, for example+-- whitespace tokens, or keyword tokens which have the text used to create the token easily+-- retrievable by converting token to a string. Making use of 'token' can greatly improveme+-- performance as compared to using 'tokenHold' exclusively.+emptyToken :: (UStrType str, RegexType rx) => str -> rx -> LexBuilderM Regex+emptyToken s = makeRegex False (toUStr s)++-- | Activating a regular expression actually converts the regular expression to a 'Lexer'. The+-- /order of activation is important/, expressions that are defined first will have the first try at+-- lexing input strings, followed by every expression activated after it in order. It is also NOT+-- necessary to define an expression with 'regex' or 'regexHold' before activating it, however+-- expressions that have not been associated with a token type will simply consume input without+-- producing any tokens. This might be desireable for things like whitespace, but it is usually not+-- what you want to do.+activate :: (TokenType tok, RegexType rx) => rx -> LexBuilder tok+activate = return . regexToLexer . toRegex++-- | An array of tokenizers with every tokenizer indexed by the very first character they accept.+data LexTable lexFunc+  = LexNoTable{ lexFinal :: lexFunc }+  | LexTable{ lexTableArray :: Array Char (lexFunc), lexFinal :: lexFunc }++-- | Create a 'LexTable' array with the given list of 'Regex's, the indecies of the array created+-- are determined by the lowest and highest possible characters that of all of the 'Regex's you+-- provide. If your parser works with UTF characters beyond the ASCII range, the arrays can get+-- pretty big if you are not careful. Try to group parsers together that are near each other in the+-- UTF table, which involves making sure the 'Prelude.Int' value returned by 'Data.Char.ord' for the+-- characters that the tokenizer can match are all near each other on the number line. If your+-- parser only works on ASCII characters, you have nothing to worry about, your tokenizer array will+-- not be larger than 128 indecies.+makeRegexTable :: RegexType rx => rx -> LexTable Regex+makeRegexTable regex = case regexToLexerPairs (toRegex regex) of+  ([]   , final) -> LexNoTable final+  (elems, final) -> LexTable (accumArray mappend mempty bounds elems) final where+    bounds  = foldl (\ (lo, hi) c -> (min lo c, max hi c)) (initIdx, initIdx) (map fst elems)+    initIdx = fst (head elems)++lexTableRegexToLexer :: TokenType tok => LexTable Regex -> LexTable (Lexer tok ())+lexTableRegexToLexer table = case table of+  LexNoTable     regex -> LexNoTable (regexToLexer regex)+  LexTable table regex -> LexTable (amap regexToLexer table) (regexToLexer regex)++makeLexTable :: (TokenType tok, RegexType rx) => rx -> LexTable (Lexer tok ())+makeLexTable = lexTableRegexToLexer . makeRegexTable++lexTableToLexer :: TokenType tok => LexTable (Lexer tok ()) -> Lexer tok ()+lexTableToLexer table = case table of+  LexNoTable     final -> final+  LexTable table final -> do+    cx <- gets lexInput+    case cx of+      []  -> mzero+      c:_ -> if inRange (bounds table) c then table!c else final++-- | If you don't care about the 'LexTable' value but want to convert the 'Regex' to a 'Lexer' using a+-- 'LexTable', use this function. The array will be allocated in memory and used to perform lexing,+-- but your code will never see a reference to the 'LexTable' as it is passed directly to+-- 'lexTableToLexer'. This function is defined as:+-- > 'lexTableToLexer' . 'lexTableRegexToLexer' . 'makeRegexTable'+regexToTableLexer :: (RegexType rx, TokenType tok) => rx -> Lexer tok ()+regexToTableLexer = lexTableToLexer . lexTableRegexToLexer . makeRegexTable++-- | Once you have defined your 'LexBuilderM' function using monadic notation, convert the value of+-- this function to a 'TokenDB' value. The 'TokenDB' is mostly handy for retreiving the string+-- values associated with each token ID created by the 'newTokenType' function, for example when+-- using 'dervieShowFromTokenDB' which uses a 'TokenDB' to produce a function suitable for+-- instantiating your @'TokenType'@ into the 'Prelude.Show' class.+makeTokenDB :: TokenType tok => LexBuilderM (Lexer tok ()) -> TokenDB tok+makeTokenDB builder =+  TokenDB+  { tableTTtoUStr = array (MkTT 1, regexItemCounter st) $+      fmap swap $ fmap (fmap unwrapTT) $ M.assocs tabmap+  , tokenDBLexer  = mplus (void (many lexer)) (return ())+  , tableUStrToTT = tabmap+  }+  where+    tabmap = stringToIDTable st+    (lexer, st) = runState (runLexBuilder builder) $+      LexBuilderState{regexItemCounter=MkTT 1, stringToIDTable=mempty}++-- | This function lets you easily "derive" the instance for 'Prelude.Show' for a given 'TokenType'+-- associated with a 'TokenDB'. It should be used like so:+-- > newtype MyToken = MyToken{ unwrapMyToken :: TT }+-- > instance 'TokenType' MyToken where{ wrapTT = MyToken; unwrapTT = unwrapMyToken; }+-- > instance 'Prelude.Show' MyToken where{ show = 'deriveShowFromTokenDB' myTokenDB }+-- > myTokenDB :: 'TokenDB' MyToken+-- > myTokenDB = 'makeTokenDB' $ ....+deriveShowFromTokenDB :: TokenType tok => TokenDB tok -> tok -> String+deriveShowFromTokenDB tokenDB tok =+  let str = uchars (tableTTtoUStr tokenDB ! unwrapTT tok)+  in  if or (map (not . isAlphaNum) str) then show str else str++tokTypeToUStr :: (TokenType tok, HasTokenDB tok) => tok -> UStr+tokTypeToUStr tok =+  let arr = (tableTTtoUStr (tokenDBFromToken tok))+      tt  = unwrapTT tok+  in  if inRange (bounds arr) tt+        then  arr!tt+        else  error ("no registered identifier "++show tt++" in tokenDB")++tokTypeToString :: (TokenType tok, HasTokenDB tok) => tok -> String+tokTypeToString = uchars . tokTypeToUStr++tokenToUStr :: (TokenType tok, HasTokenDB tok) => TokenAt tok -> UStr+tokenToUStr tok = case asToken tok of+  EmptyToken t   -> tokTypeToUStr t+  CharToken  _ c -> ustr [c]+  Token      _ u -> u++tokenToString :: (TokenType tok, HasTokenDB tok) => TokenAt tok -> String+tokenToString tok = case asToken tok of+  EmptyToken t   -> uchars (tokTypeToUStr t)+  CharToken  _ c -> [c]+  Token      _ u -> uchars u++-- | Get token from a 'TokenDB' that was associated with the 'Dao.String.UStrType'.+maybeLookupToken :: (UStrType str, TokenType tok) => TokenDB tok -> str -> Maybe tok+maybeLookupToken tokenDB = fmap wrapTT . flip M.lookup (tableUStrToTT tokenDB) . toUStr++-- | Like 'maybeLookupToken' but evaluates to 'Prelude.error' if no such token was defined.+lookupToken :: (UStrType str, TokenType tok) => TokenDB tok -> str -> tok+lookupToken tokenDB str =+  fromMaybe (error $ "internal: token "++show (toUStr str)++" was never defined") $+    maybeLookupToken tokenDB str++mk_keyword :: UStrType str => Regex -> str -> LexBuilderM (UStr, TT)+mk_keyword regex key = do+  let ukey = toUStr key+      keyChars = uchars ukey+  if fst (runRegex regex keyChars :: (Bool, ([TokenAt TT], String)))+    then  LexBuilderM (newTokID ukey) >>= return . (,) ukey+    else  error ("keyword token "++show keyChars++"does not match it's own keyword Regex")++-- | Create a single keyword 'Regex'. 'Control.Monad.mapM'-ing over this function is not the same as+-- using 'keywordTable', 'keywordTable' creates an actual table when evalauting to a 'Lexer'. This+-- function creates no table, it will simply evaluate to a lexer that returns a token of the keyword+-- type if the keyword matches the input, or else it returns the default token type.+keyword :: (UStrType str, UStrType key) => str -> Regex -> key -> LexBuilderM Regex+keyword deflt regex key = do+  deflt      <- LexBuilderM (newTokID (toUStr deflt))+  (ukey, tt) <- mk_keyword regex key+  return (regex . rxMakeToken (\str -> if ustr str==ukey then (False, tt) else (True, deflt)))++-- | To construct a keyword table, you must provide three parameters: the first two are a default+-- 'TokenType' and a 'Regex' used to split non-keyword words out of the character stream. The third+-- parameter is a list of keywords strings. Every keyword string will become it's own token type.+-- The resultant 'Regex' will, when evaluated as a 'Lexer', first try to split a non-keyword string+-- off of the stream. But if that string matches a keyword, a keyword token of it's own type is+-- emitted. Otherwise, it will emit a non-keyword token of the 'TokenType' given here. Keyword+-- tokens are empty, non-keyword contain the characters that matched the regex.+--+-- A common way to use this function is with the 'Data.List.words' function:+-- > 'keywordTable' MyVarNameType ('rx' ('from' @'@a@'@ 'to' @'@z@'@)) $+-- >     'Data.List.words' $ 'Data.List.unwords' $ +-- >         [ "while for if then else goto return break continue"+-- >           "class instance new delete super typeof" ]+keywordTable :: (UStrType str, UStrType key) => str -> Regex -> [key] -> LexBuilderM Regex+keywordTable deflt regex keys = do+  deflt   <- LexBuilderM (newTokID (toUStr deflt))+  keyDict <- fmap M.fromList (forM keys (mk_keyword regex))+  return (regex . rxMakeToken (maybe (True, deflt) ((,) False) . flip M.lookup keyDict . ustr))++-- | Creates a token type with 'regex' where the text lexed from the input is identical to name of+-- the token. The difference between an operator and a keyword is that operators will be lexed+-- regardless of the characters following it in the stream, which means if you have an operator "op"+-- and the next characters in the stream are @"open()"@, then the lexical analysis will split this+-- into @["op", "en()"]@, the remainder @"en()"@ characters must be lexed by some other lexer,+-- and @"op"@ will be treated as a single operator token. Keywords do not work this way.+operator :: UStrType str => str -> LexBuilderM Regex+operator str = do+  let u = toUStr str+  case ulength u of+    0 -> return id+    1 -> makeRegex False u (head (uchars u))+    _ -> makeRegex False u u++-- | Creates a 'TokenTable' using a list of keywords or operators you provide to it. Use this+-- function to ensure operators do not interfear with each other. For example, if you have two+-- operators @"=="@ and @"="@, the lexer must try to split the @"=="@ operator from the stream+-- before it tries splitting @"="@. This function ensures that the order in which operators are+-- tried is the correct order.+-- +-- Every string provided becomes it's own token type. For example:+-- > myKeywords = 'tokenTable' $ 'Data.List.words' $ 'Data.List.unwords' $+-- >     [ "** * / % + - & | ^",+-- >       "= *= /= %= += -= &= |= ^=",+-- >       "== != <= >= < >" ]+operatorTable :: UStrType str => [str] -> LexBuilderM Regex+operatorTable = fmap mconcat . mapM operator .+  sortBy (\a b -> compare (ulength b) (ulength a)) . map toUStr++-- | Retrieve a 'TokenType' from a 'UStrType' (or a subclass of 'UStrType' like 'MetaToken') value.+-- This is necesary for building tokenizing regular expressions that are more complicated than a+-- typeical keyword or operator. You must declare in the 'Regex' when to create a token from the+-- given token types returned to the 'LexBuilderM' monad by this function.+getTokID :: (UStrType tokID, TokenType tok) => tokID -> LexBuilderM tok+getTokID tokID = fmap wrapTT (LexBuilderM (newTokID (toUStr tokID)))++----------------------------------------------------------------------------------------------------+-- $Regular_expressions+-- Provides a very simple data type for constructing expressions that can match strings. This type+-- is used in a 'LexBuilderM' to and are associated with token types such than when the 'LexBuilderM'+-- is converted to a 'Lexer', a token of the associated type is generated when a regex matches+-- the beginning of the input string that is being lexically analyzed.++-- | Any function with a type @'RegexUnit' -> 'RegexUnit'@ or 'Regex' can be used in a+-- dot-operator-separated sequence of expressions. But the 'rx' function provided by this class+-- introduces a kind of constant expression that can be used in sequences of 'RegexUnit's. For+-- example, suppose you have defined a regular expression @digit@ of type+-- @'RegexUnit' -> 'RegexUnit'@ to match an arbitrarily long sequence of numeric characters, and a+-- regular expression @space@ of type 'Regex' to match an arbitrarily long sequence of whitespace+-- characters. You could then define a regular expression with a sequence like so:+-- > myRegex :: Regex+-- > myRegex = 'rx' "first" . space . digit . space . 'rx' "second" . space . digit+-- Here, we take advantage of the fact that 'Prelude.String' is instnatiated into the+-- 'RegexBaseType' class, because this allows us to write @'rx' "first"@ and @'rx' "second"@, which+-- will match the strings "first" and "second" if they occur in the input string to be matched. This+-- expression is equivalent to the POSIX regular expression+-- @first[[:space:]]+[[:digit:]]+[[:space:]]+second[[:space:]]+[[:digit:]]+@+-- which would match strings like the following:+-- > "first 1231 second 99"+-- > "first    0          second      1233491202"+-- +-- /To create a choice/ you can use 'Data.Monoid.mappend', 'Data.Monoid.mconcat', or the infix+-- operator equivalent of 'Data.Monoid.mappend', which is 'Data.Monoid.<>'. The reason is,+-- 'Data.Monoid.Monoid' instantiates functions of type @a -> b@, and this provides a default+-- instnatiation for functions of type 'Regex'. For example,+-- suppose you have two regular expressions, @regexA@ and @regexB@. If you want to construct a+-- 'Regex' that tries matching @regexA@, and if it fails, then tries @regexB@, you would write:+-- > matchAorB = regexA 'Data.Monoid.<>' regexB+-- You can use 'Data.Monoid.concat' to create larger choices:+-- > 'Data.Monoid.mconcat' ['rx' "tryThis", 'rx' "thenThis", regexA, regexB]+-- or equivalently:+-- > 'rx' 'Data.Monoid.<>' "tryThis" 'Data.Monoid.<>' 'rx' "thenThis" 'Data.Monoid.<>' regexA 'Data.Monoid.<>' regexB+-- +-- Another advantage of 'Regex' being a function of type @'RegexUnit' -> 'RegexUnit'@ is that any+-- function of the type @a -> a@ can easily be used with the 'Prelude.fix' function to create loops,+-- for example, to lex an arbitrarily long sequence of numbers separated by spacecs:+-- > do space  <- 'newTokenType' "SPACE"+-- >    number <- 'newTokenType' "NUMBER"+-- >    'regex' $ 'Prelude.fix' $ \loop ->+-- >        ('rxRepeat1'('ch' ' ') . 'rxEmptyToken' space 'Data.Monoid.<>' 'rxRepeat1'('from' '0' 'to' '9') . 'rxToken' number) . loop+type Regex = RegexUnit -> RegexUnit++-- Not for export, this is a type used in the 'RxMakeToken' constructor, it is a basically a data+-- representing a function that can convert a string to a 'TT', but could be a constant function.+data MakeToken = MakeToken (String -> (Bool, TT)) | ConstToken Bool TT+instance Eq MakeToken where+  ConstToken kA ttA == ConstToken kB ttB = kA==kB && ttA==ttB+  _                 == _                 = False+instance Show MakeToken where+  show (ConstToken kA ttA) = (if kA then "full " else "empty ")++show ttA+  show _                   = "MakeToken"++evalMakeToken :: TokenType tok => MakeToken -> String -> Lexer tok ()+evalMakeToken mkt withStr = (if keep then makeToken else makeEmptyToken) (wrapTT tt) where+  (keep, tt) = case mkt of+    ConstToken keep tt -> (keep, tt)+    MakeToken  make    -> make withStr++-- | This is an intermediate type for constructing 'Regex's. You will not be using it directly. You+-- will instead use any function that evaluates to a 'Regex', which is a function of this data type.+data RegexUnit+  = RxBacktrack+  | RxSuccess+  | RxChoice   { getSubRegexes :: [RegexUnit] }+  | RxStep     { rxStepUnit    :: RxPrimitive , subRegex :: RegexUnit }+  | RxExpect   { rxErrMsg      :: UStr        , subRegex :: RegexUnit }+  | RxDontMatch{                                subRegex :: RegexUnit }+  | RxMakeToken{ rxMakeFunc    :: MakeToken   , subRegex :: RegexUnit }+  deriving Eq+instance Show RegexUnit where+  show rx = loop rx where+    loop rx = case rx of+      RxBacktrack     -> "RxBacktrack"+      RxSuccess       -> "RxSuccess"+      RxChoice      c -> "RxChoice "++show c+      RxStep      p _ -> "RxStep ("++showRegexPrim p++") ..."+      RxExpect    e _ -> "RxExpect "++show e++" ..."+      RxDontMatch   _ -> "RxDontMatch ..."+      RxMakeToken t _ -> "RxMakeToken ("++show t++") ..."+instance Show (RegexUnit -> RegexUnit) where { show rx = show (rx RxSuccess) }+instance Monoid RegexUnit where+  mempty = RxBacktrack+  mappend a b = case a of+    RxBacktrack        -> b+    RxSuccess          -> a+    RxExpect    _   _  -> a+    RxStep      a'  ax -> case b of+      RxStep      b'  bx -> if a' == b' then RxStep a' (ax<>bx) else RxChoice [a,b]+      b                  -> RxChoice [a,b]+    RxDontMatch    ax  -> case b of+      RxDontMatch    bx  -> RxDontMatch (ax<>bx)+      b                  -> RxChoice [a,b]+    RxChoice       ax  -> case b of+      RxChoice       bx  -> reduce (loop ax bx)+      b                  -> reduce (loop ax [b])+    RxMakeToken ta ax -> case b of+      RxMakeToken tb bx | ta==tb -> RxMakeToken ta (ax<>bx)+      b                          -> RxChoice [a,b]+    where+      reduce list = case list of+        []     -> RxBacktrack+        [item] -> item+        list   -> RxChoice list+      loop ax bx = case ax of+        []   -> bx+        [a]  -> case bx of+          []   -> [a]+          b:bx -> case a<>b of+            RxChoice ax -> ax++bx+            b           -> b : loop ax bx -- NEEDS TO BE TESTED, changed from (a:b:ax)+        a:ax -> a : loop ax bx++-- | Convert a 'Regex' function to a 'Lexer'. The resulting 'Lexer' will not call 'makeToken' or+-- 'makeEmptyToken', it will only match the beginning of the input string according to the 'Regex',+-- leaving the matched characters in the 'lexBuffer'.+-- +-- /BUG FIX:/ 'regexToLexer' should be distributive over 'Data.Monoid.mappend'ed 'Regex's, i.e the+-- statement:+-- > 'regexToLexer' (regex1 'Data.Monoid.<>' regex2)+-- should be identical to:+-- > 'regexToLexer' regex1 'Data.Monoid.<>' 'regexToLexer' regex2+-- however I have discovered that this is not the case for all possible 'Regex's. I need to write a+-- QuickCheck test to figure out why and correct this problem.+regexToLexer :: TokenType tok => Regex -> Lexer tok ()+regexToLexer re = loop (re RxSuccess) where+  loop re = case re of+    RxBacktrack       -> lexBacktrack+    RxSuccess         -> return ()+--  RxMakeToken tt re -> gets lexBuffer >>= evalMakeToken tt >> loop re+    RxMakeToken tt re -> case re of+      RxMakeToken tt re -> loop (RxMakeToken tt re)+      _                 -> gets lexBuffer >>= evalMakeToken tt >> loop re+        -- if there are two 'RxMakeToken's in a row, use the later one. This makes for more+        -- intuitive regular expressions. -- TODO, maybe lets not do this.+    RxChoice       re -> msum $ map loop re+    RxStep    r    re -> do+      keep <- gets lexBuffer+      clearBuffer+      mplus (regexPrimToLexer r >> modify (\st -> st{lexBuffer = keep ++ lexBuffer st}))+            (modify (\st -> st{lexBuffer=keep, lexInput = lexBuffer st ++ lexInput st}) >> mzero)+      loop re+    RxExpect  err  re -> mplus (loop re) (fail (uchars err))+    RxDontMatch    re -> case re of+      RxDontMatch    re -> loop re -- double negative means succeed on match+      re                -> do+        keep <- gets lexBuffer+        matched <- clearBuffer >> mplus (loop re >> return True) (return False)+        if matched+          then  do -- fail if matched+            modify $ \st ->+              st{ lexBuffer = ""+                , lexInput  = keep ++ lexBuffer st ++ lexInput st+                }+            mzero+          else  do -- success if not matched+            modify $ \st ->+              st{ lexBuffer = keep+                , lexInput  = lexBuffer st ++ lexInput st+                }+            return ()++-- Evaluate a 'Regex' to a 'Lexer' using 'regexToLexer', but also create a list of pairs, every pair+-- containing a character in the set of characters that this 'Regex' accepts. So, for example, if+-- the 'Regex' passed to this function is created from an 'Dao.Interval.EnumSet' with characters from+-- @a@ to @z@, this function will evaluate to a list of 26 pairs with every character from @a@ to+-- @z@ as the first element and the 'Lexer' as the second element. Every pair has the exact same+-- lexer function. This function returns 'Data.Maybe.Nothing' if the 'Regex' given does not evaluate+-- to a 'RxChoice' or 'RxStep' regex.+-- +-- Evaluates to a pair, the first element being a list of paris mapping characters to lexers, the+-- second being the lexers which cannot be mapped to characters but should be tried if any of the+-- character lexers backtrack. Lexers that cannot be mapped to characters but occur in the middle of+-- the list of 'RegexUnit's list are bunched together and prepended to the lexers that can be mapped+-- to characters.+regexToLexerPairs :: Regex -> ([(Char, Regex)], Regex)+regexToLexerPairs regex = case regex RxSuccess of+  RxChoice  [] -> (mzero, mempty)+  RxChoice [r] -> regexToLexerPairs (const r)+  RxChoice  rx -> loop mempty [] (flatten rx)+  RxStep  p r  -> loop mempty [] [RxStep p r]+  _            -> (mzero, mempty)+  where+    flatten = concatMap $ \r -> case r of+      RxChoice rx -> flatten rx+      r           -> [r]+    done pre stk = (stk, const pre)+    loop :: RegexUnit -> [(Char, Regex)] -> [RegexUnit] -> ([(Char, Regex)], Regex)+    loop pre stk rx = case rx of+      []   -> done pre stk+      r:rx -> case r of+        RxSuccess     -> done (pre<>RxSuccess) stk+        RxBacktrack   -> loop pre stk rx+        RxStep p _ -> loopStep r p where+          loopStep r p = case p of+            RxDelete         -> loop (pre<>r) stk rx+            RxString  u      -> case uchars u of+              ""  -> done (pre<>RxSuccess) stk+              c:_ -> loop mempty (create pre stk [c] r) rx+            RxCharSet cs     -> case Iv.elems cs of+              [] -> loop pre stk rx+              cx -> loop mempty (create pre stk cx r) rx+            RxRepeat _  _  p -> loopStep r p+        r             -> loop (pre<>r) stk rx+    create pre stk cx r = let fn = const (pre<>r) in stk ++ map (\c -> (c, fn)) cx++-- Not for export+data RxPrimitive+  = RxDelete+  | RxString   { rxString   :: UStr }+  | RxCharSet  { rxCharSet  :: Iv.Set Char }+  | RxRepeat   { rxLowerLim :: Iv.Inf Int, rxUpperLim :: Iv.Inf Int, subRegexUnit :: RxPrimitive }+  deriving Eq++showRegexPrim :: RxPrimitive -> String+showRegexPrim re = case re of+  RxDelete           -> "(delete)"+  RxString       str -> show str+  RxCharSet      ch  -> show ch+  RxRepeat lo hi re  -> "repeat("++show lo++".."++show hi++", "++showRegexPrim re++")"++regexPrimToLexer :: TokenType tok => RxPrimitive -> Lexer tok ()+regexPrimToLexer re = case re of+  RxDelete          -> clearBuffer+  RxString  str     -> lexString (uchars str)+  RxCharSet set     -> lexCharP (Iv.member set)+  RxRepeat lo hi re -> rept lo hi re+  where+    rept lo hi re = fromMaybe (seq (error "internal error") $! return ()) $ do+      getLo <- mplus (Iv.toPoint lo >>= return . lowerLim re) (return (return ()))+      getHi <- mplus (Iv.toPoint hi >>= return . upperLim re) (return (noLimit re))+      return (getLo >> mplus getHi (return ()))+    lowerLim re lo = case re of+      RxDelete            -> clearBuffer+      RxString  str       -> lowerLimLex lo (lexString (uchars str))+      RxCharSet set       -> do+        keep <- gets lexBuffer+        clearBuffer >> lexWhile (Iv.member set)+        got <- gets lexBuffer+        if length got < lo+          then  do+            modify (\st -> st{lexInput = keep ++ got ++ lexInput st, lexBuffer = ""})+            mzero+          else  modify (\st -> st{lexBuffer = keep ++ got})+      RxRepeat lo' hi' re -> lowerLimLex lo (rept lo' hi' re)+    lowerLimLex lo lex = replicateM_ lo lex+    upperLim re hi = case re of+      RxDelete            -> clearBuffer+      RxString  str       -> replicateM_ hi (lexString (uchars str))+      RxCharSet set       -> lexWhile       (Iv.member set)+      RxRepeat lo' hi' re -> replicateM_ hi (rept lo' hi' re)+    noLimit re = case re of+      RxDelete            -> clearBuffer+      RxString  str       -> forever  (lexString (uchars str))+      RxCharSet set       -> lexWhile (Iv.member set)+      RxRepeat lo  hi  re -> forever  (rept lo hi re)++-- | Any type which instantiates the 'RegexBaseType' class can be used to with the 'rx' function to+-- construct a part of a 'Regex' which can be used in a sequence of 'Regex's.+--+-- Probably the most useful instance of this class apart from that of 'Prelude.String' is the+-- instance for the type @['Dao.Interval.Set' 'Data.Char.Char']@, which allows you to union ranges of+-- character sets like so:+-- > 'rx'['from' '0' 'to' '9', from @'A'@ 'to' @'Z'@, 'from' '@a@' 'to' '@z@', 'ch' '@_@']+-- which would be equivalent to the POSIX regular expression @[0-9A-Za-z_]@, a regular expression+-- that matches any single alphabetic, numeric, of underscore character.+class RegexBaseType t where+  rxPrim :: t -> RxPrimitive+  rx :: t -> Regex+  rx = RxStep . rxPrim+instance RegexBaseType  Char          where { rxPrim = RxCharSet . Iv.point }+instance RegexBaseType  String        where { rxPrim = RxString  . ustr     }+instance RegexBaseType  UStr          where { rxPrim = RxString  }+instance RegexBaseType (Iv.Set Char)  where { rxPrim = RxCharSet }+instance RegexBaseType [Iv.Set Char]  where { rxPrim = RxCharSet . foldl Iv.union mempty }+instance RegexBaseType (Char, Char)   where { rxPrim = RxCharSet . Iv.fromPairs . (:[]) }+instance RegexBaseType [(Char, Char)] where { rxPrim = RxCharSet . Iv.fromPairs }++-- | The type of the 'from' and 'to' functions are specially defined so that you can write ranges of+-- characters. For example, if you want to match upper-case characters, you would simply write:+-- > from 'A' to 'Z'+-- or equivalently:+-- > 'A' `to` 'Z'+-- but I prefer to use 'from' because the use of single quotes and back-quotes together in the same+-- expression is tedius. This would be equivalent to the POSIX regular expressions: @[A-Z]@+from :: Char -> (Char -> Char -> Iv.Set Char) -> Char -> Iv.Set Char+from a to b = to a b++-- | The type of the 'from' and 'to' functions are specially defined so that you can write ranges of+-- characters. For example, if you want to match upper-case characters, you would simply write:+-- > from 'A' to 'Z'+-- or equivalently:+-- > 'A' `to` 'Z'+-- but I prefer to use 'from' because the use of single quotes and back-quotes together in the same+-- expression is tedius. This would be equivalent to the POSIX regular expressions: @[A-Z]@+to :: Char -> Char -> Iv.Set Char+to toch frch = Iv.range frch toch++-- | Create a character set that matches only a single character. For example if you want to match+-- just a single lowercase letter-A character:+-- > ch 'a'+-- This would b equivalent to the POSIX regular expression @[a]@+-- Be careful not to confuse this function with the 'rx' function, which is instantiated to create+-- 'Regex' functions from 'Prelude.Char's. The expression @'rx' @'@@a@@'@ cannot be used in a+-- set of other @'Dao.Interval.Set' 'Prelude.Char'@ types to create a larger set:+-- > badRegex = 'repeat' ['from' '0' 'to' '9', 'rx' @'@.@'@] -- /COMPILE-TIME ERROR!!!/+-- >+-- > -- This matches strings ending in dots, like "98765.", "123.", and "0."+-- > -- but does not match "0.0" or ".123"+-- > numberEndingWithDot 'repeat' ['from' '0' 'to' '9'] . 'rx' '.' +-- >+-- > -- This matches strings like "0.0.0.0", "123.", ".99", "...", "0.0" and "1..20"+-- > dotsOrDigits = 'repeat' ['from' '0' 'to' '9', 'ch' '.']+-- This function is also useful with the 'Prelude.map' function to create a set of characters from a+-- 'Prelude.String':+-- > stringOfVowels = 'rxRepeat' ('Prelude.map' 'ch' "AEIOUaeiou")+ch :: Char -> Iv.Set Char+ch = Iv.point++-- | Produces a character set that matches any character, like the POSIX regular expression dot+-- (@.@). /NEVER use this in a 'rxRepeat' function/ unless you really want to dump the entire+-- remainder of the input string into the 'lexBuffer'.+anyChar :: Iv.Set Char+anyChar = Iv.whole++-- | Invert a character set: this 'Regex' will match any characters not in the union of the sets+-- provided.+invert :: [Iv.Set Char] -> Iv.Set Char+invert = Iv.invert . foldl Iv.union mempty++-- | An optional regex, tries to match, but succeeds regardless of whether or not the given+-- actually matches. In fact, this 'Regex' is exactly identical to the equation:+-- > \regex -> regex 'Data.Monoid.<>' 'Prelude.id'+opt :: Regex -> Regex+opt = (<>id)++-- | This 'Regex' matches nothing and succeeds, and deletes any 'Regex' appended to it with the dot+-- operator. Any 'Regex' occurring after a 'halt' will not be evaluated.+halt :: Regex+halt = const RxSuccess++-- | Marks a point in a 'Regex' sequence where the matching must not fail, and if it does fail, the+-- resulting 'Lexer' to which this 'Regex' evaluates will evaluate to 'Control.Monad.fail' with an+-- error message provided as a paramater to this function. For example:+-- > decimalPoint = digits . 'rx' '.' . 'cantFail' "must have digits after a decimal point" . digits+cantFail :: String -> Regex+cantFail msg = RxExpect (ustr msg)++-- | This is a look-ahead 'Regex' that matches if the 'Regex' parameter provided does not match. An+-- extremely inefficient function, you should avoid using it and consider re-designing your+-- 'LexBuilderM' if you rely on this function too often. This function is designed to occur only at+-- the end of your 'Regex', that is, every 'Regex' that occurs after 'rxDont' is part of the 'Regex'+-- to not match. For example:+-- > myRegex = 'rx' "else" . spaces . 'rxDont' . 'rx' "if" . spaces . rx "end"+-- will succeed only if the string else is not followed by a string @"if end"@. There is no way to+-- make the 'Regex' first check if the next string is not @"if"@ and if it is not then continue+-- matching with @spaces@ and @'rx' "end"@ after that.+dont :: Regex+dont = RxDontMatch++-- | Clear the 'lexBuffer' without creating a token, effectively deleting the characters from the+-- input stream, ignoring those characters.+rxClear :: Regex+rxClear = RxStep RxDelete++-- | Force an error to occur.+rxErr :: String -> Regex+rxErr msg = cantFail msg . mempty++-- | Repeat a regular 'RegexBaseType' regular expression a number of times, with the number of times+-- repeated being limited by an upper and lower bound. Fails to match if the minimum number of+-- occurences cannot be matched, otherwise continues to repeat as many times as possible (greedily)+-- but not exceeding the upper bound given.+rxLimitMinMax :: RegexBaseType rx => Int -> Int -> rx -> Regex+rxLimitMinMax lo hi = RxStep . RxRepeat (Iv.Finite lo) (Iv.Finite hi) . rxPrim++-- | Repeats greedily, matching the 'RegexBaseType' regular expression as many times as possible,+-- but backtracks if the regex cannot be matched a minimum of the given number of times.+rxLimitMin :: RegexBaseType rx => Int -> rx -> Regex+rxLimitMin lo = RxStep . RxRepeat (Iv.Finite lo) Iv.PosInf . rxPrim++-- | Match a 'RegexBaseType' regex as many times as possible (greedily) but never exceeding the+-- maximum number of times given. Must match at least one character, or else backtracks.+rxLimitMax :: RegexBaseType rx => Int -> rx -> Regex+rxLimitMax hi = RxStep . RxRepeat Iv.NegInf (Iv.Finite hi) . rxPrim++-- | Like 'rx' but repeats, but must match at least one character. It is similar to the @*@ operator+-- in POSIX regular expressions. /WARNING:/ do not create regex loops using only regexs of this+-- type, your regex will loop indefinitely.+rxRepeat :: RegexBaseType rx => rx -> Regex+rxRepeat = RxStep . RxRepeat Iv.NegInf Iv.PosInf . rxPrim++-- | Defined as @'rxLimitMin' 1@, matches a primitive 'RegexBaseType' one or more times, rather than+-- zero or more times. It is imilar to the @+@ operator in POSIX regular expressions.+rxRepeat1 :: RegexBaseType rx => rx -> Regex+rxRepeat1 = rxLimitMin 1++-- | Create a token, keep the portion of the string that has matched the regex up to this point, but+-- clear the match buffer once the token has been created.+rxToken :: TokenType tok => tok -> Regex+rxToken tok = RxMakeToken (ConstToken True $ unwrapTT tok)++-- | Create a token, disgarding the portion of the string that has matched the regex up to this point.+rxEmptyToken :: TokenType tok => tok -> Regex+rxEmptyToken tok = RxMakeToken (ConstToken False $ unwrapTT tok)++rxMakeToken :: TokenType tok => (String -> (Bool, tok)) -> Regex+rxMakeToken make = RxMakeToken (MakeToken (fmap (fmap unwrapTT) make))++----------------------------------------------------------------------------------------------------+-- $Lexical_Analysis+-- There is only one type used for lexical analysis: the 'Lexer'. This monad is used to analyze+-- text in a 'Prelude.String', and to emit 'Token's. Internally, the 'Token's+-- emitted are automatically stored with their line and column number information in a 'TokenAt'+-- object.+--+-- Although lexical analysis and syntactic analysis are both separate stages, keep in mind that+-- Haskell is a lazy language. So when each phase is composed into a single function, syntactic+-- analysis will occur as tokens become available as they are emitted the lexical analyzer. So what+-- tends to happen is that lexical and syntactic analysis will occur in parallel.+--+-- Although if your syntactic analysis does something like apply 'Data.List.reverse' to the entire+-- token stream and then begin parsing the 'Data.List.reverse'd stream, this will force the entire+-- lexical analysis phase to complete and store the entire token stream into memory before the+-- syntactic analyse can begin. Any parser that scans forward over tokens will consume a lot of+-- memory. But through use of 'Parser' it is difficult to make this mistake.++-- | This is the state used by every 'Lexer'. It keeps track of the line number and column+-- number, the current input string, and the list of emitted 'Token's.+data LexerState tok+  = LexerState+    { lexTabWidth      :: TabWidth+      -- ^ When computing the column number of tokens, the number of spaces a @'\TAB'@ character+      -- counts for should be configured. The default set in 'newLexerState' is 4.+    , lexCurrentLine   :: LineNum+    , lexCurrentColumn :: ColumnNum+    , lexTokenCounter  :: Word+      -- ^ some algorithms would like to know if you lexed any tokens at all, and will fail if you+      -- did not. There needs to be some way of knowing how many tokens your 'Lexer' created.+    , tokenStream      :: [TokenAt tok]+    , lexBuffer        :: String+      -- ^ stores the characters consumed by 'Lexer's. This buffer is never cleared until+      -- 'makeToken' is evaluated. Retrieve this string using:+      -- > 'Control.Monad.State.gets' 'lexBuffer'+    , lexInput         :: String+      -- ^ contains the remainder of the input string to be analyzed. Retrieve this string using:+      -- > 'Control.Monad.State.gets' 'lexInput'+    }+instance HasLineNumber   (LexerState tok) where { lineNumber   = lexCurrentLine }+instance HasColumnNumber (LexerState tok) where { columnNumber = lexCurrentColumn }++-- | Create a new lexer state using the given input 'Prelude.String'. This is only realy useful if+-- you must evaluate 'runLexerState'.+newLexerState :: String -> LexerState tok+newLexerState input =+  LexerState+  { lexTabWidth      = 4+  , lexTokenCounter  = 0+  , lexCurrentLine   = 1+  , lexCurrentColumn = 1+  , tokenStream      = []+  , lexBuffer        = ""+  , lexInput         = input+  }++-- | 'parse' will evaluate the 'Lexer' over the input string first. If the 'Lexer' fails, it+-- will evaluate to a 'Dao.Prelude.PFail' value containing a 'Error' value of type:+-- > 'Error' ('LexerState')+-- However the 'Parser's evaluate to 'Error's containing type:+-- > 'Error' ('TokStreamState' st)+-- This function provides an easy way to convert between the two 'Error' types, however since+-- the state value @st@ is polymorphic, you will need to insert your parser state into the error+-- value after evaluating this function. For example:+-- > case tokenizerResult of+-- >    'Dao.Predicate.PFail' lexErr -> 'Dao.Predicate.PFail' (('lexErrToParseErr' lexErr){'parseStateAtErr' = Nothing})+-- >    ....+lexErrToParseErr :: TokenType tok => ParseError (LexerState tok) tok -> ParseError (TokStreamState st tok) tok+lexErrToParseErr (lexErr@ParseError{parseStateAtErr=st}) =+  lexErr+  { parseStateAtErr = mzero+  , parseErrLoc = maybe LocationUnknown (\st -> atPoint (lexCurrentLine st) (lexCurrentColumn st)) st+  , parseErrMsg = return (ustr "Lexical analysis failed on ") <> parseErrMsg lexErr <>+      (do st <- st+          return $ ustr $ concat $ concat $+            [ do  guard (not (null (lexBuffer st)))+                  ["\nBuffered token string: ", show (lexBuffer st)]+            , ["\nString failed on: ", show (take 20 (lexInput st))]+            ]+      )+  }++lexCurrentLocation :: LexerState tok -> Location+lexCurrentLocation st = atPoint (lineNumber st) (columnNumber st)++-- | The 'Lexer' is very similar in many ways to regular expressions, however 'Lexer's always+-- begin evaluating at the beginning of the input string. The lexical analysis phase of parsing+-- must generate 'Token's from the input string. 'Lexer's provide you the means to do with+-- primitive functions like 'lexString', 'lexChar', and 'lexUntil', and combinators like 'defaultTo'+-- and 'lexUntilTermChar'. These primitive functions collect characters into a buffer, and you can+-- then empty the buffer and use the buffered characters to create a 'Token' using the+-- 'makeToken' function.+-- +-- The 'Control.Monad.fail' function is overloaded such that it halts 'lexecialAnalysis' with a+-- useful error message about the location of the failure. 'Control.Monad.Error.throwError' can+-- also be used, and 'Control.Monad.Error.catchError' will catch errors thrown by+-- 'Control.Monad.Error.throwError' and 'Control.Monad.fail'.  'Control.Monad.mzero' causes+-- backtracking. Be careful when recovering from backtracking using 'Control.Monad.mplus' because+-- the 'lexBuffer' is not cleared. It is usually better to backtrack using 'lexBacktrack' (or don't+-- backtrack at all, because it is inefficient). However you don't need to worry too much; if a+-- 'Lexer' backtracks while being evaluated in lexical analysis the 'lexInput' will not be+-- affected at all and the 'lexBuffer' is ingored entirely.+newtype Lexer tok a = Lexer{+    lexerToPredicateT :: PredicateT (ParseError (LexerState tok) tok) (State (LexerState tok)) a+  }+  deriving (Functor, Applicative, Alternative, MonadPlus)++instance TokenType tok =>+  Monad (Lexer tok) where+    (Lexer fn) >>= mfn = Lexer (fn >>= lexerToPredicateT . mfn)+    return             = Lexer . return+    fail msg           = do+      st <- get+      throwError $+        (parserErr (lexCurrentLocation st)){parseErrMsg = Just (ustr msg), parseStateAtErr=Just st}++instance TokenType tok => MonadState (LexerState tok) (Lexer tok) where+  get = Lexer (lift get)+  put = Lexer . lift . put++instance TokenType tok => MonadError (ParseError (LexerState tok) tok) (Lexer tok) where+  throwError                     = Lexer . throwError+  catchError (Lexer try) catcher = Lexer (catchError try (lexerToPredicateT . catcher))++instance TokenType tok => MonadPlusError (ParseError (LexerState tok) tok) (Lexer tok) where+  catchPredicate (Lexer try) = Lexer (catchPredicate try)+  predicate            = Lexer . predicate++instance (TokenType tok, Monoid a) => Monoid (Lexer tok a) where+  mempty      = return mempty+  mappend a b = liftM2 mappend a b++-- | Append the first string parameter to the 'lexBuffer', and set the 'lexInput' to the value of+-- the second string parameter. Most lexers simply takes the input, breaks it, then places the two+-- halves back into the 'LexerState', which is what this function does. *Be careful* you don't pass+-- the wrong string as the second parameter. Or better yet, don't use this function.+lexSetState :: TokenType tok => String -> String -> Lexer tok ()+lexSetState got remainder = modify $ \st ->+  st{lexBuffer = lexBuffer st ++ got, lexInput = remainder}++-- | Unlike simply evaluating 'Control.Monad.mzero', 'lexBacktrack' will push the contents of the+-- 'lexBuffer' back onto the 'lexInput'. This is inefficient, so if you rely on this too often you+-- should probably re-think the design of your lexer.+lexBacktrack :: TokenType tok => Lexer tok ig+lexBacktrack = modify (\st -> st{lexBuffer = "", lexInput = lexBuffer st ++ lexInput st}) >> mzero++-- | Single character look-ahead, never consumes any tokens, never backtracks unless we are at the+-- end of input.+lexLook1 :: TokenType tok => Lexer tok Char+lexLook1 = gets lexInput >>= \input -> case input of { "" -> mzero ; c:_ -> return c }++-- | Arbitrary look-ahead, creates a and returns copy of the portion of the input string that+-- matches the predicate. This function never backtracks, and it might be quite inefficient because+-- it must force strict evaluation of all characters that match the predicate.+lexCopyWhile :: TokenType tok => (Char -> Bool) -> Lexer tok String+lexCopyWhile predicate = fmap (takeWhile predicate) (gets lexInput)++-- | A fundamental 'Lexer', uses 'Data.List.break' to break-off characters from the input string+-- until the given predicate evaluates to 'Prelude.True'. Backtracks if no characters are lexed.+lexWhile :: TokenType tok => (Char -> Bool) -> Lexer tok ()+lexWhile predicate = do+  (got, remainder) <- fmap (span predicate) (gets lexInput)+  if null got then mzero else lexSetState got remainder++-- | Like 'lexUnit' but inverts the predicate, lexing until the predicate does not match. This+-- function is defined as:+-- > \predicate -> 'lexUntil' ('Prelude.not' . predicate)+lexUntil :: TokenType tok => (Char -> Bool) -> Lexer tok ()+lexUntil predicate = lexWhile (not . predicate)++-- lexer: update line/column with string+lexUpdLineColWithStr :: TokenType tok => String -> Lexer tok ()+lexUpdLineColWithStr input = do+  st <- get+  let tablen = lexTabWidth st+      countNLs lns cols input = case break (=='\n') input of+        (""    , ""        ) -> (lns, cols)+        (_     , '\n':after) -> countNLs (lns+1) 1 after+        (before, after     ) -> (lns, cols + foldl (+) 0 (map charPrintWidth (before++after)))+      charPrintWidth c = case c of+        c | c=='\t'   -> tablen+        c | isPrint c -> 1+        _             -> 0+      (newLine, newCol) = countNLs (lineNumber st) (columnNumber st) input+  put (st{lexCurrentLine=newLine, lexCurrentColumn=newCol})++-- | Create a 'Token' using the contents of the 'lexBuffer', then clear the 'lexBuffer'. This+-- function backtracks if the 'lexBuffer' is empty. If you pass "Prelude.False' as the first+-- parameter the tokens in the 'lexBuffer' are not stored with the token, the token will only+-- contain the type.+makeGetToken :: TokenType tok => Bool -> tok -> Lexer tok (Token tok)+makeGetToken storeChars typ = do+  st <- get+  let str = lexBuffer st+  token <- case str of+    []               -> mzero+    [c] | storeChars -> return $ CharToken{tokType=typ, tokChar=c}+    _   | storeChars -> return $ Token{tokType=typ, tokUStr=ustr str}+    _                -> return $ EmptyToken{tokType=typ}+  put $+    st{ lexBuffer   = ""+      , tokenStream = tokenStream st +++          [ TokenAt+            { tokenAtLineNumber   = lineNumber   st+            , tokenAtColumnNumber = columnNumber st+            , getTokenValue       = token+            } ]+      , lexTokenCounter = lexTokenCounter st + 1+      }+  lexUpdLineColWithStr str+  return token++-- | Create a token in the stream without returning it (you usually don't need the token anyway). If+-- you do need the token, use 'makeGetToken'.+makeToken :: TokenType tok => tok -> Lexer tok ()+makeToken = void . makeGetToken True++-- | Create a token in the stream without returning it (you usually don't need the token anyway). If+-- you do need the token, use 'makeGetToken'. The token created will not store any characters, only+-- the type of the token. This can save a lot of memory, but it requires you have very descriptive+-- token types.+makeEmptyToken :: TokenType tok => tok -> Lexer tok ()+makeEmptyToken = void . makeGetToken False++-- | Clear the 'lexBuffer' without creating a token.+clearBuffer :: TokenType tok => Lexer tok ()+clearBuffer = get >>= \st -> lexUpdLineColWithStr (lexBuffer st) >> put (st{lexBuffer=""})++-- | A fundamental lexer using 'Data.List.stripPrefix' to check whether the given string is at the+-- very beginning of the input.+lexString :: TokenType tok => String -> Lexer tok ()+lexString str = gets lexInput >>= maybe mzero return . stripPrefix str >>= lexSetState str++-- | A fundamental lexer succeeding if the next 'Prelude.Char' in the 'lexInput' matches the+-- given predicate. See also: 'charSet' and 'unionCharP'.+lexCharP :: TokenType tok => (Char -> Bool) -> Lexer tok ()+lexCharP predicate = gets lexInput >>= \input -> case input of+  c:input | predicate c -> lexSetState [c] input+  _                     -> mzero++-- | Succeeds if the next 'Prelude.Char' on the 'lexInput' matches the given 'Prelude.Char'+lexChar :: TokenType tok => Char -> Lexer tok ()+lexChar c = lexCharP (==c)++-- | Backtracks if there are still characters in the input.+lexEOF :: TokenType tok => Lexer tok ()+lexEOF = fmap (=="") (gets lexInput) >>= guard++-- | Takes a 'tokenStream' resulting from the evaulation of lexical analysis and breaks it into+-- 'Line's. This makes things a bit more efficient because it is not necessary to store a line+-- number with every single token. It is necessary for initializing a 'Parser'.+tokenStreamToLines :: [TokenAt tok] -> [Line tok]+tokenStreamToLines toks = loop toks where+  makeLine num toks =+    Line+    { lineLineNumber = num+    , lineTokens     = map (\t -> (tokenAtColumnNumber t, getToken t)) toks+    }+  loop toks = case toks of+    []     -> []+    t:toks ->+      let num           = tokenAtLineNumber t+          (line, toks') = span ((==num) . tokenAtLineNumber) (t:toks)+      in  makeLine num line : loop toks'++-- | The 'Lexer's analogue of 'Control.Monad.State.runState', runs the lexer using an existing+-- 'LexerState'.+lexicalAnalysis+  :: TokenType tok+  => Lexer tok a -> LexerState tok -> (Predicate (ParseError (LexerState tok) tok) a, LexerState tok)+lexicalAnalysis lexer st = runState (runPredicateT (lexerToPredicateT lexer)) st++-- | Perform a simple evaluation of a 'Lexer' against the beginning of a string, returning the+-- tokens and the remaining string. Evaluates to @('Prelude.True', (tokens, remainder))@ if the+-- lexer succeeded, evaluates to @('Prelude.False', (tokens, remainder))@ if the lexer failed or+-- backtracked, where @tokens@ are the tokens produced and @remainder@ is the portion of the string+-- that was not tokenized.+runLexer :: TokenType tok => Lexer tok a -> String -> (Bool, ([TokenAt tok], String))+runLexer lexer inputStr =+  let (lexResult, st) = lexicalAnalysis lexer (newLexerState inputStr)+  in  (case lexResult of { OK _ -> True; _ -> False; }, (tokenStream st, lexInput st))++-- | Convert a 'Regex' to a 'Lexer' and match a string against it using 'runLexer', so it only+-- matches at the beginning of a string, not at any arbitrary point in the middle of the string.+runRegex :: TokenType tok => Regex -> String -> (Bool, ([TokenAt tok], String))+runRegex lexer inputStr =+  let (a, (b, c)) = runLexer (regexToLexer lexer) inputStr in (a, (fmap (fmap wrapTT) b, c))++testLexicalAnalysis_withFilePath+  :: (Show tok, TokenType tok)+  => Lexer tok () -> FilePath -> TabWidth -> String -> IO ()+testLexicalAnalysis_withFilePath tokenizer filepath tablen input = putStrLn report where+  (result, st) = lexicalAnalysis tokenizer ((newLexerState input){lexTabWidth=tablen})+  lines  = tokenStreamToLines (tokenStream st)+  more   = take 21 (lexInput st)+  remain = "\nremaining: "++(if length more > 20 then show (take 20 more)++"..." else show more)+  loc    = show (lineNumber st) ++ ":" ++ show (lexCurrentColumn st)+  report = (++remain) $ intercalate "\n" (map showLine lines) ++ '\n' : case result of+    OK      _ -> "No failures during lexical analysis."+    Backtrack -> reportFilepath ++ ": lexical analysis evalauted to \"Backtrack\""+    PFail err -> show (fmapParseErrorState (const ()) err)+  showLine line = unlines $ ["----------", show line]+  reportFilepath = (if null filepath then "" else filepath)++":"++loc++-- | Run the 'lexicalAnalysis' with the 'Lexer' on the given 'Prelude.String' and print out+-- every token created.+testLexicalAnalysis+  :: (Show tok, TokenType tok)+  => Lexer tok () -> TabWidth -> String -> IO ()+testLexicalAnalysis a b c = testLexicalAnalysis_withFilePath a "" b c++-- | Run the 'lexicalAnalysis' with the 'Lexer' on the contents of the file at the the given+-- 'System.IO.FilePath' 'Prelude.String' and print out every token created.+testLexicalAnalysisOnFile+  ::(Show tok, TokenType tok) +  => Lexer tok () -> TabWidth -> FilePath -> IO ()+testLexicalAnalysisOnFile a b c = readFile c >>= testLexicalAnalysis_withFilePath a c b++----------------------------------------------------------------------------------------------------+-- $Fundamental_parser_data_types+-- A parser is defined as a stateful monad for analyzing a stream of tokens. A token stream is+-- represented by a list of 'Line' structures, and the parser monad's jobs is to look at the+-- current line, and extract the current token in the current line in the state, and use the tokens+-- to construct data. 'TokStream' is the fundamental parser, but it might be very tedious to use. It+-- is better to construct parsers using 'TokStream' which is a higher-level, easier to use data type+-- that is converted into the lower-level 'TokStream' type.++-- | The 'TokStreamState' contains a stream of all tokens created by the 'lexicalAnalysis' phase.+-- This is the state associated with a 'TokStream' in the instantiation of+-- 'Control.Monad.State.MonadState', so 'Control.Monad.State.get' returns a value of this data type.+data TokStreamState st tok+  = TokStreamState+    { userState     :: st+    , getLines      :: [Line tok]+    , tokenQueue    :: [TokenAt tok]+      -- ^ single look-ahead is common, but the next token exists within the 'Prelude.snd' value+      -- within a pair within a list within the 'lineTokens' field of a 'Line' data structure.+      -- Rather than traverse that same path every time 'nextToken' or 'withToken' is called, the+      -- next token is cached here.+    , finalLocation :: Location -- ^ the line and column number marking the end of the file.+    }+instance Functor (TokStreamState st) where+  fmap f s =+    TokStreamState+    { userState     = userState s+    , getLines      = fmap (fmap f) (getLines s)+    , tokenQueue    = fmap (fmap f) (tokenQueue s)+    , finalLocation = finalLocation s+    }++newTokStream :: TokenType tok => st -> [Line tok] -> TokStreamState st tok+newTokStream userState lines =+  TokStreamState+  { userState     = userState+  , getLines      = lines+  , tokenQueue    = []+  , finalLocation = LocationUnknown+  }++newTokStreamFromLexer :: TokenType tok => st -> LexerState tok -> TokStreamState st tok+newTokStreamFromLexer userState lexerState =+  (newTokStream userState $ tokenStreamToLines $ tokenStream lexerState)+  { finalLocation =+      atPoint (lexCurrentColumn lexerState) (lexCurrentColumn lexerState)+  }++-- The 'TokStreamState' data structure has a field of a polymorphic type reserved for containing+-- arbitrary stateful information. 'TokStream' instantiates 'Control.Monad.State.Class.MonadState'+-- usch that 'Control.Monad.State.Class.MonadState.get' and+-- 'Control.Monad.State.Class.MonadState.put' return the 'TokStreamState' type, however if you wish+-- to modify the arbitrary state value using a function similar to how the+-- 'Control.Monad.State.Class.MonadState.modify' would do, you can use this function.+--modifyUserState :: TokenType tok => (st -> st) -> TokStream st tok ()+--modifyUserState fn = modify (\st -> st{userState = fn (userState st)})++-- | The task of the 'TokStream' monad is to look at every token in order and construct syntax trees+-- in the 'syntacticAnalysis' phase.+--+-- This function instantiates all the useful monad transformers, including 'Data.Functor.Functor',+-- 'Control.Monad.Monad', 'Control.MonadPlus', 'Control.Monad.State.MonadState',+-- 'Control.Monad.Error.MonadError' and 'Dao.Predicate.MonadPlusError'. Backtracking can be done+-- with 'Control.Monad.mzero' and "caught" with 'Control.Monad.mplus'. 'Control.Monad.fail' and+-- 'Control.Monad.Error.throwError' evaluate to a control value containing a 'Error' value+-- which can be caught by 'Control.Monad.Error.catchError', and which automatically contain+-- information about the location of the failure and the current token in the stream that caused the+-- failure.+newtype TokStream st tok a+  = TokStream{+      parserToPredicateT ::+        PredicateT (ParseError (TokStreamState st tok) tok) (State (TokStreamState st tok)) a+    }+instance Functor (TokStream st tok) where { fmap f (TokStream a) = TokStream (fmap f a) }+instance TokenType tok =>+  Monad (TokStream st tok) where+    (TokStream ma) >>= mfa = TokStream (ma >>= parserToPredicateT . mfa)+    return a               = TokStream (return a)+    fail msg = do+      tok <- optional (nextToken False)+      st  <- get+      throwError $+        ParseError+        { parseErrLoc     = maybe LocationUnknown asLocation tok+        , parseErrMsg     = Just (ustr msg)+        , parseErrTok     = fmap getToken tok+        , parseStateAtErr = Just st+        }+instance TokenType tok =>+  MonadPlus (TokStream st tok) where+    mzero                             = TokStream mzero+    mplus (TokStream a) (TokStream b) = TokStream (mplus a b)+instance TokenType tok =>+  Applicative (TokStream st tok) where { pure = return ; (<*>) = ap; }+instance TokenType tok =>+  Alternative (TokStream st tok) where { empty = mzero; (<|>) = mplus; }+instance TokenType tok =>+  MonadState (TokStreamState st tok) (TokStream st tok) where+    get = TokStream (PredicateT (fmap OK get))+    put = TokStream . PredicateT . fmap OK . put+instance TokenType tok =>+  MonadError (ParseError (TokStreamState st tok) tok) (TokStream st tok) where+    throwError err = do+      st <- get+      predicate (PFail (err{parseStateAtErr=Just st}))+    catchError (TokStream ptrans) catcher = TokStream $ do+      pval <- catchPredicate ptrans+      case pval of+        OK      a -> return a+        Backtrack -> mzero+        PFail err -> parserToPredicateT (catcher err)+instance TokenType tok =>+  MonadPlusError (ParseError (TokStreamState st tok) tok) (TokStream st tok) where+    catchPredicate (TokStream ptrans) = TokStream (catchPredicate ptrans)+    predicate                   = TokStream . predicate+instance (TokenType tok, Monoid a) =>+  Monoid (TokStream st tok a) where { mempty = return mempty; mappend a b = liftM2 mappend a b; }++-- Return the next token in the state along with it's line and column position. If the boolean+-- parameter is true, the current token will also be removed from the state.+nextToken :: TokenType tok => Bool -> TokStream st tok (TokenAt tok)+nextToken doRemove = do+  st <- get+  case tokenQueue st of+    [] -> case getLines st of+      []         -> mzero+      line:lines -> do+        modify (\st -> st{tokenQueue=lineToTokensAt line, getLines=lines})+        nextToken doRemove+    tok:tokx | doRemove -> put (st{tokenQueue=tokx}) >> return tok+    tok:_               -> return tok++----------------------------------------------------------------------------------------------------++-- | The public API for the 'TokStream' monad wraps 'TokStream' in a newtype called 'Parser.+data Parser st tok a+  = ParserNull+  | Parser{ parserToTokStream :: TokStream st tok a }+  -- 'Parser' has it's own 'ParserNull' constructor because of lookup tables. When a lookup table is+  -- evaluated, it selects the next parser from the table based on the current token in the stream.+  -- But before it evaluates the next parser, it must shift the current token from the stream. If+  -- the next parser is 'mzero', then the token will need to be unshifed immediately. To prevent+  -- this unnecessary shift-unshift, the looked-up parser is checked: if the next parser is+  -- 'ParserNull' (which could happen often because it is the default value used when constructing+  -- the table) then the current token is not shifted at all.+instance Show (Parser st tok a) where { show p = case p of { ParserNull -> "ParserNull"; Parser _ -> "Parser ..."; }}+instance TokenType tok => Functor (Parser st tok) where+  fmap f p = case p of { ParserNull -> ParserNull; Parser p -> Parser (fmap f p); }+instance TokenType tok =>+  Monad (Parser st tok) where+    return = Parser . return+    parser >>= bind = case parser of+      ParserNull -> ParserNull+      Parser   p -> Parser $ p >>= \a -> case bind a of { ParserNull -> mzero; Parser p -> p; }+    --parserA >> parserB = case parserA of+    --  ParserNull     -> ParserNull+    --  Parser parserA -> case parserB of+    --    ParserNull     -> Parser (parserA >> mzero)+    --    Parser parserB -> Parser (parserA >> parserB)+    fail   = Parser . fail+instance TokenType tok =>+  MonadPlus (Parser st tok) where+    mzero = ParserNull+    mplus a b = case a of+      ParserNull -> b+      Parser   a -> Parser $ case b of+        ParserNull -> a+        Parser   b -> mplus a b+instance TokenType tok => Applicative (Parser st tok) where { pure = return; (<*>) = ap;    }+instance TokenType tok => Alternative (Parser st tok) where { empty = mzero; (<|>) = mplus; }+instance TokenType tok => MonadState st (Parser st tok) where+  get     = Parser (gets userState)+  put ust = Parser (modify (\st -> st{userState=ust}))+instance TokenType tok =>+  MonadError (ParseError (TokStreamState st tok) tok) (Parser st tok) where+    throwError = Parser . throwError+    catchError trial catcher = Parser $+      catchError (parserToTokStream trial) (\err -> parserToTokStream (catcher err))+instance TokenType tok =>+  MonadPlusError (ParseError (TokStreamState st tok) tok) (Parser st tok) where+    catchPredicate ptrans = Parser (catchPredicate (parserToTokStream ptrans))+    predicate       = Parser . predicate+instance TokenType tok => Monoid (Parser st tok a) where {mempty=mzero; mappend=mplus; }++----------------------------------------------------------------------------------------------------++-- | This class exists to provide the 'token'. Ordinarily you would want to use the 'tokenType'+-- function to construct a parser that succeeds when the 'TokenType' value you provide to it matches+-- the next 'Token' in the 'TokStream'. However you need to have this 'TokenType' value first to+-- construct the parser, which means retrieving it by name from the 'TokenDB'. But things are more+-- convenient if you have a 'MetaType' that you used to construct your 'Lexer' using the 'fullToken'+-- or 'emptyToken' functions, which is possible because these functions construct 'Lexer's from+-- 'UStrType's, and your 'MetaToken' type also instantiates 'UStrType'. If you have created a data+-- type to be used as a 'MetaType' and used it to construct tokens, the 'Dao.String.UStr' value of+-- the 'MetaToken' type is associated with the 'TT' value of your 'TokenType' in the 'TokenDB'. This+-- function conveniently sees your 'MetaToken' type, retrieves it from the 'TokenDB', and uses the+-- 'TT' value retrieved to construct a 'TokStream' using the 'tokenType' function.+-- > newtype MyToken = MyToken{ unwrapMyToken :: TT }+-- > instance 'TokenType' MyToken where { 'unwrapTT' = unwrapMyToken; 'wrapTT' = MyToken; }+-- > data MyMetaTT WHITESPACE | NUMBER | LABEL+-- > +-- > instance 'MetaToken' MyMetaTT MyToken where { 'tokenDBFromMetaValue' _ = getTokenDB }+-- > instance 'HasTokenDB' MyToken where+-- >     getTokenDB = 'makeTokenDB' $ do+-- >         mySpace  <- emptyToken WHITESPACE $ 'rxRepeat1'('Prelude.map' 'ch' "\n\t ")+-- >         let number = 'from' '0' 'to' '9'+-- >         myNumber <- fullToken  NUMBER     $ 'rxRepeat1' number+-- >         let alpha_ = [ch '_', 'from' '@A@' 'to' '@Z@', 'from' '@a@' 'to' '@z@']+-- >         myLabel  <- fullToken  LABLE      $ 'rxRepeat1' alpha_ . rxRepeat(number : alpha_)+-- >         -- now the 'TT' values have been associated with the 'Dao.String.UStr' values+-- >         -- of your 'MetaToken' type.+-- >         'activate' [mySpace, myNumber, myLabel]+-- > +-- > data MyAST = NullAST | Assign{ label :: 'Prelude.String', intValue :: 'Prelude.Int' }+-- > mkAssign :: String -> String -> MyAST+-- > mkAssign lbl val = Assign{ label = lbl, intValue = 'Prelude.read' val }+-- > +-- > -- make a 'TokStream' that parses a label, followed by a space, followed by a number+-- > myTokStream :: TokStream () MyToken MyAST+-- > myTokStream = 'Control.Applicative.pure' mkAssign 'Control.Applicative.<*>' ('token' LABEL) 'Control.Applicative.<*>' ('token' NUMBER)+class (Enum meta, UStrType meta) =>+  MetaToken meta tok | meta -> tok where { tokenDBFromMetaValue :: meta -> TokenDB tok }++-- | This class exists to to provide the 'tokenBy' function.+class TokenType tok => HasTokenDB tok where { tokenDB :: TokenDB tok }+getTokenDB :: HasTokenDB tok => Parser st tok (TokenDB tok)+getTokenDB = return tokenDB++tokenDBFromToken :: HasTokenDB tok => tok -> TokenDB tok+tokenDBFromToken _ = tokenDB++tokenDBFromParser :: HasTokenDB tok => Parser st tok a -> TokenDB tok+tokenDBFromParser _ = tokenDB++-- | If the given 'Parser' backtracks then evaluate to @return ()@, otherwise ignore the result of+-- the 'Parser' and evaluate to @return ()@.+ignore :: TokenType tok => Parser st tok ig -> Parser st tok ()+ignore parser = mplus (parser >> return ()) (return ()) ++-- | Return the default value provided in the case that the given 'Parser' fails, otherwise+-- return the value returned by the 'Parser'.+defaultTo :: TokenType tok => a -> Parser st tok a -> Parser st tok a+defaultTo defaultValue parser = mplus parser (return defaultValue)++-- | Given two parameters: 1. an error message and 2. a 'Parser', will succeed normally if+-- evaluating the given 'Parser' succeeds. But if the given 'Parser' backtracks, this this function+-- will evaluate to a 'Parser' failure with the given error message. If the given 'Parser' fails,+-- it's error message is used instead of the error message given to this function. The string+-- "expecting " is automatically prepended to the given error message so it is a good idea for your+-- error message to simple state what you were expecting, like "a string" or "an integer". I+-- typically write 'expect' statements like so:+-- > fracWithExp = do+-- >     fractionalPart <- parseFractional+-- >     'tokenStrType' 'Alphabetic' (\tok -> tok=="E" || tok=="e")+-- >     'expect' "an integer expression after the 'e'" $ do+-- >         exponentPart <- parseSignedInteger+-- >         return (makeFracWithExp fractionalPart exponentPart :: 'Prelude.Double')+expect+  :: (TokenType tok, UStrType str, MonadError (ParseError (TokStreamState st tok) tok) (Parser st tok))+  => str -> Parser st tok a -> Parser st tok a+expect errMsg parser = do+  loc <- mplus (look1 asLocation) (Parser (gets finalLocation))+  let expectMsg = "expecting " ++ uchars errMsg+  mplus parser (throwError ((parserErr loc){parseErrMsg = Just (ustr expectMsg)}))++-- | Given a constructor that takes an arbitray value and a 'Dao.NewTokStream.Location' value, and a+-- 'Dao.NewTokStream.Parser' that evaluates to the same type of arbitrary value, this function+-- automatically notes the location of the current token, then evaluates the parser, then notes the+-- location of the next token to create a 'Dao.NewTokStream.Location' value and apply it to the+-- constructor.+withLoc :: TokenType tok => Parser st tok (Location -> a) -> Parser st tok a+withLoc parser = do+  before <- look1 asLocation+  cons   <- parser+  after  <- mplus (look1 asLocation) (Parser (gets finalLocation))+  return (cons (before<>after))++shift :: TokenType tok => (TokenAt tok -> a) -> Parser st tok a+shift as = Parser (fmap as (nextToken True))++look1 :: TokenType tok => (TokenAt tok -> a) -> Parser st tok a+look1 as = Parser (fmap as (nextToken False))++unshift :: TokenType tok => TokenAt tok -> Parser st tok ()+unshift tok = Parser $ modify (\st -> st{tokenQueue = tok : tokenQueue st})++metaTypeToTokenType :: (TokenType tok, MetaToken meta tok) => meta -> tok+metaTypeToTokenType meta =+  case M.lookup (toUStr meta) (tableUStrToTT (tokenDBFromMetaValue meta)) of+    Nothing  -> error $ "internal: parser defined to use meta token "++show (toUStr meta)+++      " without having activated any tokenizer that constructs a token of that meta type"+    Just tt -> wrapTT tt++-- | This function takes two parameters, the first is a polymorphic function we can call+-- @getter@ that takes some of the contents of the current token in the stream. The first value+-- is a 'MetaToken' value we can call @meta@. This function will check the whether current token+-- in the stream has an identifier value that matches the given @meta@ value. If so, the current+-- token is shifted off of the stream and passed to the @getter@ function to extract the+-- necessary information from the token.+-- +-- Valid @getter@ functions are 'asTokType', 'asString', 'asUStr', 'as0', 'asToken',+-- 'asTokenAt', 'asTriple', 'asLineColumn', 'asLocation', or any composition of functions with+-- any of the above as the right-most function.+token :: (TokenType tok, MetaToken meta tok) => meta -> (TokenAt tok -> a) -> Parser st tok a+token meta as = look1 asTokType >>= \tok ->+  if tok == metaTypeToTokenType meta then shift as else mzero++-- | Useful for keywords or operators, this function is used to check if the next 'Token' value+-- in the 'Parser' is of a 'TokenType' labeled by the given constant string. This function+-- has similar behavior to @('tokenString' 'shift')@, /HOWEVER/ unlike 'tokenString', /this+-- function is much more efficient/ because the 'Token' identifier is looked up in the 'TokenDB'+-- only once and then used to add this parser to a parse table instead of merely comparing the+-- string value of the token.+-- +-- Valid @getter@ functions are 'asTokType', 'asString', 'asUStr', 'as0', 'asToken',+-- 'asTokenAt', 'asTriple', 'asLineColumn', 'asLocation', or any composition of functions with+-- any of the above as the right-most function.+tokenBy :: (UStrType name, HasTokenDB tok) => name -> (TokenAt tok -> a) -> Parser st tok a+tokenBy name as = do+  db <- getTokenDB+  let uname = toUStr name +  tok <- look1 id+  case M.lookup uname (tableUStrToTT db) of+    Nothing -> if asUStr tok == uname then shift as else mzero+    Just tt -> if unwrapTT (asTokType tok) == tt then shift as else mzero++-- | A 'marker' immediately stores the cursor onto the runtime call stack. It then evaluates the+-- given 'Parser'. If the given 'Parser' fails, the position of the failure (stored in a+-- 'Dao.Token.Location') is updated such that the starting point of the failure points to the cursor+-- stored on the stack by this 'marker'. When used correctly, this function makes error reporting a+-- bit more helpful.+marker :: TokenType tok => Parser st tok a -> Parser st tok a+marker parser = do+  before <- mplus (look1 asLocation) (Parser (gets finalLocation))+  pval <- catchPredicate parser+  case pval of+    PFail err -> throwError $ err{parseErrLoc = before <> parseErrLoc err}+    pval      -> predicate pval++-- | The 'Parser's analogue of 'Control.Monad.State.runState', runs the parser using an existing+-- 'TokStreamState'.+runParserState+  :: TokenType tok+  => Parser st tok a+  -> TokStreamState st tok+  -> (Predicate (ParseError (TokStreamState st tok) tok) a, TokStreamState st tok)+runParserState parser initTokSt = case parser of+  ParserNull                -> (Backtrack, initTokSt)+  Parser (TokStream parser) -> runState (runPredicateT parser) initTokSt++-- | This is the second phase of parsing, takes a stream of tokens created by the 'lexicalAnalysis'+-- phase (the @['Line' tok]@ parameter) and constructs a syntax tree data structure using the+-- 'Parser' monad provided.+syntacticAnalysis+  :: TokenType tok+  => Parser st tok synTree+  -> TokStreamState st tok+  -> (Predicate (ParseError (TokStreamState st tok) tok) synTree, TokStreamState st tok)+syntacticAnalysis = runParserState++getNullToken :: TokenType tok => Parser st tok tok+getNullToken = return (wrapTT (MkTT 0))++isEOF :: TokenType tok => Parser st tok Bool+isEOF = Parser (get >>= \st -> return (null (getLines st) && null (tokenQueue st)))++----------------------------------------------------------------------------------------------------++-- | Parse table, used to create arrays of tokens that can be used to efficiently select the next+-- parse action to take based on the value of the current token in the token stream.+data PTable tok a+  = PTableNull+  | PTable { pTableArray :: Array TT (Maybe (TokenAt tok -> a)) }+instance TokenType tok => Functor (PTable tok) where+  fmap f ptab = case ptab of+    PTableNull -> PTableNull+    PTable arr -> PTable (fmap (fmap (fmap f)) arr)+instance (Monoid a, TokenType tok) => Monoid (PTable tok a) where+  mempty      = PTableNull+  mappend a b = case a of+    PTableNull -> b+    PTable arr -> case b of+      PTableNull  -> PTable arr+      PTable arr' -> PTable (mergeArrays mappend mempty arr arr' )++newtype TableItem tok a = TableItem{ tableItemToPair :: (tok, TokenAt tok -> a) }+instance TokenType tok => Functor (TableItem tok) where+  fmap f (TableItem ti) = TableItem (fmap (fmap f) ti)++tableItem :: (TokenType tok, MetaToken meta tok) =>+  meta -> (TokenAt tok -> a) -> TableItem tok a+tableItem meta parser = TableItem (metaTypeToTokenType meta, parser)++tableItemBy :: (TokenType tok, HasTokenDB tok, UStrType name) =>+  name -> (TokenAt tok -> a) -> TableItem tok a+tableItemBy name parser =+  case M.lookup (toUStr name) (tableUStrToTT (tokdb parser)) of+    Nothing  -> error ("tableItemBy "++show (toUStr name)++" not activated in TokenDB")+    Just tok -> TableItem (wrapTT tok, parser)+  where+    tokdb   :: HasTokenDB tok => (TokenAt tok -> a) -> TokenDB tok+    tokdb parser = tokenDBFromToken (tokType parser)+    tokType :: HasTokenDB tok => (TokenAt tok -> a) -> tok+    tokType    _ = undefined -- don't want the value, just the type to be inferred++-- | Use this function if your 'TableItem' contains a parser which you also need to evalaute as a+-- stand-alon parser.+evalPTableItem :: TokenType tok => TableItem tok a -> Parser st tok a+evalPTableItem (TableItem (tokType, parser)) =+  look1 asTokType >>= \t -> if tokType==t then shift id >>= return . parser else mzero++-- | Usually, 'PTable's and 'TableItem's will contain monadic 'Parser' function elements, and evaluating a+-- 'PTable or 'TableItem' will result in that 'Parser' function element being returned to the monadic+-- function which evaluated it, in which case it must be 'Control.Monad.join'ed. This function+-- provides a handy shortcut to the expression @('Control.Monad.join' . 'evalPTableItem')@. See also+-- 'joinEvalPTable'.+joinEvalPTableItem :: TokenType tok => TableItem tok (Parser st tok a) -> Parser st tok a+joinEvalPTableItem = join . evalPTableItem++table :: Monoid a => TokenType tok => [TableItem tok a] -> PTable tok a+table tokParserAssocs = case asocs of+  []          -> PTableNull+  (tok1, _):_ -> PTable (accumArray mappend mempty bnds ttParserAssocs) where+    ttParserAssocs = fmap (\ (tok, parser) -> (unwrapTT tok, Just parser)) asocs+    tt = unwrapTT tok1+    bnds = foldl (\ (lo, hi) (tt, _) -> (min lo tt, max hi tt)) (tt, tt) ttParserAssocs+  where+    asocs = fmap tableItemToPair tokParserAssocs++-- | Like 'bindPTable' but operates on a single 'TableItem'.+bindPTableItem :: TokenType tok =>+  TableItem tok (Parser st tok a) -> (a -> Parser st tok b) -> TableItem tok (Parser st tok b)+bindPTableItem (TableItem item) bind = TableItem (fmap (fmap (>>=bind)) item)++-- | Like 'bindPTable' but operates on a list of 'TableItem's.+bindPTableItemList :: TokenType tok =>+  [TableItem tok (Parser st tok a)] -> (a -> Parser st tok b) -> [TableItem tok (Parser st tok b)]+bindPTableItemList list bind = fmap (flip bindPTableItem bind) list++-- | 'PTable's take functions from a 'TokenAt' type to an arbitrary value, but usually this value is+-- a monadic computation. This function takes a table containing monadic computations in the+-- 'Parser' monad and binds it to a monadic 'Parser' function you provide using the+-- 'Control.Monad.>>=' function, evaluating to a new 'PTable' containing the function you provided.+bindPTable :: TokenType tok =>+  PTable tok (Parser st tok a) -> (a -> Parser st tok b) -> PTable tok (Parser st tok b)+bindPTable table bind = case table of+  PTableNull -> PTableNull+  PTable arr -> PTable (fmap (fmap (fmap (>>=bind))) arr)++evalPTable :: TokenType tok => PTable tok a -> Parser st tok a+evalPTable ptable = case ptable of+  PTableNull -> mzero+  PTable arr -> do+    tok <- look1 id+    let tt = unwrapTT (asTokType tok)+    if inRange (bounds arr) tt+      then  case arr!tt of+              Nothing -> mzero+              Just fn -> shift id >>= return . fn+      else  mzero++-- | 'PTable's take functions from a 'TokenAt' type to an arbitrary value, but usually this value is+-- a monadic computation, therefore evaluating the table results in a computation that you must join+-- to the monad in which it was evaluated using 'Control.Monad.join'. This is so common it is+-- worthwhile to provide the 'joinEvalPTable' function as a handy shortcut for the expression:+-- > 'Control.Monad.join' ('evalPTable' myTable)+joinEvalPTable :: TokenType tok => PTable tok (Parser st tok a) -> Parser st tok a+joinEvalPTable = join . evalPTable++----------------------------------------------------------------------------------------------------+-- $Infix_operator_table+-- An infix operator table is an efficient method to parse equations expressed with infix operators.+-- These functions and data types allow you to define a grammar that can handle operator precedence+-- and right or left associativity (for example the rules for PEMDAS/BOMDAS).+--+-- The polymorphic types used throughout use @op@ as the operator token type, and @o@ as the+-- expression type. Your grammar must be some form of tree data structure similar to this example:+-- > data Equation = LEAF Int | BRANCH Equation Char Equation+-- You have at least two constructors, leaves store values and branches store operators and branch+-- to other trees. In the above example, the @Equation@ data type would be bound to the polymorphic+-- type @o@, and @Data.Char.Char@ would be bound to the polymorphic @op@ type.++---------+-- Personal note: I considered making the 'InfixConstr' and 'OpPrec' types of the form:+-- > type InfixConstr a op b = a -> op -> a -> b+-- > data OpPrec a op b = OpPrec Associativity [UStr] (InfixConster a op b)+-- But this required me to add another function to the 'OpTableParser' of the type @(a -> b)@ to+-- handle the case where the there was only a single value not followed by an operator. But I+-- figured this could be handled without complicating things: you can simply require the parsed type+-- to be @a@ and use 'fmap' to convert the result of the parse table to @b@ using @(a -> b)@.+-- +-- I also tried making InfixConstr like this:+-- > type InfixConstr a op b = a -> op -> b -> a+-- and also+-- > type InfixConstr a op b = a -> op -> b -> b+-- But doing this does not allow one to easily mix together right and left associative parsers into+-- a single table. Again, it is best to assume a consistent type for all tokens over which to fold,+-- and place the burden of matching inconsistent types on whoever is writting the infix parser.++-- | An infix constructor is a function of this form. It takes a 'Location' as it's final parameter,+-- which will denote the location of the @op@ token. The 'Location' can just be ignored if you want.+type InfixConstr st tok op o = o -> op -> o -> Parser st tok o++-- | Used to define right or left associativity for infix operators.+newtype Associativity = Associativity{ associatesLeft :: Bool } deriving (Eq, Ord)+instance Show Associativity where+  show (Associativity left) = if left then "leftAssoc" else "rightAssoc"++associatesRight :: Associativity -> Bool+associatesRight = not . associatesLeft++rightAssoc :: Associativity+rightAssoc = Associativity False++leftAssoc :: Associativity+leftAssoc  = Associativity True++runAssociativity+  :: TokenType tok+  => Associativity+  -> InfixConstr st tok op o+  -> o+  -> [(o, op)]+  -> Parser st tok o+runAssociativity assoc constr o stack =+  if associatesLeft assoc+    then  foldl (\ lhs (rhs, op) -> lhs >>= \lhs -> constr lhs op rhs) (return o) stack+    else  (foldr (\ (rhs, op) next initObj -> next rhs >>= constr initObj op) return stack) o++-- | This data type is used to relate an 'Associativity' and an 'InfixConstr' to some operators,+-- the operators being given as strings.+data OpPrec st tok op o+  = OpPrec+    { opPrecAssoc  :: Associativity+    , opPrecOps    :: [UStr]+    , opPrecConstr :: InfixConstr st tok op o+    }++opLeft :: UStrType str => [str] -> InfixConstr st tok op o -> OpPrec st tok op o+opLeft = OpPrec leftAssoc . map toUStr++opRight :: UStrType str => [str] -> InfixConstr st tok op o -> OpPrec st tok op o+opRight = OpPrec rightAssoc . map toUStr++-- Stored in the 'OpTableParser', used to make choices on when to stack a token and when backtrack.+type OpTablePrec st tok op o = Maybe (Associativity, Int, InfixConstr st tok op o)++-- | Use this data type to setup an operator table parser which parses a sequence of @o@ type data+-- separated by @op@ type operator tokens, where the @op@ tokens have been assigned the properties+-- of fixity and right or left associativity.+data OpTableParser st tok op o+  = OpTableParser+    { opTableErrMsg      :: UStr+    , opTableAutoShift   :: Bool+      -- ^ instructs the 'evalOpTableParser' whether or not to automatically shift the operator+      -- token from the token stream. Usually you should set this tor 'Prelude.True'. However if+      -- your @op@ parser is more complicated than just converting a token, and actually needs to+      -- parse tokens in between terms, set this to 'Prelude.False' and make the 'opTableOpAs'+      -- function perform parsing and shifting of the operator. If you do set this to+      -- 'Prelude.False', make sure your 'opTableOpAs' function evaluates 'shift' at least once.+      -- The original reason for providing this option is to more easily build parsers that keep+      -- comments in the abstract syntax tree. Parsers that keep comments will usually parse all+      -- comments at the beginning of the file, then proceed with parsing, and every token parsed+      -- will have comments immediately after it parsed and paired with it. But it would be+      -- impossible to create such a parser without the ability to specify exactly when to shift the+      -- operator token and parse the comments.+    , opTableOpAs        :: TokenAt tok -> Parser st tok op+      -- ^ 'TokenAt' values are automatically retrieved from the token stream by the+      -- 'evalOpTableParser' function, and this function is used to convert those 'TokenAt' values+      -- to values of data type @op@. During evaluation of 'evalOpTableParser' this function is+      -- evaluated before the operator token is shifted from the token stream.+    , opTableObjParser   :: Parser st tok o+      -- ^ This function will parse the non-opreator values of the equation.+    , opTableConstr      :: InfixConstr st tok op o+      -- ^ This function is used to construct an @o@ from a stack of @o@ and @op@ values, it is+      -- passed to 'runAssociativity'. In an arithmetic parser, for example, this function might be+      -- of the form:+      -- > constr :: Int -> String -> Int -> Int+      -- > constr a op b = if op=="+" then a+b else if op=="*" then a*b+    , opTableArray  :: Maybe (Array TT (OpTablePrec st tok op o))+    }++-- | Evaluate an 'OpTableParser' to a 'Parser'.+evalOpTableParser :: (HasTokenDB tok, TokenType tok, Show o) => OpTableParser st tok op o -> Parser st tok o+evalOpTableParser optab = evalOpTableParserWithInit (opTableObjParser optab) optab++-- | Same as 'evalOpTableParser', but lets you provide a different parser for parsing the first+-- object term in the expression. This is useful if the function for parsing the initial term of the+-- expression is a prefix expression (but necessarily returns the same data type) of the function+-- that parses object terms in the expression. After the initial parser function is evaluated, the+-- 'opTableObjParser' function is used for every other term after it.+evalOpTableParserWithInit+  :: (HasTokenDB tok, TokenType tok)+  => Parser st tok o+  -> OpTableParser st tok op o+  -> Parser st tok o+evalOpTableParserWithInit initParser optab = do+  initObj <- initParser+  maybe (return initObj) (begin initObj) (opTableArray optab)+  where+    begin o table = mplus (lookGetPrec table >>= bindLeft table o) (return o)+    lookGetPrec table = do+      tok <- look1 id+      let tt = unwrapTT (asTokType tok)+      if inRange (bounds table) tt+        then  case table!tt of+                Nothing      -> mzero+                Just (a,b,c) -> return (tok, a, b, c)+        else  mzero+    bindLeft table leftObj (tok, assoc, prec, constr) = flip mplus (return leftObj) $ do+      op <- opTableOpAs optab tok+      if opTableAutoShift optab then shift as0 else return ()+      (rightObj, opInfo) <- bindRight table tok assoc prec+      o <- constr leftObj op rightObj+      case opInfo of+        Nothing     -> return o+        Just opInfo -> bindLeft table o opInfo+    bindRight table tok assoc prec = do+      expect (uchars (opTableErrMsg optab)++" after "++show tok++" token") $ do+        leftObj <- opTableObjParser optab+        flip mplus (return (leftObj, Nothing)) $ do+          opInfo@(nextTok, nextAssoc, nextPrec, constr) <- lookGetPrec table+          let mergeStack = return (leftObj, Just opInfo)+          let msg assoc = "associates to the "++(if associatesLeft assoc then "left" else "right")+          case () of+            () | assoc/=nextAssoc      && prec==nextPrec -> fail $ unwords $+              [ "ambiguous experession, infix operators"+              , show tok, "and", show nextTok, "are of the same prescedence, but"+              , show tok, msg assoc, "whereas", show nextTok, msg nextAssoc+              ]+            () | associatesLeft  assoc && prec>=nextPrec -> mergeStack+            () | associatesRight assoc && prec> nextPrec -> mergeStack+            ()                                           -> do+              op <- opTableOpAs optab nextTok+              if opTableAutoShift optab then shift as0 else return ()+              (rightObj, opInfo) <- bindRight table nextTok nextAssoc nextPrec+              constr leftObj op rightObj >>= \o -> return (o, opInfo)++-- | Sets up the 'OpTableParser' data structure.+--+-- The first parameter is a function used to parse the right and left hand sides of each infix+-- operator. This function may safely recurse to itself via the 'Parser' created by the evaluation+-- of 'evalOpTableParser' provided that there is at least one other parser that does not recurse+-- which is tried before it. For example:+-- > myOperatorTable :: OpPrecTable MyOperator MySymbol+-- > myOperatorFromToken :: 'TokenAt' MyTokType -> 'Parser' () MyTokType MyOperator+-- > nonRecursive :: 'Parser' () MyTokType MySymbol -- This parser never recurses to 'myExpression'.+-- >+-- > -- This parser does recurse to 'myExpression'+-- > recursive :: 'Parser' () MyTokType MySymbol+-- > recursive = 'evalOpTableParser' myExpression+-- >+-- > -- This expression parser is OK, it will not loop infinitely as long as nonRecursive takes at+-- > least one token from the token stream.+-- > myExpression :: 'OpTableParser' () MyTokType MyOperator MySymbol+-- > myExpression = 'newOpTableParser' (nonRecursive >> recursive) myOperatorFromToken myOperatorTable+-- >+-- > -- These expression parsers will loop infinitely doing nothing:+-- > badExpression1 = 'newOpTableParser' recursive myOperatorFromToken myOperatorTable+-- > badExpression2 = 'newOpTableParser' (nonRecursive<|>recursive) myOperatorFromToken myOperatorTable+-- > +-- +-- The second parameter is a function which produces an @op@ data type from a 'TokenAt' value.+-- Operators are taken from the token stream by the table evaluator, and this function will take the+-- 'TokenAt' value provided by the table evaluator and convert it to an operator data type. The @op@+-- typed data evaluated from this function will be used to construct the final @o@ value.+-- +-- The final parameters is an 'OpPrecTable' which you construct with the 'opPrecTable' or 'opTable'+-- functions, where you will assign prescedence and associativity properties to every operator+-- token.+newOpTableParser+  :: (HasTokenDB tok, TokenType tok, UStrType errMsg)+  => errMsg+  -> Bool+  -> (TokenAt tok -> Parser st tok op)+  -> Parser st tok o+  -> InfixConstr st tok op o+  -> [OpPrec st tok op o]+  -> OpTableParser st tok op o+newOpTableParser errMsg autoShift asOp objParser constr optab =+  OpTableParser+  { opTableErrMsg    = toUStr errMsg+  , opTableAutoShift = autoShift+  , opTableObjParser = objParser+  , opTableOpAs      = asOp+  , opTableConstr    = constr+  , opTableArray     = inferTypes objParser tokenDB optab+  }+  where+    ttBounds (tt, _) = foldl (\ (lo, hi) (tt, _) -> (min lo tt, max hi tt)) (tt, tt) . tail+    maxPrec = length optab+    precList+      :: (TokenType tok, HasTokenDB tok)+      => Parser st tok o+      -> TokenDB tok+      -> [OpPrec st tok op o]+      -> [(TT, OpTablePrec st tok op o)]+    precList _ db optab = do+      (n, p) <- zip [0..] optab+      op <- opPrecOps p+      case M.lookup op (tableUStrToTT db) of+        Nothing -> error ("internal, token "++show op++" has not been activated in the TokenDB")+        Just op -> return (op, Just (opPrecAssoc p, maxPrec-n, opPrecConstr p))+    inferTypes+      :: (TokenType tok, HasTokenDB tok)+      => Parser st tok o+      -> TokenDB tok+      -> [OpPrec st tok op o]+      -> Maybe (Array TT (OpTablePrec st tok op o))+    inferTypes parser db optab = case precList parser db optab of+      [] -> Nothing+      ax -> Just (accumArray (flip const) Nothing (ttBounds (head ax) ax) ax)++-- | Evaluate a parser with infix operators in between each term. Provide an initial parser to be+-- evaluated for the first term only, then the function for parsing terms of the expression, then+-- the infix operator parser. All infix operators will be of the same prescedence and the given+-- associativity. No tables are created by this function, so it is a good idea for your infix+-- operator parser and or the parser for evaluating terms to be functions of the 'table' function.+simpleInfixedWithInit+  :: (TokenType tok, UStrType errMsg)+  => errMsg+  -> Associativity+  -> InfixConstr st tok op o+  -> Parser st tok o+  -> Parser st tok o+  -> Parser st tok op+  -> Parser st tok o+simpleInfixedWithInit errMsg assoc constr initPar objPar opPar = initPar >>= loop [] where+  loop stack initObj = flip mplus (runAssociativity assoc constr initObj stack) $+    opPar >>= \op -> expect (toUStr errMsg) (objPar >>= \o -> loop (stack++[(o, op)]) initObj)++-- | Same as 'simpleInfixedWithInit' except the fourth parameter (the function for parsing the terms+-- of the expression) is used as both the initial term parser and the function for parsing terms of+-- the expression.+simpleInfixed+  :: (TokenType tok, UStrType errMsg)+  => errMsg+  -> Associativity+  -> InfixConstr st tok op o+  -> Parser st tok o+  -> Parser st tok op+  -> Parser st tok o+simpleInfixed errMsg assoc constr objPar opPar = objPar >>= loop [] where+  loop stack initObj = flip mplus (runAssociativity assoc constr initObj stack) $+    opPar >>= \op -> expect (toUStr errMsg) (objPar >>= \o -> loop (stack++[(o, op)]) initObj)++----------------------------------------------------------------------------------------------------+-- | A 'Language' is a data structure that allows you to easily define a+-- two-phase parser (a parser with a 'lexicalAnalysis' phase, and a 'syntacticAnalysis' phase). The+-- fields supplied to this data type define the grammar, and the 'parse' function can be used to+-- parse an input string using the context-free grammar defined in this data structure. *Note* that+-- the parser might have two phases, but because Haskell is a lazy language and 'parse' is a pure+-- function, both phases happen at the same time, so the resulting parser does not need to parse the+-- entire input in the first phase before beginning the second phase.+-- +-- This data type can be constructed from a 'Parser' in such a way that the resulting+-- 'Parser' is stored in this object permenantly. It might then be possible to reduce+-- initialization time by using an *INLINE* pragma, which will hopefully cause the compiler to+-- define as much of the 'Parser'@'@s sparse matrix as it possibly can at compile time. But this+-- is not a guarantee, of course, you never really know how much an optimization helps until you do+-- proper profiling.+data Language st tok synTree+  = Language+    { columnWidthOfTab :: TabWidth+      -- ^ specify how many columns a @'\t'@ character takes up. This number is important to get+      -- accurate line:column information in error messages.+    , mainLexer        :: Lexer tok ()+      -- ^ *the order of these tokenizers is important,* these are the tokenizers passed to the+      -- 'lexicalAnalysis' phase to generate the stream of tokens for the 'syntacticAnalysis' phase.+    , mainParser    :: Parser st tok synTree+      -- ^ this is the parser entry-point which is used to evaluate the 'syntacticAnalysis' phase.+    }++-- | Construct a 'Language' from a 'Parser'. This defines a complete parser that can be used+-- by the 'parse' function. In constructing this 'Language', the 'Parser' will be converted+-- to a 'Parser' which can be referenced directly from this object. This encourages the runtime+-- to cache the 'Parser' which can lead to better performance. Using an INLINE pragma on this+-- value could possibly improve performance even further.+newLanguage :: (HasTokenDB tok, TokenType tok) =>+  TabWidth -> Parser st tok synTree -> Language st tok synTree+newLanguage tabw parser =+  Language+  { columnWidthOfTab = tabw+  , mainLexer        = tokenDBLexer tokenDB+  , mainParser       = parser+  }++-- | This is /the function that parses/ an input string according to a given 'Language'.+parse :: TokenType tok =>+  Language st tok synTree -> st -> String -> Predicate (ParseError st tok) synTree+parse lang st input = case lexicalResult of+  OK     () -> case parserResult of+    OK     a  -> OK a+    Backtrack -> Backtrack+    PFail err -> PFail $ err{parseStateAtErr = Just (userState parserState)}+  Backtrack -> Backtrack+  PFail err -> PFail $ (lexErrToParseErr err){parseStateAtErr = Nothing}+  where+    initState = (newLexerState input){lexTabWidth = columnWidthOfTab lang}+    (lexicalResult, lexicalState) = lexicalAnalysis (mainLexer lang) initState+    (parserResult , parserState ) =+      syntacticAnalysis (mainParser lang) (newTokStreamFromLexer st lexicalState)++----------------------------------------------------------------------------------------------------++mergeArrays :: Ix i => (e -> e -> e) -> e -> Array i e -> Array i e -> Array i e+mergeArrays plus zero a b =+  accumArray plus zero (boun (bounds a) (bounds b)) (assocs a ++ assocs b) where+    boun (loA, hiA) (loB, hiB) = (min loA loB, max hiA hiB)++----------------------------------------------------------------------------------------------------++class Parseable a where+  parser :: TokenType tok => Parser st tok a++class HasParseTable a where+  parseTable :: TokenType tok => PTable tok a+
+ src/Dao/Predicate.hs view
@@ -0,0 +1,253 @@+-- "src/Dao/Predicate.hs"  provides 'PredicateT' which combines the+-- Maybe and Either types into a single monad.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.+++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | Provides a monad that essentially combines the monadic functionality of 'Prelude.Maybe' and+-- 'Prelude.Either' into a single monad 'Predicate. Both the 'Prelude.Maybe' and 'Prelude.Either'+-- data types are both monads but it is convenient to have a single data type combining the two.+-- 'PFail' is analogous to @'Prelude.Left'@, 'Backtrack' is analogous to+-- @'Prelude.Right' $ 'Prelude.Nothing'@, and 'OK' is analogous to+-- @'Prelude.Right' . 'Prelude.Just'@. All relevant monad transformers are instnatiated, including+-- 'Control.Applicative.Applicative', 'Control.Applicative.Alternative', 'Control.Monad.MonadPlus',+-- and 'Control.Monad.Error.MonadError'. +--+-- A new monad transformer 'PredicateT' is also introduced which lifts the 'Predicate' monad into+-- another monad and wraps it into the 'PredicateT' data type which instantiates the+-- 'Control.Monad.Trans.MonadTrans' class. Further, a new class 'MonadPlusError' is defined which+-- allows you to directly manipulate the 'Predicate' value of a 'PredicateT' transformer.+-- +-- Here is a simple example of how to use this module.+-- > newtype MyErr = MyErr String+-- > newtype MyIO a = WrapMyIO { unwrapMyIO :: 'PredicateT' MyErr IO a }+-- >         deriving (Functor, Applicative, Alternative)+-- >+-- > instance 'Control.Monad.Monad' MyIO where -- this instance can also be derived+-- >     'Control.Monad.return' = WrapMyIO . 'Control.Monad.return'+-- >     f 'Control.Monad.>>= bindTo    =    WrapMyIO $ unwrapMyIO f 'Control.Monad.>>=' unwrapMyIO . bindTo+-- >     'Control.Monad.fail' message = WrapMyIO $ 'PFail' (MyErr message)+-- > +-- > instance 'Control.Monad.MonadPlus' MyIO where -- this instance can also be derived+-- >     'Control.Monad.mzero' = WrapMyIO 'mzero'+-- >     'Control.Monad.mplus' (WrapMyIO try1) (WrapMyIO try2) = WrapMyIO ('mplus' try1 try2)+-- >+-- > instance 'Control.Monad.Error.Class.MonadError' MyErr MyIO where+-- >     'Control.Monad.Error.Class.MonadError.throwError' = WrapMyIO . 'Control.Monad.Error.Class.MonadError.throwError'+-- >     'Control.Monad.Error.Class.MonadError.catchError' (WrapMyIO try) catch = WrapMyIO ('catchError' try (unwrapMyIO . catch))+-- > +-- > instance 'Control.Monad.IO.Class.MonadIO' MyIO where+-- >     'Control.Monad.IO.Class.liftIO' = WrapMyIO . 'liftIO'+-- > +-- > doStep :: MyIO ()+-- > doStep = ...+-- > +-- > doJump :: MyIO ()+-- > doJump = ...+module Dao.Predicate where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Error++import           Data.Monoid++-- | 'Predicate' is a data type that combines 'Prelude.Maybe' and 'Prelude.Either' into a single+-- type. The 'Predicate' monad allows you to construct predicate functions that evaluate to 'OK'+-- (true) 'Backtrack' (false), and also provides a 'PFail' constructor for indicating a "does not+-- make sense" condition.+--+-- The truth condition 'OK' can 'Control.Monad.return' a value which makes it a 'Data.Functor', an+-- 'Control.Applicative.Applicative', and a 'Control.Monad.Monad'. The false condition 'Backtrack'+-- serves as the 'Control.Monad.mzero' for 'Control.Monad.MonadPlus' and 'Control.Applicative.empty'+-- value for 'Control.Applicative.Alternative'. The 'PFail' condition, like 'Prelude.Left', can be+-- used as an error condition in the 'Control.Monad.Error.ErrorClass' which can be caught by+-- 'Control.Monad.Error.catchError'.+--+-- This data type was originally intended for use in the Dao parser, but it is now used in several+-- contexts throughout the program.+data Predicate err ok+  = Backtrack -- ^ analogous to 'Prelude.Nothing'+  | PFail err -- ^ analogous to 'Prelude.Left'+  | OK    ok  -- ^ OK is "just right" i.e. it is analogous to 'Prelude.Just' and 'Prelude.Right'.+  deriving (Eq, Ord, Show)++instance Functor (Predicate err) where+  fmap fn (OK    a) = OK (fn a)+  fmap _  (PFail u) = PFail u+  fmap _  Backtrack = Backtrack++instance Monad (Predicate err) where+  return = OK+  ma >>= mfn = case ma of+    OK     ok -> mfn    ok+    PFail err -> PFail err+    Backtrack -> Backtrack++instance MonadPlus (Predicate err) where+  mzero = Backtrack+  mplus Backtrack b = b+  mplus a         _ = a++instance MonadError err (Predicate err) where+  throwError           = PFail+  catchError try catch = case try of+    PFail err -> catch err+    try       -> try++instance Applicative (Predicate err) where { pure  = return; (<*>) = ap;    }++instance Alternative (Predicate err) where { empty = mzero;  (<|>) = mplus; }++instance Monoid ok => Monoid (Predicate err ok) where+  mempty                = Backtrack+  mappend (OK a) (OK b) = OK(a<>b)+  mappend     a      _  = a++----------------------------------------------------------------------------------------------------++-- | A monad transformer lifting 'Predicate' into an outer monad. Use 'runPreicateT' to remove the+-- 'PredicateT' outer monad and retrieve the inner 'Predictate' value.+newtype PredicateT err m ok = PredicateT { runPredicateT :: m (Predicate err ok) }++instance Monad m => Monad (PredicateT err m) where+  return a = PredicateT (return (OK a))+  PredicateT ma >>= fma = PredicateT $ do+    a <- ma+    case a of+      Backtrack -> return Backtrack+      PFail   u -> return (PFail u)+      OK      o -> runPredicateT (fma o)+  PredicateT ma >> PredicateT mb = PredicateT $ do+    a <- ma+    case a of+      Backtrack -> return Backtrack+      PFail   u -> return (PFail u)+      OK      _ -> mb+  fail msg = PredicateT{ runPredicateT = return (PFail (error msg)) }++instance Functor m => Functor (PredicateT err m) where+  fmap f (PredicateT ma) = PredicateT (fmap (fmap f) ma)++instance Monad m => MonadPlus (PredicateT err m) where+  mzero = PredicateT (return Backtrack)+  mplus (PredicateT a) (PredicateT b) = PredicateT $ do+    result <- a+    case result of+      Backtrack -> b+      PFail   u -> return (PFail u)+      OK      o -> return (OK o)++instance Monad m => MonadError err (PredicateT err m) where+  throwError msg = PredicateT{ runPredicateT = return (PFail msg) }+  catchError ptrans catcher = PredicateT $ do+    value <- runPredicateT ptrans+    case value of+      Backtrack -> return Backtrack+      PFail   u -> runPredicateT (catcher u)+      OK      a -> return (OK a)++instance (Functor m, Monad m) => Applicative (PredicateT err m) where { pure = return; (<*>) = ap; }++instance (Functor m, Monad m) => Alternative (PredicateT err m) where { empty = mzero; (<|>) = mplus; }++instance MonadTrans (PredicateT err) where { lift m = PredicateT(m >>= return . OK) }++instance MonadIO m => MonadIO (PredicateT err m) where { liftIO = PredicateT . liftIO . fmap OK }++----------------------------------------------------------------------------------------------------++-- | Often it is necessary to evaluate a sub-predicate monad within the 'Predicate' or 'PredicateT'+-- monads within the current 'Predicate' monad. Simply evaluating the sub-predicate would cause the+-- current predicate monad to evaluates to 'PFail' or 'Backtrack' if the sub-predicate evaluates to+-- either of these values. But using 'catchPredicate', it is possible to safely evaluate the+-- sub-predicate and capture it's 'Predicate' result, where you can then make a decision on how to+-- behave.+-- > do p <- 'catchPredicate' couldFailOrBacktrack+-- >    case p of+-- >        'OK'    rval -> useReturnValue rval -- use the return value from couldFailOrBacktrack+-- >        'PFail' msg  -> printMyError msg    -- report the error from couldFailOrBacktrack+-- >        'Backtrack'  -> return ()           -- ignore backtracking+-- The above procedure prints the error message created if the sub-predicate evaluated to 'PFail'.+-- If you would like to "re-throw" a 'Predicate' that you have received you can use the 'predicate'+-- function. For example, this line of code could be added to the above procedure:+-- >    predicate p+-- and the function will evaluate to the same exact 'Predicate' value that @couldFailOrBacktrack@+-- had produced after the necessary response to the failure has been made, e.g. after the error+-- message has been printed.+class MonadPlusError err m | m -> err where+  -- | Unlifts the whole 'Predicate' value, unlike 'catchError' which only catches the value stored+  -- in a 'PFail' constructor.+  catchPredicate :: m a -> m (Predicate err a)+  -- | This will force the 'Predicate' value of the current computation. The following should+  -- generally be true for all instances of 'MonadPlusError'.+  -- > 'Control.Monad.return' = 'predicate' . 'OK'+  -- > 'Control.Monad.Error.State.throwError' = 'predicate' . 'PFail'+  -- > 'Control.Monad.mzero' = 'predicate' 'Backtrack'+  predicate :: Predicate err a -> m a++instance MonadPlusError err (Predicate err) where { catchPredicate = OK; predicate = id; }++instance Monad m => MonadPlusError err (PredicateT err m) where+  catchPredicate (PredicateT fn) = PredicateT{ runPredicateT = fn >>= \o -> return (OK o) }+  predicate pval = PredicateT (return pval)++-- | Evaluates to an empty list if the given 'Predicate' is 'Backtrack' or 'PFail', otherwise returns a+-- list containing the value in the 'OK' value.+okToList :: Predicate err o -> [o]+okToList pval = case pval of+  OK      o -> [o]+  Backtrack -> []+  PFail   _ -> []++-- | Like 'okToList', but evaluates to 'Data.Maybe.Nothing' if the given 'Predicate' is 'Backtrack' or+-- 'PFail', or 'Data.Maybe.Just' containing the value in the 'OK' value.+okToJust :: Predicate err o -> Maybe o+okToJust pval = case pval of+  OK      o -> Just o+  Backtrack -> Nothing+  PFail   _ -> Nothing++-- | If given 'Data.Maybe.Nothing', evaluates to 'PFail' with the given error information.+-- Otherwise, evaluates to 'OK'.+maybeToPFail :: err -> Maybe o -> Predicate err o+maybeToPFail err o = case o of+  Nothing -> PFail err+  Just ok -> OK    ok++-- | Like 'Prelude.fmap' but operates on the error report data of the 'Predicate'.+fmapPFail :: (errA -> errB) -> Predicate errA o -> Predicate errB o+fmapPFail f pval = case pval of+  OK      o -> OK o+  Backtrack -> Backtrack+  PFail err -> PFail (f err)++-- | Like 'Data.Either.partitionEithers', but operates on a list of 'Predicates'.+partitionPredicates :: [Predicate err o] -> ([err], [o])+partitionPredicates = loop [] [] where+  loop errs oks ox = case ox of+    []             -> (errs, oks)+    OK    o   : ox -> loop  errs        (oks++[o]) ox+    PFail err : ox -> loop (errs++[err]) oks       ox+    Backtrack : ox -> loop  errs         oks       ox+
+ src/Dao/Random.hs view
@@ -0,0 +1,483 @@+-- "src/Dao/Random.hs"  generates objects from integers that can be used+-- to test the parsers/pretty-printer, and the binary encoder/decoder.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++-- | Hints for making good random object generators:+-- Avoid using scramble more than once per constructor. If you have a data type constructed with:+-- > return DataType <*> 'scrambO' <*> 'scrambO'+-- then just do this instead+-- > 'scramble' $ return DataType <*> 'randO' <*> 'randO'+-- +-- Do not bother preceding generators for newtype data types with 'recurse' or 'countNode', it isn't+-- really necessary.+-- +-- Recursive data types containing lists with 'randList' should probably generate small lists for+-- 'randO' instances, and generate larger lists for 'defaultO' instances.+-- +-- When instantiating 'randO', use only 'randO' to fill-in all the objects contained in the object.+-- When instantiating 'defaultO', use only 'defaultO' to fill-in all the objects contained in the+-- object.+--+-- When instantiating 'defaultO', it is OK to use 'defaultO' to fill-in other non-recursive data+-- types, but /BE VERY CAREFUL/ not to call 'defaultO' for another non-recursive type.+module Dao.Random where++import           Dao.String+import qualified Dao.Tree as T++import           Control.Exception+import           Control.Applicative+import           Control.Monad.Trans.Class+import           Control.Monad.IO.Class+import           Control.Monad.State++import           Data.Monoid+import           Data.Char+import           Data.Word+import           Data.Ratio+import           Data.Time+import           Data.Array.IArray+import qualified Data.ByteString.Char8 as B++import           System.Random+import           System.IO++----------------------------------------------------------------------------------------------------++-- | A simple, stateful monad for generating arbitrary data types based on pseudo-random numbers+-- without lifting the @IO@ or @ST@ monads, i.e. it can be evaluated in a pure way.+newtype RandT m a = RandT { runRandT :: StateT RandOState m a }+  deriving (Functor, Applicative, Monad, MonadPlus, Alternative)++instance MonadTrans RandT where { lift = RandT . lift }+instance MonadIO m => MonadIO (RandT m) where { liftIO = RandT . liftIO }++type RandO a = RandT IO a++data RandOState+  = RandOState+    { integerState :: Integer -- ^ the predictable random generator+    , stdGenState  :: StdGen  -- ^ the unpredictable random generator+    , nodeCounter  :: Int     -- ^ counts how many nodes have been created for this particular run+    , depthLimit   :: Int     -- ^ sets the limit of the recursion depth+    , currentDepth :: Int     -- ^ counts the current recursion depth for this particular run+    , deepestSoFar :: Int     -- ^ keeps track of how deep the deepest recursion has gone+    , traceLevel   :: Int   +      -- ^ when performing a trace, keeps track of how many trace recursions there have been+    }++-- | Initializes the 'RandOState' with two integer values: a maximium recursion depth value (limits+-- the number of times you can recursively call 'limSubRandO') and the seed value passed to+-- 'System.Random.mkStdGen'.+initRandOState :: Int -> Int -> RandOState+initRandOState subdepthlim seed =+  RandOState+  { integerState = fromIntegral seed+  , stdGenState  = mkStdGen seed+  , nodeCounter  = 0     +  , depthLimit   = subdepthlim+  , currentDepth = 0+  , deepestSoFar = 0+  , traceLevel   = 0+  }++-- | Increment the internal node counter of the random generator state. This is good for measuring+-- the "weight" of randomly generated objects. /NOTE:/ do not use this if you also start your+-- 'randO' instance with 'recurse', because 'recurse' also calls this function.+countNode_ :: RandO Int+countNode_ = do+  i' <- RandT $ gets nodeCounter+  let i = i' + 1+  RandT $ modify (\st -> st{nodeCounter=i})+  return i++-- | Algorithmically identical 'countNode_' but its function type is such that it can be written like so:+-- > 'countNode' $ do ...+-- whereas the 'countNode' function must be written like so:+-- > do { 'countNode_'; ... }+-- or+-- > countNode_ >> ...+-- /NOTE:/ do not use this if you also start your 'randO' instance with 'recurse', because 'recurse'+-- also calls this function.+countNode :: RandO a -> RandO a+countNode fn = countNode_ >> fn++newtype RandChoice o = RandChoice{ getChoiceArray :: Maybe (Array Int (RandO o)) }+instance Functor RandChoice where+  fmap f (RandChoice arr) = RandChoice $ fmap (fmap (fmap f)) arr+instance Monoid (RandChoice o) where+  mempty = RandChoice Nothing+  mappend (RandChoice a) (RandChoice b) = RandChoice $ msum+    [ do  (loA, hiA) <- fmap bounds a+          (loB, hiB) <- fmap bounds b+          listA <- fmap elems a+          listB <- fmap elems b+          return $ listArray (min loA loB, max hiA hiB) (listA++listB)+    , a, b+    ]++-- | Similar to monadic bind, allows you to create a new 'RandChoice' by using the value produced by+-- another 'RandChoice'.+bindRandChoice :: RandChoice o -> (o -> RandChoice p) -> RandChoice p+bindRandChoice (RandChoice arr) f = RandChoice $ fmap (fmap (\o -> o >>= runRandChoiceOf . f)) arr++-- | Instantiate your data types into this class if you can generate arbitrary objects from random+-- numbers using the 'RandO' monad. Minimal complete definition is one of either 'randO' or+-- 'randChoice', and one of either 'defaultO' or 'defaultChoice'.+class HasRandGen o where+  -- | This is the function used to generate a random object of a data type that only has one+  -- constructor. You must define either this or 'randChoice' or both. The 'randChoice' will be+  -- defined as @('randChoiceList' ['randO'])@.+  randO :: RandO o+  randO = runRandChoice+  -- | This is the function used to generate a random object of a data type that has multiple+  -- constructors. Use 'randChoiceList' to build a list of 'RandO' data types, each item producing+  -- an object with a different constructor. You must define either this or 'randO' or both. The+  -- 'randO' will be defined using @('runChoiceList' 'randChoice')@ by default.+  randChoice :: RandChoice o+  randChoice = randChoiceList [randO]+  -- | The 'randO' and/or 'randChoice' functions can be defined without any restrictions, they can+  -- even be called recursively. But since we are working with randomness, recursion may produce+  -- arbitrarily large objects which may consume all memory and crash the program. The 'recurse'+  -- function can be used to count the depth of the recursive data type constructed and to limit the+  -- depth, and when the limit is reached a non-recursive default value should be constructed+  -- instead. This is the function that should produce the non-recursive data.+  --+  -- Keep in mind that it is impossible to enforce whether or not the data generated by any function+  -- will be recursive or not unless the data type itself is inherently not recursive. So it is the+  -- programmers responsiblity to understand how to use this function. This function must terminate,+  -- it is your responsibility to see that it does, it is your responsability to make sure you never+  -- call a recursive function within this function.+  --+  -- For data types that are inherenly not recursive, for example types instantiating+  -- 'Prelude.Enum', this function may safely be defined by calling 'randO'. For recursive data+  -- types, if the data type instantiates 'Data.Monoid.Monoid', consider returning+  -- 'Data.Monoid.mempty'.+  -- +  -- Either this function or 'defaultChoice' must be defined.+  defaultO :: RandO o+  defaultO = runDefaultChoice+  -- | This function is to 'defaultO' what 'randChoice' is to 'randO': it lets you construct a+  -- random object from a list of choices, but like 'defaultO' every choice provided here must NOT+  -- be a recursive function.+  defaultChoice :: RandChoice o+  defaultChoice = randChoiceList [defaultO]++runRandChoiceOf :: RandChoice o -> RandO o+runRandChoiceOf (RandChoice{ getChoiceArray=arr }) = case arr of+  Nothing  -> fail "null RandChoice"+  Just arr -> let (lo, hi) = bounds arr in join $ (arr!) . (lo+) <$> nextInt (hi-lo)++runRandChoice :: HasRandGen o => RandO o+runRandChoice = runRandChoiceOf randChoice++runDefaultChoice :: HasRandGen o => RandO o+runDefaultChoice = runRandChoiceOf defaultChoice++randChoiceList :: forall o . [RandO o] -> RandChoice o+randChoiceList items = RandChoice{ getChoiceArray = guard (not $ null items) >> (Just arr) } where+  len = length items+  arr :: Array Int (RandO o)+  arr = listArray (0, len-1) items++instance HasRandGen ()       where { randO = return (); defaultO = randO; }+instance HasRandGen Int      where { randO = randInt; defaultO = randO; }+instance HasRandGen Integer  where { randO = fmap fromIntegral randInt; defaultO = randO; }+instance HasRandGen Char     where { randO = fmap chr randInt; defaultO = randO }+instance HasRandGen Word64   where { randO = fromIntegral <$> (randO::RandO Int); defaultO = randO; }+instance HasRandGen Rational where+  randO = return (%) <*> defaultO <*> ((+1) <$> defaultO)+  defaultO = randO+instance HasRandGen Double   where { randO = fromRational <$> randO; defaultO = randO; }+instance HasRandGen UTCTime  where+  randO = do+    day <- fmap (ModifiedJulianDay . unsign . flip mod 73000) randInt+    sec <- fmap (fromRational . toRational . flip mod 86400) randInt+    return (UTCTime{utctDay=day, utctDayTime=sec})+  defaultO = randO+instance HasRandGen NominalDiffTime where+  randO = randInteger (fromRational 0) $ \i -> do+    div <- randInt+    fmap (fromRational . (% fromIntegral div) . longFromInts) (replicateM (mod i 2 + 1) randInt)+  defaultO = randO+instance HasRandGen Name where { randO = fmap (fromUStr . randUStr) randInt; defaultO = randO; }+instance HasRandGen UStr where+  randO = fmap (ustr . unwords . fmap (uchars . toUStr)) (randList 0 9 :: RandO [Name])+  defaultO = randO+instance HasRandGen Bool where { randO = fmap (0/=) (nextInt 2); defaultO = randO; }+instance HasRandGen a => HasRandGen (Maybe a) where+  randO = randO >>= \n -> if n then return Nothing else fmap Just randO+  defaultO = return Nothing++instance (Ord p, HasRandGen p, HasRandGen o) => HasRandGen (T.Tree p o) where+  defaultO = return T.Void+  randO = recurse $ do+    branchCount <- nextInt 4+    cuts <- fmap (map (+1) . randToBase 6) randInt+    fmap (T.fromList . concat) $ replicateM (branchCount+1) $ do+      wx <- replicateM 6 randO+      forM cuts $ \cut -> do+        obj <- randO+        return (take cut wx, obj)++-- | Construct a value from an 'Prelude.Int'. Actually, you have a 50/50 chance of drawing a zero,+-- but this is because zeros are used often for you data type.+randInteger :: a -> (Int -> RandO a) -> RandO a+randInteger zero mkOther = do+  i <- randInt+  let (x, r) = divMod i 2+  if r==0 then return zero else mkOther x++-- | Generate a random object given a maximum recursion limit, a seed value, and a 'RandO' generator+-- function. The weight (meaning the number of calls to 'countNode', 'countNode_', or 'recurse') of+-- the generated item is also returned.+genRandWeightedWith :: RandO a -> Int -> Int -> IO (a, Int)+genRandWeightedWith (RandT gen) subdepthlim seed =+  fmap (fmap nodeCounter) $ runStateT gen (initRandOState subdepthlim seed)++-- | This function you probably will care most about. does the work of evaluating the+-- 'Control.Monad.State.evalState' function with a 'RandOState' defined by the same two parameters+-- you would pass to 'initRandOState'. In other words, arbitrary random values for any data type @a@+-- that instantates 'HasRandGen' can be generated using two integer values passed to this function.+genRandWeighted :: HasRandGen a => Int -> Int -> IO (a, Int)+genRandWeighted subdepthlim seed = genRandWeightedWith randO subdepthlim seed++-- | Like 'genRandWeightedWith' but the weight value is ignored, only being evaluated to the random+-- object,+genRandWith :: RandO a -> Int -> Int -> IO a+genRandWith gen subdepthlim seed = fmap fst $ genRandWeightedWith gen subdepthlim seed++-- | Like 'genRandWeightedWith' but the weight value is ignored, only being evaluated to the random+-- object.+genRand :: HasRandGen a => Int -> Int -> IO a+genRand subdepthlim seed = genRandWith randO subdepthlim seed++randTrace :: MonadIO m => String -> RandT m a -> RandT m a+randTrace msg rand = do+  trlev <- RandT $ gets traceLevel+  nc <- RandT $ gets nodeCounter+  sd <- RandT $ gets currentDepth+  let prin msg = liftIO $ do+        hPutStrLn stderr (replicate trlev ' ' ++ msg)+        hFlush stderr >>= evaluate+  () <- prin $ "begin "++msg++" c="++show nc++" d="++show sd+  RandT $ modify $ \st -> st{traceLevel=trlev+1}+  a  <- rand >>= liftIO . evaluate+  RandT $ modify $ \st -> st{traceLevel=trlev}+  () <- prin $ "end   "++msg+  return a++-- | Take another integer from the seed value. Provide a maximum value, the pseudo-random integer+-- returned will be the seed value modulo this maximum value (so passing 0 will result in a+-- divide-by-zero exception, passing 1 will always return 0). The seed value is then updated with+-- the result of this division. For example, if the seed value is 10023, and you pass 10 to this+-- function, the result returned will be 3, and the new seed value will be 1002.+--    Using numbers generated from this seed value is very useful for generating objects that are+-- somewhat predictable, but the contents of which are otherwise unpredictable. For example, if you+-- want to generate random functions but always with the names "a", "b", or "c", like so:+-- > a(...), b(...), c(...)+-- where the arguments to these functions can be arbitrary, then have your function generator+-- generate the names of these functions using 'nextInt' like so:+-- > 'Prelude.fmap' ('Prelude.flip' 'Prelude.lookup ('Prelude.zip' "abc" [0,1,2]))'nextInt' 3+-- then the arguments to these functions can be generated using 'randInt'. The names of the+-- functions will be predictable for your seed values: any seed value divisible by 3 will generate a+-- function named "a", but the arguments will be arbitrary because they were generated by 'randInt'.+nextInt :: Int -> RandO Int+nextInt maxval = if abs maxval==1 || maxval==0 then return 0 else do+  st <- RandT $ get+  let (i, rem) = divMod (integerState st) (fromIntegral (abs maxval))+  RandT $ put $ st{integerState=i}+  return (fromIntegral rem)++-- | Generate a random integer from the pseudo-random number generator.+randInt :: RandO Int+randInt = RandT $+  state (\st -> let (i, gen) = next (stdGenState st) in (i, st{stdGenState=gen}))++-- | Mark a recursion point, also increments the 'nodeCounter'. The recusion depth limit set when+-- evaluating a 'randO' computation will not be exceeded.  When the number of 'recurse' functions+-- called without returning has reached this limit and this function is evaluated again, the given+-- 'RandO' generator will not be evaluated, the default value will be returned.+recurse :: HasRandGen a => RandO a -> RandO a+recurse fn = do+  st <- RandT get+  if currentDepth st > depthLimit st+    then defaultO+    else do+      countNode_+      i <- (+1) <$> (RandT $ gets currentDepth)+      RandT $ modify (\st -> st{currentDepth = i, deepestSoFar = max (deepestSoFar st) i})+      a <- fn+      RandT $ modify (\st -> st{currentDepth = currentDepth st - 1})+      return a++-- | The 'nextInt' function lets you derive objects from a non-random seed value internal to the+-- state of the 'RandT' monad. This is useful for random objects that have multiple constructors,+-- and you want to generate one of every constructor by simply initializing the random seed with+-- incrementing integers.+--+-- However every instantiation of 'randChoice' makes use of this seed value. Consequently if your+-- data type is composed entirely of objects which all instantiate 'randChoice', every node of the+-- object will be generated by a non-random number. In some cases this is desirable, it allows you+-- to generate every possible object with a large enough sequence of random numbers.+--+-- However when you wish to generate a very random, varied set of random objects, this+-- predictability is not desirable. To get around this, you can use the 'scramble' function. This+-- will use the current seed value to initialize a new child random generator with a child random+-- seed, and the provided 'RandT' function will be evaluated with in this child environment. After+-- evaluation is complete, the parent seed is restored. Since the child random seed is derived from the+-- parent seed, you are still guaranteed to always generate the same object from the same seed value,+-- but the child object generated will be much more varied and less predictable.+-- +-- So instead of generating a child node of your object with ordinary 'randO', use 'scrambO' (which+-- is equivalent to @('scramble' 'randO')@ and this will make your objects more varied, even for+-- predictable input.+scramble :: RandO a -> RandO a+scramble fn = do+  newGen  <- randInt+  oldst   <- RandT get+  RandT (put $ oldst{ stdGenState=mkStdGen newGen })+  let wrap x = toInteger (fromIntegral x :: Word)+  x <- wrap <$> randInt+  y <- wrap <$> randInt+  RandT (modify $ \st -> st{ integerState = x*(1 + (toInteger (maxBound::Word))) + y })+  a <- fn+  RandT (modify $ \st -> st{ integerState=integerState oldst, stdGenState=stdGenState oldst })+  return a++-- | This function is defined simply as @('scramble' 'randO')@, but I expect it to be used often+-- enough it warrants it's own function name.+scrambO :: HasRandGen a => RandO a+scrambO = scramble randO++-- | The number of unique values a 'Prelude.Int' can be, which is @('Prelude.maxBound'+1)*2@.+intBase :: Integer+intBase = (fromIntegral (maxBound::Int) + 1) * 2++-- | Take an ordinary 'Prelude.Int' and make it unsigned by checking if it is a negative value, and+-- if it is, returning the maximum unsigned value plus the negative value, otherwise returning the+-- positive value unchanged. For example, -1 will return @2*('Prelude.maxBound'+1)-1@ and @+1@ will+-- return @1@.+unsign :: Int -> Integer+unsign i = if i<0 then intBase + fromIntegral i else fromIntegral i++-- | Creates a string of digits from 0 to the given @base@ value by converting a random unsigned+-- integer to the list of digits that represents the random integer in that @base@. For example, if+-- you want a list of digits from 0 to 4 to be produced from a number 54, pass 4 as the base, then+-- the number 54. Each digit of the base-4 number representation of 54 will be returned as a+-- separate integer: @[2,1,3]@ (from lowest to highest place value, where 123 in base 10 would+-- return the list @[3,2,1]@).+randToBase :: Int -> Int -> [Int]+randToBase base i = loop (unsign i)  where+  loop i = if i==0 then [] else let (i' , sym) = divMod i b in fromIntegral sym : loop i'+  b      = fromIntegral base++-- | When generating 'Prelude.Integers' from 'Int's, treat a list of 'Int's as a list of symbols in+-- a base M number, where M is the @('Prelude.maxBound'::'Prelude.Int')@ multiplied by two to allow+-- for every negative number to also be considered a unique symbol.+longFromInts :: [Int] -> Integer+longFromInts = foldl (\a b -> a*intBase + unsign b) 0++randEnum :: (Bounded x, Enum x) => x -> x -> RandO x+randEnum lo hi = fmap toEnum (nextInt (abs (fromEnum lo - fromEnum hi)))++----------------------------------------------------------------------------------------------------++randUStr :: Int -> UStr+randUStr = ustr . B.unpack . getRandomWord++randMultiName :: RandO [UStr]+randMultiName = do+  i0 <- randInt+  let (i1, len) = divMod i0 4+  fmap ((randUStr i1 :) . map randUStr) (replicateM len randInt)++-- | When you want to use 'randList' or 'randListOf', you must provide a maximum bound for the+-- number of values generated for the list. Lets say you want a maximum bound of 20 items for your+-- data types. It sounds reasonable, but if your data type is recursive, and your recursion depth+-- limit 'depthLimit' is set to 4, your data type has a chance of creating 20^4 or 160000 nodes! You+-- may want to call 'randListOf' or 'randList' with a diminishing upper bound, a bound which gets+-- lower and lower as the recursion depth increases.+--+-- That is the purpose of this function. You provide an initial integer value (like 24) and this+-- value will be logarithmically scaled based on the 'currentDepth' value. The scaling equation is:+-- > \x -> 'Prelude.floor' (x / 2^'depthLimit')+-- So if you provide a value of 24 to this function, the value returned will be:+-- > 'Prelude.floor' (24 / 2^'depthLimit')+-- And if the 'depthLimit' is 4 then @'Prelude.floor' (2 / 2^4) == 'Prelude.floor' (2/16) == 1@. So+-- for passing a value of 24 means the maximum number of nodes will be @24*12*6*3*1 == 5184@ nodes,+-- which is large, but considerably smaller than 160000 nodes.+depthLimitedInt :: Int -> RandO Int+depthLimitedInt x = getCurrentDepth >>= \d -> return (div x (2^d))++getCurrentDepth :: Monad m => RandT m Int+getCurrentDepth = RandT $ gets currentDepth++randListOf :: Int -> Int -> RandO a -> RandO [a]+randListOf minlen maxlen rando = do+  -- half of all lists will be null, unless the 'minlen' parameter is greater than 0+  minlen <- return (min minlen maxlen)+  maxlen <- return (max minlen maxlen)+  empt <- if minlen==0 then nextInt 2 else return 0+  if empt==1+    then return []+    else do+      ln <- nextInt (maxlen-minlen)+      replicateM (minlen+ln) rando++randList :: HasRandGen a => Int -> Int -> RandO [a]+randList lo hi = randListOf lo hi randO++defaultList :: HasRandGen a => Int -> Int -> RandO [a]+defaultList lo hi = randListOf lo hi defaultO++randRational :: Int -> RandO Rational+randRational i0 = do+  let (i1, len1) = divMod i0 4+      (_ , len2) = divMod i1 4+  a <- fmap longFromInts (replicateM (len1+1) randInt)+  b <- fmap longFromInts (replicateM (len2+1) randInt)+  return (a%b)++getRandomWord :: Int -> B.ByteString+getRandomWord i = randomWords ! (mod i (rangeSize (bounds randomWords) - 1))++randomWords :: Array Int B.ByteString+randomWords = listArray (0, length list - 1) (map B.pack list) where+  list = words $ unwords $+    [ "a academia accomplished added also an analysis and application applications apply are arent slim"+    , "argument arguments as at avoids be because been behavior between book both by calculus plus were"+    , "calling can change changes code commercial computability computation computer concepts earth was"+    , "constructs contrast conversely declarative definition depending depends describing metal key fee"+    , "designed developed development difference different domains domain easier effects fire water add"+    , "elaborations elements eliminating emphasize entscheidungsproblem eschewing star best least being"+    , "especially evaluation example executing expression facilitate financial formal greatest open etc"+    , "functional has have hope how however imperative industrial input investigate is home close where"+    , "it key lack lambda language languages largely like make many math mathematical may from flow she"+    , "motivations much mutable notion numeric of on one ones only organizations output paradigm pit he"+    , "specific pioneering practice predict produce program programming prominent purely rather trust I"+    , "recursion referential result roots same science side so software some specifically state move me"+    , "statistics style subject such supported symbolic system than that the they child this super mesh"+    , "transparency treats twice understand use used value values variety viewed which wide will bill X"+    , "dates times database structured listing setting dictionary returning throwing catching law factor"+    , "option procedure alpha beta electron proton neutron shift hard soft bean beam fix drug undo minus"+    , "field magic latice jump assemble area volume interesting slice sector region cylinder sphere plan"+    , "inside without trying patterned rules"+    ]+
+ src/Dao/RefTable.hs view
@@ -0,0 +1,75 @@+-- "src/Dao/RefTable.hs"  a data type which maps opaque reference+-- handles to 'Dynamic' objects.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++-- | This module is used to implement a kind of un-typed global state for the Dao runtime which can+-- store object of arbitrary type in a place that can be accessed anywhere. It is used for data+-- types like file handles which have their own unique identifiers and you don't need Dao to assign+-- it a new unique ID to it them for you, you can just index it by a hash of the the unique ID.+-- +-- Every value stored in a table gets it's own MVar, so updating the value is thread safe, but it is+-- a bit memory intensive. So a 'RefTable' should only be used for things that really need to be+-- well protected, like UNIX file descriptors or sockets, ordinary file handles, credentials,+-- handles to access databases -- anything that needs to be allocated and released in order for it+-- to be used during runtime.+module Dao.RefTable+  ( RefMonad,+    RefNode, refNodeDestructor, refNodeValue, refTableNode,+    RefTable, newRefTable, initializeWithKey, destroyWithKey+  )+  where++import qualified Dao.HashMap as H++import           Control.Applicative+import           Control.Concurrent.MVar+import           Control.Monad.Reader++----------------------------------------------------------------------------------------------------++type RefMonad key val a = ReaderT (RefTable key val) IO a++data RefNode a = RefNode{ refNodeDestructor :: IO (), refNodeValue :: MVar a }++refTableNode :: (a -> IO ()) -> a -> IO (RefNode a)+refTableNode destructor a = newMVar a >>= \mvar ->+  return $ RefNode{ refNodeDestructor=destructor a, refNodeValue=mvar }++newtype RefTable key a = RefTable { refTableMVar :: MVar (H.HashMap key (RefNode a)) }++newRefTable :: IO (RefTable key a)+newRefTable = RefTable <$> newMVar H.empty++initializeWithKey :: Ord key => a -> IO () -> H.Index key -> RefMonad key a (MVar a)+initializeWithKey o destructor key = do+  mvar <- H.hashLookup key <$> (asks refTableMVar >>= liftIO . readMVar)+  case mvar of+    Just node -> return (refNodeValue node)+    Nothing   -> do+      mvar <- liftIO $ newMVar o+      asks refTableMVar >>=+        liftIO . flip modifyMVar (\hmap -> return (H.hashInsert key (RefNode destructor mvar) hmap, mvar))++destroyWithKey :: Ord key => H.Index key -> RefMonad key a ()+destroyWithKey key = do+  mvar <- H.hashLookup key <$> (asks refTableMVar >>= liftIO . readMVar)+  case mvar of+    Nothing -> return ()+    Just  _ -> asks refTableMVar >>= liftIO . flip modifyMVar_ (return . H.hashDelete key)+
+ src/Dao/Stack.hs view
@@ -0,0 +1,88 @@+-- "src/Dao/Stack.hs"  provides the stack mechanism used for storing+-- local variables during evaluation.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++module Dao.Stack where++import qualified Data.Map as M++import           Control.Monad+import           Control.Monad.Identity++newtype Stack key val = Stack { mapList :: [M.Map key val] } deriving Show++emptyStack :: Stack key val+emptyStack = Stack []++stackLookup :: Ord key => key -> Stack key val -> Maybe val+stackLookup key stack = foldl (\f -> mplus f . (M.lookup key)) Nothing (mapList stack)++-- | Always update in the top of the stack, regardless of whether the key being updated has been+-- defined at some lower level in the stack. If the stack is empty, the update function is evaluated+-- with 'Prelude.Nothing' and the result @a@ is returned, but the updated @val@ is disgarded.+stackUpdateTopM+  :: (Monad m, Ord key)+  => (Maybe val -> m (a, Maybe val)) -> key -> Stack key val -> m (a, Stack key val)+stackUpdateTopM updVal key (Stack stack) = case stack of+  []      -> updVal Nothing >>= \ (a, _) -> return (a, Stack [])+  s:stack -> updVal (M.lookup key s) >>= \ (a, o) -> return (a, Stack $ M.alter (const o) key s : stack)++-- | If the key does not exist, the update will occur in the top level of the stack. If the key does+-- exist, regardless of whether the key exists in the top or in some lower level, the value at that+-- key will be updated in the level in which it is defined. If the stack is empty, the update+-- function is evaluated with 'Prelude.Nothing' and the result @a@ is returned, but the updated+-- @val@ is disgarded.+stackUpdateM+  :: (Monad m, Ord key)+  => (Maybe val -> m (a, Maybe val)) -> key -> Stack key val -> m (a, Stack key val)+stackUpdateM updVal key (Stack stack) = loop [] stack where+  loop rx stack = case stack of+    []      -> atTop (reverse rx)+    s:stack -> case M.lookup key s of+      Just  o -> updVal (Just o) >>= \ (a, o) ->+        return (a, Stack $ reverse rx ++ M.alter (const o) key s : stack)+      Nothing -> loop (s:rx) stack+  atTop stack = case stack of+    []      -> updVal Nothing >>= \ (a, _) -> return (a, Stack [])+    s:stack -> updVal Nothing >>= \ (a, o) -> return (a, Stack $ M.alter (const o) key s : stack)++stackUpdate+  :: Ord key+  => (Maybe val -> (a, Maybe val))+  -> key -> Stack key val -> (a, Stack key val)+stackUpdate upd key = runIdentity . stackUpdateM (return . upd) key++stackUpdateTop+  :: Ord key+  => (Maybe val -> (a, Maybe val))+  -> key -> Stack key val -> (a, Stack key val)+stackUpdateTop upd key = runIdentity . stackUpdateTopM (return . upd) key++-- | Define or undefine a value at an address on the top tree in the stack.+stackDefine :: Ord key => key -> Maybe val -> Stack key val -> Stack key val+stackDefine key val = snd . stackUpdate (const ((), val)) key++stackPush :: Ord key => M.Map key val -> Stack key val -> Stack key val+stackPush init stack = stack{ mapList = init : mapList stack }++stackPop :: Ord key => Stack key val -> (Stack key val, M.Map key val)+stackPop stack =+  let mx = mapList stack+  in  if null mx then (stack, M.empty) else (stack{mapList=tail mx}, head mx)+
+ src/Dao/StepList.hs view
@@ -0,0 +1,414 @@+-- "src/Dao/StepList.hs"  provides a fundamental data type used in the+-- Dao System, the "StepList", which is a cursor that can step forward+-- or backward through a list.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.+++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | This is a line-editor object, but it works with arbitrary lists of objects, but this will work+-- for editing arbitrary lists. You could use it to create an ordinary line editor by representing a+-- file as be a list of strings representing a file. each string could further be converted to a+-- StepList containing characters to edit the line. +--+-- This module provides a basic list cursor interface, that is, a list that you can step through+-- forward or backward, item by item. This is useful for building line editors. This module export+-- operators, so it is best not to import this module qualified. Therefore functions similar to+-- 'Data.Set.empty' or 'Data.Set.singleton' are named 'slEmpty' and 'slSingleton' to prevent name+-- conflicts without using qualified importing.+--+module Dao.StepList where++import           Control.Applicative+import           Control.Monad++import           Data.Array.IArray+import qualified Data.IntMap as I+import           Data.List+import           Data.Monoid+import           Data.Typeable++----------------------------------------------------------------------------------------------------++data StepList a+  = StepList+    { slCursor :: Int+    , slLength :: Int+    , slLeftOfCursor :: [a]+      -- ^ items to the left of the cursor are stored in reverse order. If your 'StepList' is:+      -- > list_A = [0, 1, 2, 3, 4] <> [5, 6, 7, 8]+      -- evaluating @'leftOfCursor' list_A@ produces:+      -- > [4, 3, 2, 1, 0]+    , slRightOfCursor :: [a]+      -- ^ items to the left of the cursor are stored in forward order. If your 'StepList' is:+      -- > list_A = [0, 1, 2, 3, 4] <> [5, 6, 7, 8]+      -- evaluating @'leftOfCursor' list_A@ produces:+      -- > [5, 6, 7, 8]+    }+  deriving (Eq, Ord, Show, Read, Typeable)++instance Monoid (StepList a) where { mempty = slEmpty; mappend = (+:+); }+instance Functor     StepList where { fmap  = slMap }+instance MonadPlus   StepList where { mzero = mempty; mplus = (+:+); }+instance Applicative StepList where { pure  = return; (<*>) = ap;      }+instance Alternative StepList where { empty = mempty; (<|>) = (+:+); }+instance Monad       StepList where+  -- | Return is defined by 'slSingletonL'. This is because when lists are used as a monad, the+  -- 'Control.Monad.return' operations that occur earlier in the computation place items in the list+  -- earlier than 'Control.Monad.return' operations that occur later in the computation. Therefore a+  -- monadic computation like @a >> b@ will have @a@ placed to the left of @b@.+  return = slSingletonL+  -- | Just like how the '(Prelude.>>=)' operator instantiated for Haskell lists is the+  -- 'Prelude.concatMap' function, the '(Prelude.>>=)' operator for 'StepList's is the 'slConcatMap'+  -- function.+  (>>=) = flip slConcatMap++-- | Test if the 'StepList' contains no elements.+slNull :: StepList a -> Bool+slNull sl = null (slLeftOfCursor sl) && null (slRightOfCursor sl)++-- | Create an empty 'StepList'.+slEmpty :: StepList a+slEmpty = StepList 0 0 [] []++-- | Create a 'StepList' with a single item to the right of the cursor.+slSingletonR :: a -> StepList a+slSingletonR a = StepList 1 1 [a] []++-- | Create a 'StepList' with a single item to the left of the cursor.+slSingletonL :: a -> StepList a+slSingletonL a = StepList 1 1 [a] []++-- | Create a 'StepList' from a list of elements and an initial cursor position. The cursor position+-- can be out of range, it will be placed at the end by default.+slFromList :: Int -> [a] -> StepList a+slFromList i lst =+  let len = length lst+      cur = max 0 i+      (left, right) = splitAt cur lst+  in  StepList+      { slCursor        = min cur len+      , slLength        = len+      , slLeftOfCursor  = left+      , slRightOfCursor = right+      }++-- | Create a 'StepList' with two lists, the items to the left of the cursor, and the items to the+-- right of the cursor. The elements of the list to the left of the cursor are not reversed when+-- constructing the 'StepList' with this constructor. When the cursor is moved back to the+-- beginning of the list, the items will be reversed, i.e.+-- > slToList (slFromList [0,1,2,3] [4,5,6,7])+-- will evaluate to the list:+-- > [3,2,1,0,4,5,6,7]+slFromLeftRight :: [a] -> [a] -> StepList a+slFromLeftRight left right =+  StepList{ slCursor=cur, slLength=cur+rightlen, slLeftOfCursor=left, slRightOfCursor=right } where+    cur      = length left+    rightlen = length right++-- | Assign values to integer indicies in the 'Data.IntMap.IntMap' data type, and this function will+-- convert the 'Data.IntMap.IntMap' to a 'StepList'. Negative indicies will be placed to the left of+-- the cursor, with the lowest value being furthest left, positive indicies will be placed to the+-- right of the cursor with the highest value being furthest right.+slFromIntMap :: I.IntMap a -> StepList a+slFromIntMap im = slFromLeftRight (fmap snd $ sortfst left) (fmap snd $ sortfst right) where+  sortfst = sortBy (\a b -> compare (fst a) (fst b))+  (left, right) = partition ((<0) . fst) $ I.assocs im++slToArray :: StepList a -> Maybe (Array Int a)+slToArray (StepList cur len left right) =+  if len==0+  then Nothing+  else Just $ array (negate cur, len-cur-1)+          (zip (iterate (subtract 1) (negate 1)) left ++ zip (iterate (+1) 0) right)++-- | Creates an array storing the list where the indicies are 'Data.Array.IArray.bounds' such that+-- value at index zero is the value returned by 'slHeadR', items before the cursor have negative+-- indicies, and items after the cursor are zero or positive. If the cursor is at the right-most+-- position of the list, the resulting array, every item is assigned to a negative index.+slFromArray :: Maybe (Array Int a) -> StepList a+slFromArray arr = case arr of+  Nothing  -> mempty+  Just arr ->+    let bnds = bounds arr+        (lo, hi) = maybe bnds id $ do+          (lo, hi) <- return bnds+          (lo, hi) <- return (min lo hi, max lo hi)+          return $ if lo>0 then (0, hi-lo) else (lo, hi)+        len   = hi - lo + 1+        cur   = negate lo+        left  = map (arr!) (takeWhile (>=lo) $ iterate (subtract 1) (negate 1))+        right = map (arr!) (takeWhile (<=hi) $ iterate (+1) 0)+    in  StepList cur len left right++-- | Convert the 'StepList' to an ordinary Haskell list.+slToList :: StepList a -> [a]+slToList (StepList _ _ left right) = reverse left ++ right++-- | When two 'StepList's are concatenated with @a +:+ b@ think of @b@ being inserted into the cursor+-- position at @a@, with all the items to the left of the cursor in @b@ being placed to the right of+-- the cursor of @a@ and all the items to the right of the cursor of @b@ being placed to the left+-- the cursor of @a@. Here is an ASCII illustration:+-- > list_A         = [a0, a1, a2, a3, a4]         <>                             [a5, a6, a7, a8]+-- >         list_B =                     [b0, b1] <> [b2, b3, b4, b5, b6, b7, b8]+-- > ----- concatenate -----+-- > list_A<>list_B = [a0, a1, a2, a3, a4, b0, b1] <> [b2, b3, b4, b5, b6, b7, b8, a5, a6, a7, a8]+(+:+) :: StepList a -> StepList a -> StepList a+(StepList c1 n1 b1 a1) +:+ (StepList c2 n2 b2 a2) = StepList (c1+c2) (n1+n2) (b1++b2) (a2++a1)+infixr 5 +:+++slMap :: (a -> b) -> StepList a -> StepList b+slMap f (StepList cur len left right) = StepList cur len (map f left) (map f right)++slConcat :: [StepList a] -> StepList a+slConcat = foldl (+:+) slEmpty++-- | The @(Control.Monad.>>=)@ operator applied to lists is the same as the 'Data.List.concatMap'+-- function. In the case of 'StepList', the @(Control.Monad.>>=)@ operator is defined with+-- 'Data.Monoid.mconcat' and 'Prelude.map'.+slConcatMap :: (a -> StepList b) -> StepList a -> StepList b+slConcatMap f = slConcat . map f . slToList++-- | Place an item to the left of the cursor. This operator binds to the RIGHT with a precedence of+-- 5, it does not bind left. The reason is that this operator is more similar to the Haskell list+-- operator @(:)@.+-- > x <: ([0, 1, 2] <> [3, 4])+-- >      ([0, 1, 2, x] <> [3, 4])+(<|) :: a -> (StepList a -> StepList a)+(<|) a (StepList cur len left right) = StepList (cur+1) (len+1) (a:left) right+infixr 5 <|++-- | Place an item to the right of the cursor. This operator binds to the right with a precedence of+-- 5, just like the Haskell list operator @(:)@.+-- > x :> ([0, 1, 2] <> [3, 4])+-- >      ([0, 1, 2] <> [x, 3, 4])+(|>) :: a -> StepList a -> StepList a+(|>) a (StepList cur len left right) = StepList cur (len+1) left (a:right)+infixr 5 |>++-- | Place an item to the left of the cursor. This operator binds to the RIGHT with a precedence of+-- 5, it does not bind left. The reason is that this operator is more similar to the Haskell list+-- operator @(++)@.+-- > [a0, a1, a2] <++ ([b0, b1, b2] <> [b3, b4])+-- >                  ([b0, ab, b2, a0, a1, a2] <> [b3, b4])+(<++) :: [a] -> StepList a -> StepList a+(<++) ox sl = let len = length ox in+  sl{ slLeftOfCursor = slLeftOfCursor sl ++ reverse ox+    , slCursor = slCursor sl + len+    , slLength = slLength sl + len+    }+infixr 5 <++++-- | Place an item to the right of the cursor. This operator binds to the right with a precedence of+-- 5, just like the Haskell list operator @(++)@.+-- > [a0, a1, a2] ++> ([b0, b1, b2] <> [b3, b4])+-- >                  ([b0, b1, b2] <> [a0, a1, a2, b3, b4])+(++>) :: [a] -> StepList a -> StepList a+(++>) ox sl = let len = length ox in+  sl{ slRightOfCursor = ox ++ slRightOfCursor sl+    , slLength = slLength sl + len+    }+infixr 5 ++>++-- | Returns 'Prelude.True' if it is possible to move the cursor left or right by @n@ steps.+slShiftCheck :: Int -> StepList a -> Bool+slShiftCheck delta (StepList cur len _ _) = inRange (0, len) (cur+delta)++-- | Returns 'Prelude.True' if it the index is within the bounds of the list.+slIndexCheck :: Int -> StepList a -> Bool+slIndexCheck i (StepList _ len _ _) = inRange (0, len) i++-- | Shift the cursor @delta@ elements to the left if @delta@ is negative, or @delta@ elements to+-- the right if @delta@ is positive.+slCursorShift :: Int -> StepList a -> StepList a+slCursorShift delta0 a@(StepList cur len left right)+  | delta0==0 = a+  | delta0< 0 =+      let delta = max delta0 (negate cur)+          (middle, left') = splitAt (abs delta) left+      in StepList (cur+delta) len left' (reverse middle ++ right)+  | delta0> 0 =+      let delta = min delta0 (len-cur)+          (middle, right') = splitAt delta right+      in StepList (cur+delta) len (reverse middle ++ left) right'+  | otherwise = error "case statement of Dao.StepList.slCursorShift"++-- | Place the cursor at an index position.+slCursorTo :: Int -> StepList a -> StepList a+slCursorTo i a@(StepList cur _ _ _) = slCursorShift (i-cur) a++-- | Lookup a value at an absolute index (not relative to the cursor).+slIndex :: Int -> StepList a -> Maybe a+slIndex i sl =+  let (StepList _ _ _ right) = slCursorShift i sl+  in case right of { [] -> Nothing; o:_ -> return o; }++-- | A bounds value expressed as a pair of indicies relative to the current cursor position can be+-- converted to an bounds value expressed as a pair of indicies relative to the 0th element in the+-- 'StepList'. This is the inverse operation of 'slAbsToRel'.+slRelToAbs :: StepList a -> (Int, Int) -> (Int, Int)+slRelToAbs (StepList cur _ _ _) (lo, hi) = (cur+lo, cur+hi)++-- | A bounds value expressed as a pair of indicies relative to the 0th position in the 'StepList'+-- can be converted to a bounds value expressed as a pair of indicies relative to the current+-- cursor position. This is the inverse operation of 'slRelToAbs'.+slAbsToRel :: StepList a -> (Int, Int) -> (Int, Int)+slAbsToRel (StepList cur _ _ _) (lo, hi) = (lo-cur, hi-cur)++-- | Selects items around the cursor, with the option of deleting the items selected from the+-- 'StepList'. The first boolean parameter indicates whether or not the list should be altered by+-- deleting the items that were selected. Items to the left of the cursor are selected if the+-- indicies are negative and items to the right of the cursor are selected if the indicies are+-- positive. Specify the range to select by passing a lower and upper bound relative to the cursor.+-- For example, to select a range of ten items, five before the cursor and five after the cursor,+-- use @slGetRelRange False (negate 5) 5@. To delete that same range from the 'StepList' and also+-- return it use @slGetRelRange True (negate 5) 5@.+--+-- This function evaluates to a pair of 'StepList's. The 'Prelude.fst' is the selected items, the+-- 'Prelude.snd' is the modified 'StepList' which may be identical to the parameter 'StepList' if+-- the 'doDelete::Bool' parameter is 'Prelude.False'.+slCutRelRange :: Bool -> (Int, Int) -> StepList a -> (StepList a, StepList a)+slCutRelRange doDelete (lo, hi) o@(StepList cur len left right) = maybe (mempty, o) id $ do+  let cutBiased minLen list = do+        let lim = Just . min minLen . abs+        lo <- lim $ min lo hi+        hi <- lim $ max lo hi+        let cutLen = hi-lo+        guard (cutLen/=0)+        (keep, list) <- Just $ splitAt lo     list+        (cut , list) <- Just $ splitAt cutLen list+        return (cutLen, keep, cut, list)+  case lo of+    lo|lo<0  -> case hi of+      hi|hi<=0 -> do+        (cutLen, keep, cut, left) <- cutBiased cur left+        cut <- Just $ StepList cutLen cutLen cut []+        Just $+          if doDelete+          then (cut, StepList (max 0 (cur-cutLen)) (len-cutLen) (left++keep) right)+          else (cut, o)+      hi|hi>0  -> do+        lo <- Just $ min cur (abs lo)+        hi <- Just $ min (len-cur) hi+        let cutLen = hi+lo+        (midLeft,  left ) <- Just $ splitAt lo left+        (midRight, right) <- Just $ splitAt hi right+        middle            <- Just $ StepList lo cutLen midLeft midRight+        Just $+          if doDelete+          then (middle, StepList (max 0 (cur-cutLen)) (len-cutLen) left right)+          else (middle, o)+      _ -> undefined+    lo|lo>=0 -> case hi of+      hi|hi<=0 -> if lo==hi then Nothing else Just $ slCutRelRange doDelete (hi, lo) o+      hi|hi>0  -> do+        (cutLen, keep, cut, right) <- cutBiased (len-cur) right+        cut <- Just $ StepList 0 cutLen [] cut+        Just $+          if doDelete+          then (cut, StepList cur (max cur (len-cutLen)) left (keep++right))+          else (cut, o)+      _ -> undefined+    _ -> undefined++-- | Like 'slCutRelRange' but operates on an upper and lower bound indicated by absolute indicies,+-- rather than indicies relative to the cursor.+slCutAbsRange :: Bool -> (Int, Int) -> StepList a -> (StepList a, StepList a)+slCutAbsRange doDelete bnds list = slCutRelRange doDelete (slAbsToRel list bnds) list++slDeleteRelRange :: (Int, Int) -> StepList a -> StepList a+slDeleteRelRange bnds = snd . slCutAbsRange True bnds++slDeleteAbsRange :: (Int, Int) -> StepList a -> StepList a+slDeleteAbsRange bnds list = slDeleteRelRange (slAbsToRel list bnds) list++slCopyRelRange :: (Int, Int) -> StepList a -> StepList a+slCopyRelRange bnds = fst . slCutRelRange False bnds++slCopyAbsRange :: (Int, Int) -> StepList a -> StepList a+slCopyAbsRange bnds list = slCopyRelRange (slAbsToRel list bnds) list++-- | Many functions may need to modify a 'StepList' but only on the elements to the left or right of+-- the cursor. These functions take a boolean type called 'Bias'+data Bias = ToLeft | ToRight deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read)++-- | Modify the items to the left or right of the cursor. The function will return a polymorphic+-- value paired with an updated list of items to the left of the cursor.+biasedApply :: Bias -> ([elems] -> (result, [elems])) -> StepList elems -> (result, StepList elems)+biasedApply bias f (StepList cur len left right) = case bias of+  ToRight -> let (result, right') = f right in (result, StepList cur (length right') left right')+  ToLeft  -> +    let (result, left') = f left+        newlen = length left'+    in (result, StepList newlen (len-cur+newlen) left' right)++-- | Evaluates to true if the cursor is beyond the left or right-most position in the list.+slAtEnd :: Bias -> StepList a -> Bool+slAtEnd bias (StepList cur len _ _) = case bias of+  ToRight -> cur==len+  ToLeft  -> cur==0++-- | Move the cursor to the right-most or left-most end of the 'StepList', depending on the 'Bias'+-- value given. The word Return has nothing to do with monad, we use this term because this function+-- is similar to the /carriage return/ of a typewriter.+slReturn :: Bias -> StepList a -> StepList a+slReturn bias (StepList cur len left right) = case bias of+  ToLeft  -> StepList 0 (cur+len) [] (reverse left ++ right)+  ToRight -> StepList len len (left ++ reverse right) []++slHeadR :: StepList a -> a+slHeadR (StepList _ _ _ a) = head a++slHeadL :: StepList a -> a+slHeadL (StepList _ _ a _) = head a++slTail :: Bias -> StepList elems -> StepList elems+slTail bias = snd . biasedApply bias ((,) () . tail)++slTake :: Bias -> Int -> StepList a -> StepList a+slTake bias n = snd . biasedApply bias ((,) () . take n)++slTakeWhile :: Bias -> (a -> Bool) -> StepList a -> StepList a+slTakeWhile bias p = snd . biasedApply bias ((,) () . takeWhile p)++slDrop :: Bias -> Int -> StepList a -> StepList a+slDrop bias n = snd . biasedApply bias ((,) () . drop n)++slDropWhile :: Bias -> (a -> Bool) -> StepList a -> StepList a+slDropWhile bias p = snd . biasedApply bias ((,) () . dropWhile p)++slSplitAt :: Bias -> Int -> StepList a -> ([a], StepList a)+slSplitAt bias n = biasedApply bias (splitAt n)++slSpan :: Bias -> (a -> Bool) -> StepList a -> ([a], StepList a)+slSpan bias p = biasedApply bias (span p)++slBreak :: Bias -> (a -> Bool) -> StepList a -> ([a], StepList a)+slBreak bias p = biasedApply bias (break p)++-- | Apply a modifier to the whole list, try to keep the cursor in the same place. If the 'StepList'+-- shrinks below where the cursor was, the cursor is placed at the end of the 'StepList'.+slMapAll :: ([a] -> [b]) -> StepList a -> StepList b+slMapAll fn (StepList cur _ left right) =+  let (left', right') = splitAt cur (fn $ reverse left ++ right)+      newlen = length left' + length right'+  in StepList (min cur newlen) newlen (reverse left') right'+
+ src/Dao/String.hs view
@@ -0,0 +1,521 @@+-- "src/Dao/String.hs"  provides the fundamental string data type+-- called "UStr" which is used throughout the Dao System.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.+++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}++-- | This module has two purposes. Firstly, this module depends on no other module in the Dao+-- program, so it may be imported by any other module, and as such it provides the classes and+-- functions that must be available to every module. Most of these essential functions are related+-- to strings, which is why this module is named so.+--+-- Therefore secondly, this module provides the /universal string/ data type 'UStr', and a type+-- class 'UStrType' that allows you to declare arbitrary data types to be convertible to and from+-- universal strings. Universal strings are built upon the "Data.ByteString.Lazy.UTF8" module in+-- the @utf8-string@ package of the Haskell platform. All strings used in the Dao runtime are stored+-- as this data type.+--+-- /NOTE:/ though this module is absolutely essential to every other module in the Dao system, not+-- all data structures should need to instantiate 'UStrType'. By contrst, the+-- 'Dao.Interpreter.Structured' (not defined in this module) should be instantiated by nearly all+-- data structures, especially if it is necessary to manipulate these structures within the Dao+-- programming language.+--+-- Dao is a high-level language, like a macro language or a scripting language. One thing+-- scripting/meta languages all have in common is the use of strings as a way to store and transmit+-- data in a human-readable but structured format; strings are often the universal intermediate code+-- of the runtime environment. Data structures can be converted to a string, stored in memory,+-- transmitted over a socket or pipe, saved to disk. Data from the disk, the socket, or in memory+-- can be parsed to reconstruct the data structures.+--+-- However it is my opinion that use of strings as intermediate data structures is very poor design+-- in any programming language; it is an anti-pattern. I believe the universal data type should the+-- tree rather than the string. Therefore I have provided the "Dao.Tree" and "Dao.Struct" modules,+-- and the 'Dao.Interpreter.Structured' type class which expand on the ideas of 'Prelude.Show' and+-- 'Prelude.Read' by using a 'Dao.Tree.Tree' as the intermediate data structure, rather than a+-- 'Dao.String.UStr'.+module Dao.String where++import           Control.Monad+import           Control.Monad.State+import           Control.DeepSeq+import           Control.Exception (assert)++import           Data.String+import           Data.Monoid+import           Data.Typeable+import qualified Data.Binary               as B+import           Data.Bits+import           Data.Char+import           Data.List (partition, stripPrefix)+import           Data.Word+import           Data.Array.Unboxed+import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Data.ByteString.Lazy      as B+import qualified Codec.Binary.UTF8.String  as UTF8++import           Numeric++-- Necessary for the HasNullValue instances+import           Data.Int+import           Data.Ratio+import           Data.Complex+import           Data.Time.Clock+import qualified Data.IntMap as IM+import qualified Data.Map    as M+import qualified Data.Set    as S++-- | Objects which can be used as a predicate testing whether or not the object is null, or of a+-- default value, should instantiate this class.+class HasNullValue a where { nullValue :: a; testNull :: a -> Bool; }+instance HasNullValue ()   where { nullValue = (); testNull () = True; }+instance HasNullValue UStr where { nullValue = mempty; testNull = (==mempty); }+instance HasNullValue [a]  where { nullValue = []; testNull = null; }+instance HasNullValue Char where { nullValue = '\0'; testNull = (==nullValue); }+instance HasNullValue Int  where { nullValue = 0; testNull = (==nullValue); }+instance HasNullValue Int64  where { nullValue = 0; testNull = (==nullValue); }+instance HasNullValue Word   where { nullValue = 0; testNull = (==nullValue); }+instance HasNullValue Word64 where { nullValue = 0; testNull = (==nullValue); }+instance HasNullValue Double where { nullValue = 0; testNull = (==nullValue); }+instance HasNullValue Integer where { nullValue = 0; testNull = (==nullValue); }+instance HasNullValue (Ratio Integer) where { nullValue = 0%1; testNull = (==nullValue); }+instance HasNullValue (Complex Double) where { nullValue = 0:+0; testNull = (==nullValue); }+instance HasNullValue NominalDiffTime where { nullValue = fromRational 0; testNull = (==nullValue); }+instance HasNullValue (IM.IntMap a)   where { nullValue = IM.empty; testNull = IM.null }+instance HasNullValue (M.Map k a)     where { nullValue = M.empty; testNull = M.null }+instance HasNullValue (S.Set a)       where { nullValue = S.empty; testNull = S.null }+instance HasNullValue U.ByteString    where { nullValue = mempty; testNull = (==mempty); }++-- | This is the /universal string/ type. It is a @newtype@ wrapper around+-- 'Data.ByteString.Lazy.UTF8.ByteString', but has an API that is used throughout the Dao system.+-- There is serious consideration to replace this module with "Data.Text", but even if that happens,+-- this module will be kept to provide a stable API to the string package upon which it is built.+newtype UStr = UStr { toUTF8ByteString :: U.ByteString } deriving (Eq, Ord, Typeable)+instance Monoid UStr where { mempty = toUStr ""; mappend a b = toUStr (uchars a ++ uchars b); }++-- | To provide intermediate string representations of data structures is one of the purposes of+-- 'Prelude.Show' and 'Prelude.Read' in the Haskell language. In Haskell, 'Prelude.Read' and+-- 'Prelude.Show' must, by convention, output a string that can be converted back to an exactly+-- equivalent data structure to the structure that produced the output when the output string is+-- parsed by 'Prelude.Read'. In other words @read (show a) == a && show (read a) == a@ should+-- evaluate to 'Prelude.True' for any type of @a@.+-- +-- This is not merely a convention for the 'UStrType', it is a requirement. The minimal complete+-- definition is 'toUStr' and one or both of 'fromUStr' and 'maybeFromUStr'. The 'nil' function is+-- part of the minimal complete definition, except when your data type is also an instance of+-- 'Data.Monoid.Monoid'. If your data type is also a 'Data.Monoid.Monoid', then the default instance+-- of 'nil' is 'Data.monoid.mempty'.+-- +-- Another big difference between 'UStrType' and 'Prelude.Show'/'Prelude.Read' is that 'UStrType' is+-- not intented to be used to construct parsers, it is used as an abstract interface to a parser.+-- 'Prelude.Read' provides 'Prelude.lex' for taking a lexeme from the head of the input,+-- 'Prelude.readParen' for parsing items from within parentheses, and 'readsPrec' which+-- parameterizes the current precedence value and allows you to backtrack if a lexeme has a lower+-- prescedence. All of this functionality (and more) is provided in the "Dao.Parser"+-- module, it is not provided here in the 'UStrType'.+-- +-- When instantiating this class, you will may find the 'uchars' and 'ustr' to be useful if parsing+-- strings is necessary. If you want to use 'Prelude.Show' to instantiate 'toUStr', you can simply+-- use 'derive_toUStr' and 'derive_fromUStr'. The 'uchars' function is used to convert any+-- 'UStrType' to a 'Prelude.String' by first converting the 'UStrType' to a 'UStr', and 'ustr' is+-- does the inverse, however 'UStr' also instantiates 'UStrType' /so the way to convert a 'UStr' to+-- a 'Prelude.String' is to use 'uchars', the way to convert a 'Prelude.String' to a 'UStr' is to+-- use 'ustr'/. +class UStrType a where+  -- | Like 'Prelude.Show.show', converts your data type to a universal string.+  toUStr :: a -> UStr+  -- | Like 'Prelude.read', constructs your data type from a universal string.+  fromUStr :: UStr -> a+  fromUStr str = maybe (error ("cannot construct data from UStr "++show str)) id (maybeFromUStr str)+  -- | Like 'Prelude.reads' except the entire string must be consumed, and the return type is a+  -- 'Prelude.Maybe' instead of a list. The return type here is not similar to+  -- 'Prelude.ReadS' which is a synonym for @'Prelude.String' -> [(a, 'Prelude.String')]@ a pair+  -- containing the read object and the remainder.+  maybeFromUStr :: UStr -> Maybe a+  maybeFromUStr = Just . fromUStr+  nil :: a+  nil = fromUStr mempty+instance UStrType UStr where { toUStr = id; fromUStr = id; }+instance UStrType String where+  toUStr = UStr . U.fromString+  fromUStr = U.toString . toUTF8ByteString+instance UStrType U.ByteString where+  toUStr = UStr+  fromUStr = toUTF8ByteString+  maybeFromUStr = Just . fromUStr++-- | This function lets you use the instantiation of 'Prelude.Show' to instantiate 'toUStr',+-- typically used when your data type uses Haskell's @deriving@ keyword to derive 'Prelude.Show'.+-- Note that this function also requires you to instantiate 'Prelude.Read' (also, perhaps, by the+-- @deriving@ keyword), because although this function does not use any of the 'Prelude.Read'+-- functions, this requirement emphasizes the importance of 'UStr' being a data structure that is+-- used to store an intermediate representation of structured data.+derive_ustr :: (Enum a, Read a, Show a) => a -> UStr+derive_ustr = toUStr . show++-- | This function lets you use the instantiation of 'Prelude.Read' to instantiate 'toUStr',+-- typically used when your data type uses Haskell's @deriving@ keyword to derive 'Prelude.Read'.+-- Note that this function also requires you to instantiate 'Prelude.Show' (also, perhaps, by the+-- @deriving@ keyword), because although this function does not use any of the 'Prelude.Show'+-- functions, this requirement emphasizes the importance of 'UStr' being a data structure that is+-- used to store an intermediate representation of structured data.+derive_fromUStr :: (Enum a, Read a, Show a) => UStr -> a+derive_fromUStr = read . uchars++-- | This function lets you use the instantiation of 'Prelude.Read' to instantiate 'toUStr',+-- typically used when your data type uses Haskell's @deriving@ keyword to derive 'Prelude.Read'.+-- Note that this function also requires you to instantiate 'Prelude.Show' (also, perhaps, by the+-- @deriving@ keyword), because although this function does not use any of the 'Prelude.Show'+-- functions, this requirement emphasizes the importance of 'UStr' being a data structure that is+-- used to store an intermediate representation of structured data.+derive_maybeFromUStr :: (Enum a, Read a, Show a) => UStr -> Maybe a+derive_maybeFromUStr u = case reads (uchars u) of+  [(a, "")] -> Just a+  _         -> Nothing++-- | Convert a 'Prelude.String' to an object classed as a 'UStrType' by first converting it to a+-- 'UStr' using 'toUStr'. /NOTE:/ this is the function you use to convert a 'Prelude.String' to a+-- 'UStr', and for the 'UStr' type, this function never fails (never evaluates to the "bottom"+-- value).+ustr :: UStrType str => String -> str+ustr = fromUStr . toUStr++-- | Convert a 'Prelude.String' to an object classed as a 'UStrType' by first converting it to a+-- 'UStr' using 'toUStr', but uses 'maybeFromUStr' to convert from the 'UStrType' object. /NOTE:/+-- this is the function you use to convert a 'Prelude.String' to a 'UStr' (this is possible because+-- 'UStr' instantiates 'UStrType'), and for the 'UStr' type, this function never evaluates to+-- 'Prelude.Nothing'.+maybeUStr :: UStrType str => String -> Maybe str+maybeUStr = maybeFromUStr . toUStr++-- | Convert an object classed as a 'UStrType' to a 'Prelude.String'. /NOTE:/ this is the function+-- you should use to convert a 'UStr' to a 'Prelude.String' (this is possible because 'UStr'+-- instantiates 'UStrType').+uchars :: UStrType str => str -> String+uchars = U.toString . toUTF8ByteString . toUStr++-- | Convert an object classed as a 'UStrType' to a @['Data.Word.Word8']@ list. Since 'UStr's store+-- data as UTF-8 encoded strings, this function simply returns the UTF-8 formatted octet stream from+-- that the 'Data.ByteString.Lazy.UTF8.ByteString' data structure. Of course, unless your 'UStrType'+-- is simply a @newtype@ of 'UStr' a conversion to a 'UStr' is done behind the scenes, which will+-- transparently encode a UTF8 string.+utf8bytes :: UStrType str => str -> [Word8]+utf8bytes = UTF8.encode . uchars . toUStr++-- | The inverse of 'utf8bytes', tries to decode a stream of octets into a properly formatted UTF-8+-- 'Data.ByteString.Lazy.UTF8.ByteString'. If encoding fails, this function evaluates to+-- 'Prelude.error' (evaluates to the "bottom" value).+upack :: [Word8] -> UStr+upack ax = toUStr (UTF8.decode ax)++-- | Modify a 'UStr' with the APIs provided in the "Data.ByteString.UTF8.Lazy" module.+fmapUTF8String :: (U.ByteString -> U.ByteString) -> UStr -> UStr+fmapUTF8String f = UStr . f . toUTF8ByteString++-- | Split a longer string up by the shorter string, for example:+-- > splitString (ustr "--") (one-one -- two-two -----> three-three -- four-four")+-- will be split to+-- > ["one-one ", " two-two ", "", "-> three-three ", " four-four"]+splitString :: UStr -> UStr -> [UStr]+splitString a b = case compare la lb of+  EQ -> return $ if a==b then nil else a+  LT -> delstr a b+  GT -> delstr b a+  where+    la = ulength a+    lb = ulength b+    len = min la lb+    loop ox str i ax bx =+      if i>0+      then case stripPrefix ax bx of+        Nothing -> loop ox (head bx : str) (i-1) ax (tail bx)+        Just bx -> loop (ustr (reverse str) : ox) "" (i-len) ax bx+      else reverse $ ustr (reverse str ++ bx) : ox+    delstr a b = loop [] "" (abs $ lb-la) (uchars a) (uchars b)++----------------------------------------------------------------------------------------------------++-- | A Variable-Length Integer (VLI) encoder. The bits of a variable-length integer will have a+-- format like so:+-- >      bit column number: 7 6543210+-- >                         ---------+-- > 1st highest order byte: 1 XXXXXXX+-- > 2nd highest order byte: 1 XXXXXXX+-- > 3rd highest order byte: 1 XXXXXXX+-- > ...+-- > lowest order byte     : 0 XXXXXXX+-- If the highest-order bit is a one, it indicates there are more bytes to follow. If the highest+-- order bit is 0, then there are no more bytes. The 7 lower-order bits will be concatenated in+-- /big-endian order/ to form the length value for the string. By this method, most all strings+-- will have a length prefix of only one or two bytes.+vlIntegralToWord8s :: (Integral a, Bits a) => a -> [Word8]+vlIntegralToWord8s = reverse . (\ (a:ax) -> (a .&. 0x7F) : ax) .+  fix (\loop w -> let v = 0x80 .|. fromIntegral (w .&. 0x7F)+                  in  case shiftR w 7 of{ 0 -> [v]; w -> v : loop w; })++-- | Inverse operation of 'bitsToVLI'+vlWord8sToIntegral :: (Integral a, Bits a) => [Word8] -> (a, [Word8])+vlWord8sToIntegral = loop 0 where+  fn   a w  = shiftL a 7 .|. fromIntegral (w .&. 0x7F) +  loop a wx = case wx of+    []   -> (a, [])+    w:wx -> if w .&. 0x80 == 0 then (fn a w, wx) else loop (fn a w) wx++-- | Since a negative number expressed in a 'Prelude.Integer' type translates to an infinite+-- sequence of 0xFF bytes when converting it to a VLI, it needs to be encoded specially with a+-- negation bit in the very first position.+vlIntegerToWord8s :: Integer -> [Word8]+vlIntegerToWord8s w = reverse $ (\ (b:bx) -> (if w<0 then b .|. 0x40 else b):bx) $ loop (abs w) where+  loop w = fromInteger (w .&. 0x3F) :+    fix (\loop w -> case w of+            0 -> []+            w -> (0x80 .|. fromInteger (w .&. 0x7F)) : loop (shiftR w 7)+        ) (shiftR w 6)++vlWord8sToInteger :: [Word8] -> (Integer, [Word8])+vlWord8sToInteger = loop 0 where+  fn s m a w  = shiftL a s .|. fromIntegral (w .&. m)+  loop a wx = case wx of+    []   -> (a, [])+    w:wx ->+      if w .&. 0x80 == 0+        then ((if w .&. 0x40 == 0 then id else negate) $ fn 6 0x3F a w, wx)+        else loop (fn 7 0x7F a w) wx++-- | When reading from a binary file, gather the bits of a Variable-Length Integer.+vlGatherWord8s :: B.Get [Word8]+vlGatherWord8s = loop [] where+  loop wx = B.getWord8 >>= \w -> if w .&. 0x80 == 0 then return (wx++[w]) else loop (wx++[w])++-- | Encode only positive 'Prelude.Integer's. This differs from 'vlPutInteger' in that the sign of+-- the integer is not stored in the byte stream, saving a single bit of space. This can actually+-- simplify some equations that expect an VLInteger to be encoded as a multiple-of-7 length string+-- of bits as you don't need to make additional rules for the final byte which would only have+-- 6-bits if the sign is stored with it.+vlPutPosInteger :: Integer -> B.Put+vlPutPosInteger i = assert (i>=0) $ mapM_ B.putWord8 $ vlIntegralToWord8s $ i++-- | Decode only positive 'Prelude.Integer's. This differs from 'vlPutInteger' in that the sign of+-- the integer is not stored in the byte stream, saving a single bit of space. This can actually+-- simplify some equations that expect an VLInteger to be encoded as a multiple-of-7 length string+-- of bits as you don't need to make additional rules for the final byte which only have 6-bits if+-- the sign is stored with it.+vlGetPosInteger :: B.Get Integer+vlGetPosInteger = fmap (fst . vlWord8sToIntegral) vlGatherWord8s++-- | Encode a positive or negative 'Prelude.Integer' using 'vlWord8sToInteger'. The sign of the integer+-- is stored in the final byte in the list of encoded bytes, so the final encoded byte only has 6+-- bits of information, rather than 7 in the case of positive integers.+vlPutInteger :: Integer -> B.Put+vlPutInteger = mapM_ B.putWord8 . vlIntegerToWord8s++-- | Decode a positive or negative 'Prelude.Integer' using 'vlWord8sToInteger'. The sign of the integer+-- is stored in the final byte in the list of encoded bytes, so the final encoded byte only has 6+-- bits of information, rather than 7 in the case of positive integers.+vlGetInteger :: B.Get Integer+vlGetInteger = fmap (fst . vlWord8sToInteger) vlGatherWord8s++-- | Return the length of the 'UStr'.+ulength :: UStr -> Int+ulength = U.length . toUTF8ByteString++-- | Length of a list, but unlike 'Data.List.length', allows a polymorphic length type.+iLength :: Num len => [a] -> len+iLength = foldl (+) 0 . map (const 1)++-- | Used to encode a 'UStr' data type without any prefix at all. The instantiation of 'UStr' into+-- the 'Data.Binary.Binary' class places a prefix before every 'UStr' as it is serialized, allowing+-- it to be used more safely in more complex data types.+encodeUStr :: UStr -> B.Put+encodeUStr u = mapM_ B.putWord8 $+  vlIntegralToWord8s (U.length (toUTF8ByteString u)) ++ (UTF8.encode (uchars u))++-- | Used to decode a 'UStr' data type without any prefix. The instantiation of 'UStr' into the+-- 'Data.Binary.Binary' class places a prefix before every 'UStr' as it is serialized, allowing it+-- to be used more safely in more complex data types.+decodeUStr :: B.Get UStr+decodeUStr = do+  (strlen, undecoded) <- fmap vlWord8sToIntegral vlGatherWord8s+  if null undecoded+    then  fmap (toUStr . (UTF8.decode)) (replicateM strlen B.getWord8)+    else  fail "binary data decoder failed on UStr"++----------------------------------------------------------------------------------------------------++bytesBitArith :: (Word8 -> Word8 -> Word8) -> B.ByteString -> B.ByteString -> B.ByteString+bytesBitArith f a b = B.pack $ map (uncurry f) $ B.zip a b++bytesShift :: B.ByteString -> Int64 -> B.ByteString+bytesShift str i = let (len, r) = fmap fromIntegral (divMod (abs i) 8) in case compare i 0 of+  EQ -> str -- identity+  LT -> mappend (B.replicate len 0) $ if r==0 then str else -- shift right+    snd $ B.mapAccumL (\prev b -> (b, shiftR b r .|. rotateR ((2^r-1) .&. prev) r)) 0 str+  GT -> -- shift left+    (if r==0 then id else snd . B.mapAccumR (\prev b -> (b, shiftL b r .|. ((2^r-1) .&. prev))) 0+    ) (B.drop len str)++bytesRotate :: B.ByteString -> Int64 -> B.ByteString+bytesRotate str i =+  let { len = B.length str; (cur8, r) = fmap fromIntegral (divMod i (len*8)); cur = div cur8 8; }+  in if r==0 then str else let { (a, b) = B.splitAt cur str; str = b<>a; } in+    snd $ B.mapAccumL (\prev b -> (b, shiftL b r .|. ((2^r-1) .&. prev))) (B.last str) str++bytesBit :: Int64 -> B.ByteString+bytesBit i = let (len, r) = fmap fromIntegral (divMod i 8) in+  if r==0 then B.snoc (B.replicate len 0) 1 else B.snoc (B.replicate (len-1) 0) (bit r)++bytesTestBit :: B.ByteString -> Int64 -> Bool+bytesTestBit str i = let (len, r) = fmap fromIntegral (divMod i 8) in testBit (B.index str len) r++bytesBitSize :: B.ByteString -> Int64+bytesBitSize = (8*) . B.length++bytesPopCount :: B.ByteString -> Int64+bytesPopCount = B.foldl (\count b -> count + fromIntegral (popCount b)) 0++----------------------------------------------------------------------------------------------------++instance IsString UStr where { fromString = ustr }+instance Read UStr where { readsPrec n str = map (\ (s, rem) -> (toUStr (s::String), rem)) $ readsPrec n str }+instance Show UStr where { show u = show (uchars u) }+instance B.Binary UStr where+  put u = encodeUStr u+  get   = decodeUStr+instance NFData UStr where { rnf (UStr a) = deepseq a () }++-- | A type synonym for 'UStr' used where a string is used as some kind of identifier.+newtype Name = Name { nameToUStr :: UStr } deriving (Eq, Ord, Typeable)+instance Monoid Name where { mempty = nil; mappend (Name a) (Name b) = Name (a<>b); }+instance Show Name where { show = show . nameToUStr }+instance UStrType Name where+  toUStr = nameToUStr+  maybeFromUStr nm = +    let str = uchars nm+        ck f c = c=='_' || f c+    in  case str of +          c:cx | ck isAlpha c || and (fmap (ck isAlphaNum) cx) -> Just (Name nm)+          _ -> Nothing+  fromUStr str = maybe (error msg) id $ maybeFromUStr str where+    msg = "'Dao.String.Name' object must be constructed from alpha-numeric and underscore characters only:\n"+      ++ take 256 (uchars str)+instance IsString Name where { fromString = ustr }+instance B.Binary Name where+  put (Name u) = encodeUStr u+  get = decodeUStr >>= \u -> case maybeFromUStr u of+    Just nm -> return nm+    Nothing -> fail "binary data contains invalid 'Dao.String.Name' object"+instance NFData Name where { rnf (Name a) = deepseq a () }++-- | A type synonym for 'UStr' used where a string is storing a file path or URL.+type UPath = UStr++----------------------------------------------------------------------------------------------------++-- | Breaks a long list into a list of lists no longer than the specified length.+breakInto :: Int -> [a] -> [[a]]+breakInto i bx = if null bx then [] else let (grp, bx') = splitAt i bx in grp : breakInto i bx'++-- | An array mapping 6-bit values to base-64 character symbols+base64Symbols :: UArray Word Char+base64Symbols = listArray (0,63) (['A'..'Z']++['a'..'z']++['0'..'9']++"+/")++-- | Encoding arbitrary bytes in a 'Data.ByteString.Lazy.ByteString' to base-64 character symbols+-- according to RFC 3548.+b64Encode :: B.ByteString -> [[Char]]+b64Encode = breakInto 76 . concatMap enc . breakInto 3 . B.unpack where+  windows = [(0xFC0000, 18), (0x03F000, 12), (0x000FC0, 6), (0x00003F, 0)]+  enc [] = []+  enc bx =+    let len = length bx+        buf = foldl (\buf b -> shiftL buf 8 .|. fromIntegral b) 0 (take 3 (bx++replicate (3-len) 0))+    in  take 4 $ (++"==") $ take (len+1) $ flip map windows $ \ (mask, shft) ->+          base64Symbols ! shiftR (mask.&.buf) shft++-- | An array mapping base-64 character symbols to their 6-bit values.+base64Values :: UArray Char Int+base64Values = array ('+', 'z') $ concat $+  [ zip ['+', 'z'] (repeat 0xAAAAAAA) -- 0xAAAAAAA is the undefined value+  , zip ['A'..'Z']  [0..25]+  , zip ['a'..'z'] [26..51]+  , zip ['0'..'9'] [52..61]+  , [('+', 62), ('/', 63), ('=', 0xFFFFFFF)] -- 0xFFFFFFF is the end-of-input value+  ]++-- | Decoding base-64 character symbols according to RFC 3548 into a string of bytes stored in a+-- 'Data.ByteString.Lazy.ByteString'. If decoding fails, the invalid character and it's position in+-- the input string are returned as a pair in a 'Data.Either.Left' value, otherwise the+-- 'Data.ByteString.Lazy.ByteString' is returned as the 'Data.Either.Right' value.+b64Decode :: [Char] -> Either (Char, Word64) B.ByteString+b64Decode = loop 0 [] . breakInto 4 . filter (flip notElem " \t\r\n\v\f\0") where+  loop i bx cxx = case cxx of+    []     -> Right (B.pack bx)+    cx:cxx -> case sum 0 0 i cx of+      Left  (c, i)   -> Left (c, i)+      Right (i, bx') -> loop i (bx++bx') cxx+  sum tk b i cx = case cx of+    []   -> Right (i, take (3-tk) (splitup b))+    c:cx -> if inRange (bounds base64Values) c+              then  case base64Values!c of+                      0xAAAAAAA -> Left (c, i)+                      0xFFFFFFF -> sum (tk+1) (shiftL b 6)       (i+1) cx+                      c         -> sum  tk    (shiftL b 6 .|. c) (i+1) cx+              else Left (c, i)+  splitup b = map fromIntegral [shiftR (b.&.0xFF0000) 16, shiftR (b.&.0xFF00) 8, b.&.0xFF]++newtype Base64String = Base64String B.ByteString deriving Typeable+instance Show Base64String where { show (Base64String s) = unlines (b64Encode s) }+instance Read Base64String where+  readsPrec _ str =+    case partition (\c -> isSpace c || (inRange (bounds base64Values) c && base64Values!c /= 0xAAAAAAA)) str of+      ("" , _  ) -> []+      (str, rem) -> case b64Decode $ filter (not . isSpace) str of+        Left (ch, pos) -> error ("invalid charcter "++show ch++" at index "++show pos++" in base64-encoded string")+        Right u        -> [(Base64String u, rem)]+newtype Base16String = Base16String B.ByteString deriving Typeable+instance Show Base16String where+  show (Base16String u) = unlines $ fmap (unwords . fmap hex) $ breakInto 32 (B.unpack u) where+    hex b = [arr ! (shiftR (b.&.0xF0) 4), arr ! (b.&.0x0F)]+    arr :: Array Word8 Char+    arr = array (0,15) (zip [0..15] "0123456789ABCDEF")++showHex :: (Show i, Integral i) => i -> String+showHex = ("0x"++) . map toUpper . flip Numeric.showHex ""++showOrdinal :: (Show n, Integral n) => n -> String+showOrdinal n = show n ++ case mod n 100 of+  n | 11<=n||n<=13 -> "th"+  n -> case mod n 10 of { 1 -> "st"; 2 -> "nd"; 3 -> "rd"; _ -> "th"; }++----------------------------------------------------------------------------------------------------++-- | This is a simlpe string tokenizer for breaking up strings into tokens that can be easily used+-- in rules in Doa scripts.+simpleTokenizer :: String -> [String]+simpleTokenizer = fix $ \loop cx -> case cx of+  ""   -> []+  c:cx -> maybe ([c] : loop cx) (\ (cx, rem) -> cx : loop rem) $+    foldl (\f split -> mplus f (split (c:cx))) Nothing $ concat $+      [ fmap (\predicate (c:cx) -> guard (predicate c) >> Just (span predicate (c:cx))) $+          [isSpace, isNumber, isAlpha]+      , [\ (c:cx) -> guard (elem c "([{<>}])") >> Just ([c], cx)]+      , [\ (c:cx) -> Just $ span (==c) (c:cx)]+      ]+
+ src/Dao/Token.hs view
@@ -0,0 +1,400 @@+-- "src/Dao/Token.hs"  Defines the 'Token' and 'Location' types+-- used by "src/Dao/Interpreter.hs" and "src/Dao/Parser.hs".+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++{-# LANGUAGE DeriveDataTypeable #-}++module Dao.Token where++import           Dao.String+import           Dao.PPrint++import           Data.Monoid+import           Data.Word+import           Data.List (intercalate)+import           Data.Typeable+import           Data.Data++import           Control.Monad+import           Control.DeepSeq++----------------------------------------------------------------------------------------------------++type LineNum   = Word+type ColumnNum = Word+type TabWidth  = Word++-- | If an object contains a location, it can instantiate this class to allow locations to be+-- updated or deleted (deleted by converting it to 'LocationUnknown'. Only three types in this+-- module instantiate this class, but any data type that makes up an Abstract Syntax Tree, for+-- example 'Dao.Interpreter.ObjectExpr' or 'Dao.Interpreter.AST.ObjectExrpr' also instantiate this class.+class HasLocation a where+  getLocation :: a -> Location+  setLocation :: a -> Location -> a+  delLocation :: a -> a++instance HasLocation () where+  { getLocation _ = LocationUnknown; setLocation a _ = a; delLocation a = a; }++instance HasLocation UStr where+  { getLocation _ = LocationUnknown; setLocation a _ = a; delLocation a = a; }++instance HasLocation Name where+  { getLocation _ = LocationUnknown; setLocation a _ = a; delLocation a = a; }++instance HasLocation a => HasLocation (Maybe a) where+  getLocation       = maybe LocationUnknown getLocation+  setLocation o loc = fmap (flip setLocation loc) o+  delLocation o     = fmap       delLocation      o++-- | Contains two points, a starting and and ending point, where each point consists of a row (line+-- number) and column (character count from the beginning of a line) for locating entities in a+-- parsable text. This type does not contain information regarding the source of the text, or+-- whether or not the input text is a file or stream.+data Location+  = LocationUnknown+  | Location+    { startingLine   :: LineNum+      -- ^ the 'Location' but without the starting/ending character count+    , startingColumn :: ColumnNum+    , endingLine     :: LineNum+    , endingColumn   :: ColumnNum+    }+  deriving (Eq, Typeable, Data)++instance HasLocation Location where+  getLocation = id+  setLocation = flip const+  delLocation = const LocationUnknown++instance Show Location where+  show t = case t of+    LocationUnknown  -> ""+    Location a b _ _ -> show a ++ ':' : show b++instance Monoid Location where+  mempty = LocationUnknown+--  Location+--  { startingLine   = 0+--  , startingColumn = 0+--  , endingLine     = 0+--  , endingColumn   = 0+--  }+  mappend loc a = case loc of+    LocationUnknown -> a+    _ -> case a of+      LocationUnknown -> loc+      _ ->+        loc+        { startingLine   = min (startingLine   loc) (startingLine   a)+        , startingColumn = min (startingColumn loc) (startingColumn a)+        , endingLine     = max (endingLine     loc) (endingLine     a)+        , endingColumn   = max (endingColumn   loc) (endingColumn   a)+        }+instance Ord Location where+  compare a b = case (a,b) of+    (LocationUnknown, LocationUnknown) -> EQ+    (_              , LocationUnknown) -> LT+    (LocationUnknown, _              ) -> GT+    _ -> compare (abs(ela-sla), abs(eca-sca), sla, sca) (abs(elb-slb), abs(ecb-scb), slb, scb)+    where+      sla = startingLine   a+      ela = endingLine     a+      slb = startingLine   b+      elb = endingLine     b+      sca = startingColumn a+      eca = endingColumn   a+      scb = startingColumn b+      ecb = endingColumn   b+  -- ^ Greater-than is determined by a heuristic value of how large and uncertain the position of+  -- the error is. If the exact location is known, it has the lowest uncertainty and is therefore+  -- less than a location that might occur across two lines. The 'LocationUnknown' value is the most+  -- uncertain and is greater than everything except itself. Using this comparison function, you can+  -- sort lists of locations from least to greatest and hopefully get the most helpful, most+  -- specific location at the top of the list.++instance HasNullValue Location where+  nullValue = LocationUnknown+  testNull LocationUnknown = True+  testNull _ = False++instance PPrintable Location where+  pPrint o = case o of+    LocationUnknown  -> pString "srcLoc()"+    Location a b c d -> pList (pString "srcLoc") "(" ", " ")" [pShow a, pShow b, pShow c, pShow d]++instance NFData Location where+  rnf LocationUnknown = ()+  rnf (Location a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()++-- | Create a location where the starting and ending point is the same row and column.+atPoint :: LineNum -> ColumnNum -> Location+atPoint a b =+  Location+  { startingLine   = a+  , endingLine     = a+  , startingColumn = b+  , endingColumn   = b+  }++-- | The the coordinates from a 'Location':+-- @(('startingLine', 'startingColumn'), ('endingLine', 'endingColumn'))@+locationCoords :: Location -> Maybe ((LineNum, ColumnNum), (LineNum, ColumnNum))+locationCoords loc = case loc of+  LocationUnknown -> Nothing+  _ -> Just ((startingLine loc, startingColumn loc), (endingLine loc, endingColumn loc))++----------------------------------------------------------------------------------------------------+-- $All_about_tokens+-- This module was designed to create parsers which operate in two phases: a lexical analysis phase+-- (see 'lexicalAnalysis') where input text is split up into tokens, and a syntactic analysis phase+-- where a stream of tokens is converted into data. 'Token' is the data type that makes this+-- possible.++class HasLineNumber   a where { lineNumber   :: a -> LineNum }+class HasColumnNumber a where { columnNumber :: a -> ColumnNum }+class HasToken        a where { getToken     :: a tok -> Token tok }++-- | Every token emitted by a lexical analyzer must have at least a type. 'Token' is polymorphic+-- over the type of token.+data Token tok+  = EmptyToken { tokType :: tok }+    -- ^ Often times, tokens may not need to contain any text. This is often true of opreator+    -- symbols and keywords. This constructor constructs a token with just a type and no text. The+    -- more descriptive your token types are, the less you need you will have for storing the text+    -- along with the token type, and the more memory you will save.+  | CharToken  { tokType :: tok, tokChar :: !Char }+    -- ^ Constructs tokens along with the text. If the text is only a single character, this+    -- constructor is used, which can save a little memory as compared to storing a+    -- 'Dao.String.UStr'.+  | Token      { tokType :: tok, tokUStr :: UStr }+    -- ^ Constructs tokens that contain a copy of the text extracted by the lexical analyzer to+    -- create the token.+  deriving (Eq, Typeable)++instance Show tok => Show (Token tok) where+  show tok =+    let cont = tokToStr tok+    in  show (tokType tok) ++ (if null cont then "" else ' ':show cont)++instance Functor Token where+  fmap f t = case t of+    EmptyToken t   -> EmptyToken (f t)+    CharToken  t c -> CharToken  (f t) c+    Token      t u -> Token      (f t) u++-- | If the lexical analyzer emitted a token with a copy of the text used to create it, this+-- function can retrieve that text. Returns 'Dao.String.nil' if there is no text.+tokToUStr :: Token tok -> UStr+tokToUStr tok = case tok of+  EmptyToken _   -> nil+  CharToken  _ c -> ustr [c]+  Token      _ u -> u++-- | Like 'tokToUStr' but returns a 'Prelude.String' or @""@ instead.+tokToStr :: Token tok -> String+tokToStr tok = case tok of+  EmptyToken _   -> ""+  CharToken  _ c -> [c]+  Token      _ u -> uchars u++-- | This data type stores the starting point (the line number and column number) in the+-- source file of where the token was emitted along with the 'Token' itself.+data TokenAt tok+  = TokenAt+    { tokenAtLineNumber   :: LineNum+    , tokenAtColumnNumber :: ColumnNum+    , getTokenValue       :: Token tok+    }++instance Show tok =>+  Show (TokenAt tok) where+    show tok = let (a,b,c) = asTriple tok in show a++':':show b++' ':show c++instance HasLineNumber   (TokenAt tok) where { lineNumber   = tokenAtLineNumber }++instance HasColumnNumber (TokenAt tok) where { columnNumber = tokenAtColumnNumber }++instance HasToken TokenAt where { getToken = getTokenValue }++instance Functor  TokenAt where+  fmap f t =+    TokenAt+    { tokenAtLineNumber   = tokenAtLineNumber t+    , tokenAtColumnNumber = tokenAtColumnNumber t+    , getTokenValue       = fmap f (getToken t)+    }++-- | Extract the type of the token.+asTokType :: TokenAt tok -> tok+asTokType = tokType . getToken++-- | Extract the string value stored in this token. /WARNING:/ keyword and operator tokens contain+-- no strings to save memory, so evaluating this function on any token type defind by+-- 'Dao.Parser.operator', 'Dao.Parser.operatorTable', or 'Dao.Parser.keyword' will result in a null+-- sring.+asString :: TokenAt tok -> String+asString = tokToStr . getToken++-- | Extract the string value stored in this token. /WARNING:/ keyword and operator tokens contain+-- no strings to save memory, so evaluating this function on any token type defind by+-- 'Dao.Parser.operator', 'Dao.Parser.operatorTable', or 'Dao.Parser.keyword' will result in a null+-- sring.+asUStr :: TokenAt tok -> UStr+asUStr = tokToUStr . getToken++-- | Extract the string value stored in this token. /WARNING:/ keyword and operator tokens contain+-- no strings to save memory, so evaluating this function on any token type defind by+-- 'Dao.Parser.operator', 'Dao.Parser.operatorTable', or 'Dao.Parser.keyword' will result in a null+-- sring.+asName :: TokenAt tok -> Name+asName = fromUStr . asUStr++-- | That is as-zero, because "0" looks kind of like "()".+-- This function is useful when it is necessary to pass a function argument to functions like+-- 'Dao.Parser.token' and 'Dao.Parser.tokenBy' but you want to ignore the token returned.+as0 :: TokenAt tok -> ()+as0 = const ()++-- | Retrieve the token part of a 'TokenAt' object. +asToken :: TokenAt tok -> Token tok+asToken = getToken++-- | Synonym for 'Prelude.id', used when it is necessary to pass a function argument to functions like+-- 'Dao.Parser.token' and 'Dao.Parser.tokenBy' but you just want the whole 'TokenAt' object.+asTokenAt :: TokenAt tok -> TokenAt tok+asTokenAt = id++-- | Convert the contents of a 'TokenAt' object to a tripple containg it's component parts.+asTriple :: TokenAt tok -> (LineNum, ColumnNum, Token tok)+asTriple tok = (lineNumber tok, columnNumber tok, getToken tok)++-- | Convert the contents of a 'TokenAt' object to a pair containg it's component parts, but not the+-- 'Token' itself.+asLineColumn :: TokenAt tok -> (LineNum, ColumnNum)+asLineColumn tok = (lineNumber tok, columnNumber tok)++-- | Convert the contents of the 'TokenAt' object's 'lineNumber' and 'columnNumber' to a 'Location'+-- object.+asLocation :: TokenAt tok  -> Location+asLocation = uncurry atPoint . asLineColumn++-- | The lexical analysis phase emits a stream of 'TokenAt' objects, but it is not memory+-- efficient to store the line and column number with every single token. To save space, the token+-- stream is "compressed" into 'Lines', where 'TokenAt' that has the same 'lineNumber' is+-- placed into the same 'Line' object. The 'Line' stores the 'lineNumber', and the+-- 'lineNumber's are deleted from every 'TokenAt', leaving only the 'columnNumber' and 'Token'+-- in each line.+data Line tok+  = Line+    { lineLineNumber :: LineNum+    , lineTokens     :: [(ColumnNum, Token tok)]+      -- ^ a list of tokens, each with an associated column number.+    }++instance HasLineNumber (Line tok) where { lineNumber = lineLineNumber }++instance Show tok => Show (Line tok) where+  show line = concat $+    [ "Line ", show (lineLineNumber line), ":\n"+    , intercalate ", " $+        map (\ (col, tok) -> show col++" "++show tok) (lineTokens line)+    ]++instance Functor Line where+  fmap f t =+    Line+    { lineLineNumber = lineLineNumber t+    , lineTokens     = fmap (fmap (fmap f)) (lineTokens t)+    }++lineToTokensAt :: Line tok -> [TokenAt tok]+lineToTokensAt line = map f (lineTokens line) where+  lineNum         = lineNumber line+  f (colNum, tok) =+    TokenAt+    { tokenAtLineNumber   = lineNum+    , tokenAtColumnNumber = colNum+    , getTokenValue       = tok+    }++----------------------------------------------------------------------------------------------------+-- $Error_handling+-- The lexical analyzer and syntactic analysis monads all instantiate+-- 'Control.Monad.ParseError.Class.MonadError' in the Monad Transformer Library ("mtl" package). This is+-- the type used for 'Control.Monad.ParseError.Class.throwError' and+-- 'Control.Monad.ParseError.Class.catchError'.++-- | This data structure is used by both the lexical analysis and the syntactic analysis phase.+data ParseError st tok+  = ParseError+    { parseErrLoc     :: Location+    , parseErrMsg     :: Maybe UStr+    , parseErrTok     :: Maybe (Token tok)+    , parseStateAtErr :: Maybe st+    }+  deriving (Eq, Typeable)++instance (PPrintable st, Show tok) => Show (ParseError st tok) where { show err = prettyShow err }++instance Functor (ParseError st) where+  fmap f e =+    ParseError+    { parseErrLoc     = parseErrLoc e+    , parseErrMsg     = parseErrMsg e+    , parseErrTok     = fmap (fmap f) (parseErrTok e)+    , parseStateAtErr = parseStateAtErr e+    }++instance (PPrintable st, Show tok) => PPrintable (ParseError st tok) where+  pPrint err = do+    pString (show (parseErrLoc err)++": ")+    sp <-+      maybe+        (return False)+        (\tok -> pString ("(on token: "++show tok++")") >> return True)+        (parseErrTok err)+    maybe+      (return False)+      (\msg -> when sp (pString " ") >> pUStr msg >> return True)+      (parseErrMsg err)+    maybe (return ()) (\st -> pEndLine >> pIndent (pPrint st)) (parseStateAtErr err)++fmapParseErrorState :: (stA -> stB) -> ParseError stA tok -> ParseError stB tok+fmapParseErrorState f err@(ParseError{ parseStateAtErr=st }) = err{parseStateAtErr=fmap f st}++-- | An initial blank parser error you can use to construct more detailed error messages.+parserErr :: Location -> ParseError st tok+parserErr loc =+  ParseError+  { parseErrLoc = loc+  , parseErrMsg = Nothing+  , parseErrTok = Nothing+  , parseStateAtErr = Nothing+  }++newParseError :: ParseError st tok+newParseError =+  ParseError+  { parseErrLoc     = LocationUnknown+  , parseErrMsg     = Nothing+  , parseErrTok     = Nothing+  , parseStateAtErr = Nothing+  }+
+ src/Dao/Tree.hs view
@@ -0,0 +1,437 @@+-- "src/Dao/Tree.hs"  provides a fundamental data type used in the Dao+-- System, the "Tree", which is similar to the "Data.Map" data type.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.+++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Dao.Tree where++import           Dao.String (HasNullValue, nullValue, testNull) -- TODO: move the HasNullValue class to it's own module.++import           Control.Applicative+import           Control.DeepSeq+import           Control.Monad+import           Control.Monad.Identity+import           Control.Monad.Trans+import           Control.Monad.State++import           Data.Typeable+import           Data.Monoid+import           Data.List (intercalate)+-- import           Data.Binary+import qualified Data.Map as M+import           Data.Word++----------------------------------------------------------------------------------------------------++data Tree p n+  = Void+  | Leaf   { branchData :: n }+  | Branch { branchMap  :: M.Map p (Tree p n) }+  | LeafBranch +    { branchData :: n+    , branchMap  :: M.Map p (Tree p n)+    }+  deriving Typeable+instance (Show p, Show n) => Show (Tree p n) where+  show o = case o of+    Void           -> "voidTree"+    Leaf       o   -> "(leaf "++show o++")"+    Branch       t -> "(branch ["++branch t++"])"+    LeafBranch o t -> "(leaf "++show o++" branch ["++branch t++"])"+    where { branch t = intercalate ", " (M.assocs t  >>= \ (nm, o) -> [show nm++"="++show o]) }+instance (Eq p, Eq n) => Eq (Tree p n) where+  (==) a b = case (a, b) of+    (Void           , Void           ) -> True+    (Leaf       a   , Leaf       b   ) -> a == b+    (Branch     a   , Branch     b   ) -> a == b+    (LeafBranch a aa, LeafBranch b bb) -> a == b && aa == bb+    _                                  -> False+instance (Ord p, Ord n) => Ord (Tree p n) where+  compare a b = case (a, b) of+    (Void           , Void           ) -> EQ+    (Leaf       a   , Leaf       b   ) -> compare a  b+    (Branch       aa, Branch       bb) -> compare aa bb+    (LeafBranch a aa, LeafBranch b bb) -> case compare a b of+      EQ -> compare aa bb+      e  -> e+    (Void           , _              ) -> LT+    (_              , Void           ) -> GT+    (Leaf       _   , _              ) -> LT+    (_              , Leaf       _   ) -> GT+    (Branch       _ , _              ) -> LT+    (_              , Branch       _ ) -> GT+instance Ord p => Functor (Tree p) where+  fmap f tree = case tree of+    Void           -> Void+    Leaf       a   -> Leaf (f a)+    Branch       m -> Branch (fmap (fmap f) m)+    LeafBranch a m -> LeafBranch (f a) (fmap (fmap f) m)+instance (Ord p, Monoid n) => Monoid (Tree p n) where+  mempty  = Void+  mappend = unionWith mappend+instance (NFData a, NFData b) => NFData (Tree a b) where+  rnf  Void            = ()+  rnf (Leaf       a  ) = deepseq a ()+  rnf (Branch       b) = deepseq b ()+  rnf (LeafBranch a b) = deepseq a $! deepseq b ()+instance HasNullValue (Tree a b) where { nullValue = Void; testNull = Dao.Tree.null; }++-- | A combinator to modify the data in the 'Leaf' and 'LeafBranch' nodes of a tree when passed to+-- one of the functions below.+type ModLeaf     n = Maybe n -> Maybe n++-- | A combinator to modify the data in the 'Branch' and 'LeafBranch' nodes of a tree when passed to+-- one of the functions below.+type ModBranch p n = Maybe (M.Map p (Tree p n)) -> Maybe (M.Map p (Tree p n))++-- | If a 'Tree' is 'Void' or a contains a branch that is equivalent to 'Data.Map.empty',+-- 'Data.Maybe.Nothing' is returned.+notVoid :: Tree p n -> Maybe (Tree p n)+notVoid t = case t of+  Void                      -> Nothing+  Branch       b | M.null b -> Nothing+  LeafBranch a b | M.null b -> Just (Leaf a)+  _                         -> Just t++-- | If the given node is a 'Leaf' or 'LeafBranch', returns the Leaf portion of the node.+getLeaf :: Tree p n -> Maybe n+getLeaf t = case t of { Leaf n -> Just n; LeafBranch n _ -> Just n; _ -> Nothing }++-- | If the given node is a 'Branch' or 'LeafBranch', returns the branch portion of the node.+getBranch :: Tree p a -> Maybe (M.Map p (Tree p a))+getBranch t = case t of { Branch b -> Just b; LeafBranch _ b -> Just b; _ -> Nothing }++-- | Use a 'ModLeaf' function to insert, update, or remove 'Leaf' and 'LeafBranch' nodes.+alterLeaf :: ModLeaf n -> Tree p n -> Tree p n+alterLeaf alt t = maybe Void id $ case t of+  Void           -> alt Nothing         >>= \o -> Just (Leaf o)+  Leaf       o   -> alt (Just o)        >>= \o -> Just (Leaf o)+  Branch       b -> mplus (alt Nothing  >>= \o -> Just (LeafBranch o b)) (Just (Branch b))+  LeafBranch o b -> mplus (alt (Just o) >>= \o -> Just (LeafBranch o b)) (Just (Branch b))++alterBranch :: (Eq p, Ord p) => ModBranch p n -> Tree p n -> Tree p n+alterBranch alt t = maybe Void id $ case t of+  Void           -> alt Nothing         >>= \b -> Just (Branch b)+  Leaf       o   -> mplus (alt Nothing  >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))+  Branch       b -> alt (Just b)        >>= \b -> Just (Branch b)+  LeafBranch o b -> mplus (alt (Just b) >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))++----------------------------------------------------------------------------------------------------++data ZipTree p n = ZipTree{ focus :: Tree p n, history :: [(p, Tree p n)] }++newtype UpdateTreeT p n m a = UpdateTreeT{ getUpdateTreeStateT :: StateT (ZipTree p n) m a }+type UpdateTree p n a = UpdateTreeT p n Identity a++instance Monad m =>+  Monad (UpdateTreeT p n m) where+    return = UpdateTreeT . return+    (UpdateTreeT a) >>= b = UpdateTreeT (a >>= getUpdateTreeStateT . b)+instance Functor m =>+  Functor (UpdateTreeT p n m) where { fmap f (UpdateTreeT m) = UpdateTreeT (fmap f m); }+instance (Monad m, Functor m) =>+  Applicative (UpdateTreeT p n m) where { pure = return; (<*>) = ap; }+instance Monad m =>+  MonadState (ZipTree p n) (UpdateTreeT p n m) where { state = UpdateTreeT . state; }+instance MonadTrans (UpdateTreeT p n) where { lift m = UpdateTreeT (lift m); }++-- | Like 'Control.Monad.State.runState', evaluates an 'UpdateTree' monad transformer lifting the+-- 'Control.Monad.Identity.Identity' monad, removing the identity monad after evaluation to give you+-- a pure function.+runUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> (a, Tree p n)+runUpdateTree updfn = runIdentity . runUpdateTreeT updfn++-- | Like 'Control.Monad.State.execState', disgards the value returned to the 'UpdateTree' monad and+-- only returns the 'Tree'.+execUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> Tree p n+execUpdateTree updfn = snd . runUpdateTree updfn++-- | Update a 'Tree' using an 'UpdateTreeT' monad, much like how 'Control.Monad.State.runStateT'+-- works. Evaluates to a monadic computation of the lifted type @m@ that 'Control.Monad.return's a+-- pair containing the value last 'Control.Monad.return'ed to the lifted monad and the updated+-- 'Tree'.+runUpdateTreeT :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m a -> Tree p n -> m (a, Tree p n)+runUpdateTreeT updfn tree = fmap (fmap focus) $+  runStateT (getUpdateTreeStateT (updfn >>= \a -> home >> return a)) (ZipTree{focus=tree, history=[]})++-- | Go to the node with the given path. If the path does not exist, it is created.+goto :: (Ord p, Monad m) => [p] -> UpdateTreeT p n m (Tree p n)+goto path = case path of+  []       -> gets focus+  (p:path) -> do+    st <- get+    let step tree = put $ st{focus=tree, history=(p, focus st):history st}+    case getBranch (focus st) >>= M.lookup p of+      Nothing   -> step Void+      Just tree -> step tree+    goto path++-- | Go up one level in the tree, storing the current sub-tree into the upper tree, unless the+-- current tree is 'Void', in which case it is deleted from the upper tree.+back :: (Ord p, Monad m) => UpdateTreeT p n m ()+back = modify $ \st -> case history st of+  []             -> st+  (p, tree):hist ->+    st{ history = hist+      , focus   = flip alterBranch tree $ \branch -> flip mplus (fmap (M.delete p) branch) $ do+          subTree <- notVoid (focus st)+          fmap (M.insert p subTree) (mplus branch (return mempty))+      }++-- | Returns 'Prelude.True' if we are at the top level of the tree.+atTop :: (Functor m, Monad m) => UpdateTreeT p n m Bool+atTop = fmap Prelude.null (gets history)++-- | Go back to the top level of the tree.+home :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m ()+home = atTop >>= flip unless (back >> home)++-- | Return the current path.+getPath :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m [p]+getPath = fmap (reverse . fmap fst) (gets history)++-- | Modify the tree node at the current 'focus'. After the update, if there is a leaf attached at+-- the focus, the value of the leaf is returned.+modifyNode :: (Ord p, Functor m, Monad m) => (Tree p n -> Tree p n) -> UpdateTreeT p n m (Maybe n)+modifyNode mod = modify (\st -> st{focus=mod(focus st)}) >> fmap getLeaf (gets focus)++-- | Modify the tree node using a 'ModBranch' function which allows you to alter the 'Data.Map.Map'+-- object containing the branches of the current node.+modifyBranch :: (Ord p, Functor m, Monad m) => ModBranch p n -> UpdateTreeT p n m ()+modifyBranch mod = modifyNode (alterBranch mod) >> return ()++-- | Modify the tree node using a 'ModLeaf' function which allows you to alter the 'Data.Map.Map'+-- object containing the current of the current node.+modifyLeaf :: (Ord p, Functor m, Monad m) => ModLeaf n -> UpdateTreeT p n m (Maybe n)+modifyLeaf mod = modifyNode (alterLeaf mod)++----------------------------------------------------------------------------------------------------+-- $MapLikeFunctions+-- In this section I have made my best effor to create API functions as similar as possible to that+-- of the "Data.Map" module.+----------------------------------------------------------------------------------------------------++alter :: Ord p => (Tree p a -> Tree p a) -> [p] -> Tree p a -> Tree p a+alter mod path = execUpdateTree (goto path >> modifyNode mod)+--alterNode alt px t = runIdentity $ alterNodeM (return . alt) px t++-- | Insert a 'Leaf' at a given address.+insert :: Ord p => [p] -> n -> Tree p n -> Tree p n+insert path n = execUpdateTree (goto path >> modifyLeaf (const (Just n)))+--insert px a = alter (const (Just a)) (flip mplus (Just Void)) px++-- | Update a 'Leaf' at a given address.+update :: Ord p => [p] -> ModLeaf a -> Tree p a -> Tree p a+update path mod = execUpdateTree (goto path >> modifyLeaf mod)+--update path mod = alter mod (flip mplus (Just Void)) path++-- | Delete a 'Leaf' or 'Branch' at a given address.+delete :: Ord p => [p] -> Tree p a -> Tree p a+delete path = execUpdateTree (goto path >> modifyLeaf (const Nothing))+--delete px = alter (const Nothing) id px++-- | Create a 'Tree' from a list of associationes, the 'Prelude.fst' element containing the branch,+-- the 'Prelude.snd' element containing the leaf value. This is the inverse operation of 'assocs'.+fromList :: Ord p => [([p], a)] -> Tree p a+fromList = foldl (\ tree (px, a) -> insert px a tree) Void++-- | Lookup a 'Tree' value (the whole node, not just the data stored in the node) at given address.+-- NOTE: this may not be what you want. If you want return the data that is stored in a 'Leaf' or+-- 'LeafBranch', use 'lookup', or just do @'lookup' atBranch inTree >>= 'getLeaf'@.+lookupNode :: Ord p => [p] -> Tree p a -> Maybe (Tree p a)+lookupNode px t = case px of+  []   -> Just t+  p:px -> case t of+    Branch       t -> next p t+    LeafBranch _ t -> next p t+    _              -> Nothing+    where { next p t = M.lookup p t >>= Dao.Tree.lookupNode px }++-- | This function analogous to the 'Data.Map.lookup' function, which returns a value stored in a+-- leaf, or nothing if there is no leaf at the given path.+lookup :: Ord p => [p] -> Tree p a -> Maybe a+lookup px t = lookupNode px t >>= getLeaf++-- | Using @[p]@ as a path, traverse the path through the given 'Tree' as far as possible, return+-- the last node that could be reached along with the remainder of the path that was not traversed.+-- This is used to lookup whether or not a leaf has been stored into the tree at the given path, or+-- at some sub-path of the given path.+partialLookup :: Ord p => [p] -> Tree p a -> Maybe ([p], Tree p a)+partialLookup px t = case px of+  []   -> Just ([], t)+  p:px -> mplus (getBranch t >>= M.lookup p >>= partialLookup px) $+    (getLeaf t >>= \ _ -> return (p:px, t))++-- | Using @[p]@ as a path, traverse a tree and retrieve every leaf found along the path until+-- traversal cannot continue. Evaluates to the list of leaves retrieved, the portion of the path+-- that could not be traversed, and the node at which traversal stopped.+leavesAlongPath :: Ord p => [p] -> Tree p a -> ([a], ([p], Tree p a))+leavesAlongPath px t = maybe ([], (px, t)) id $ loop [] px t where+  loop ax px t = return (ax ++ maybe [] (:[]) (getLeaf t)) >>= \ax -> case px of+    []   -> return (ax, ([], t))+    p:px -> mplus (getBranch t >>= M.lookup p >>= loop ax px) (return (ax, (p:px, t)))++-- | There are only two kinds values defined as a 'MergeType': 'union' and 'intersection.+type MergeType p a+  = (Tree p a -> Tree p a -> Tree p a)+  -> M.Map p (Tree p a)+  -> M.Map p (Tree p a)+  -> M.Map p (Tree p a)++-- | Merge two trees together.+mergeWithKey :: Ord p+  => ([p] -> Maybe a -> Maybe b -> Maybe c)+  -> (Tree p a -> Tree p c)+  -> (Tree p b -> Tree p c)+  -> Tree p a -> Tree p b -> Tree p c+mergeWithKey overlap leftOnly rightOnly left right = loop [] left right where+  -- loop :: Ord p => [p] -> Tree p a -> Tree p b -> Tree p c+  loop px left right = case left of+    Void           -> case right of+      Void           -> Void+      Leaf       y   -> rightOnly (Leaf       y  )+      Branch       b -> rightOnly (Branch       b)+      LeafBranch y b -> rightOnly (LeafBranch y b)+    Leaf       x   -> case right of+      Void           -> leftOnly  (Leaf       x  )+      Leaf       y   -> maybe Void id (fmap Leaf (overlap px (Just x) (Just y)))+      Branch       b -> leafbranch (Just x) Nothing  M.empty b+      LeafBranch y b -> leafbranch (Just x) (Just y) M.empty b+    Branch       a -> case right of+      Void           -> leftOnly  (Branch       a)+      Leaf       y   -> leafbranch Nothing (Just y) a M.empty+      Branch       b -> leafbranch Nothing Nothing  a b      +      LeafBranch y b -> leafbranch Nothing (Just y) a b      +    LeafBranch x a -> case right of+      Void           -> leftOnly  (LeafBranch x a)+      Leaf       y   -> leafbranch (Just x) (Just y) a M.empty+      Branch       b -> leafbranch (Just x) Nothing  a b      +      LeafBranch y b -> leafbranch (Just x) (Just y) a b      +    where+      -- leafbranch :: Ord p => M.Map p (Tree p a) -> M.Map p (Tree p b) -> Maybe a -> Maybe b -> Tree p c+      leafbranch x y left right = +        let c = M.mergeWithKey both (bias leftOnly) (bias rightOnly) left right -- :: M.Map p (Tree p c)+        in  case overlap px x y of+              Nothing -> notEmpty Branch c+              Just  z -> notEmpty (LeafBranch z) c+      -- notEmpty :: Ord p => (M.Map p (Tree p a) -> Tree p a) -> M.Map p (Tree p a) -> Tree p a+      notEmpty cons c = if M.null c then Void else cons c+      -- both :: Ord p => p -> Tree p a -> Tree p b -> Maybe (Tree p c)+      both p left right = notVoid (loop (px++[p]) left right)+      -- bias :: Ord p => (Tree p a -> Tree p b) -> M.Map p (Tree p a) -> M.Map p (Tree p b)+      bias fn = M.mapMaybe (notVoid . fn)++mergeWith :: Ord p => (Maybe a -> Maybe b -> Maybe c) -> (Tree p a -> Tree p c) -> (Tree p b -> Tree p c) -> Tree p a -> Tree p b -> Tree p c+mergeWith overlap = mergeWithKey (\ _ -> overlap)++unionWithKey :: Ord p => ([p] -> a -> a -> a) -> Tree p a -> Tree p a -> Tree p a+unionWithKey overlap = mergeWithKey (\k a b -> msum [liftM2 (overlap k) a b, a, b]) id id++unionWith :: Ord p => (a -> a -> a) -> Tree p a -> Tree p a -> Tree p a+unionWith overlap = unionWithKey (\ _ -> overlap)++union :: Ord p => Tree p a -> Tree p a -> Tree p a+union = unionWith const++unionsWith :: Ord p => (a -> a -> a) -> [Tree p a] -> Tree p a+unionsWith overlap = foldl (unionWith overlap) Void++unions :: Ord p => [Tree p a] -> Tree p a+unions = unionsWith (flip const)++intersectionWithKey :: Ord p => ([p] -> a -> a -> a) -> Tree p a -> Tree p a -> Tree p a+intersectionWithKey overlap = mergeWithKey (\k -> liftM2 (overlap k)) (const Void) (const Void)++intersectionWith :: Ord p => (a -> a -> a) -> Tree p a -> Tree p a -> Tree p a+intersectionWith overlap = intersectionWithKey (\ _ -> overlap)++intersection :: Ord p => Tree p a -> Tree p a -> Tree p a+intersection = intersectionWith const++intersectionsWith :: Ord p => (a -> a -> a) -> [Tree p a] -> Tree p a+intersectionsWith overlap = foldl (intersectionWith overlap) Void++intersections :: Ord p => [Tree p a] -> Tree p a+intersections = intersectionsWith (flip const)++differenceWithKey :: Ord p => ([p] -> a -> b -> Maybe a) -> Tree p a -> Tree p b -> Tree p a+differenceWithKey overlap = mergeWithKey (\k a b -> mplus (b >>= \b -> a >>= \a -> overlap k a b) a) id (const Void)++differenceWith :: Ord p => (a -> b -> Maybe a) -> Tree p a -> Tree p b -> Tree p a+differenceWith overlap = differenceWithKey (\ _ -> overlap)++difference :: Ord p => Tree p a -> Tree p b -> Tree p a+difference = differenceWith (\ _ _ -> Nothing)++-- | Get all items and their associated path.+assocs :: Tree p a -> [([p], a)]+assocs t = loop [] t where+  recurs px b = M.assocs b >>= \ (p, t) -> loop (px++[p]) t+  loop px t = case t of+    Void           -> []+    Leaf       a   -> [(px, a)]+    Branch       b -> recurs px b+    LeafBranch a b -> (px, a) : recurs px b++-- | Apply @'Prelude.map' 'Prelude.snd'@ to the result of 'assocs', behaves just like how+-- 'Data.Map.elems' or 'Data.Array.IArray.elems' works.+elems :: Tree p a -> [a]+elems t = fmap snd (assocs t)++-- | Counts the number of *nodes*, which includes the number of 'Branch'es and 'Leaf's.+size :: Tree p a -> Word64+size t = case t of+  Void           -> 0+  Leaf       _   -> 1+  Branch       m -> 0 + f m+  LeafBranch _ m -> 1 + f m+  where { f m = foldl (\sz tre -> sz + size tre) (fromIntegral (M.size m)) (M.elems m) }++branchCount :: Tree p a -> Int+branchCount = maybe 0 M.size . getBranch++null :: Tree p a -> Bool+null Void = True+null _    = False++----------------------------------------------------------------------------------------------------++data TreeDiff a b+  = LeftOnly  a -- something exists in the "left" branch but not in the "right" branch.+  | RightOnly b -- something exists in the "right" branch but not in the "left" branch.+  | TreeDiff  a b -- something exists in the "left" and "right" branches but they are not equal+  deriving (Eq, Typeable)++-- | Produce a difference report of two trees with the given comparison predicate. If the predicate+-- returns 'Prelude.True', the node is ignored, otherwise the differences is reported.+treeDiffWith :: Ord p => (a -> b -> Bool) -> Tree p a -> Tree p b -> Tree p (TreeDiff a b)+treeDiffWith compare = mergeWithKey leaf (fmap LeftOnly) (fmap RightOnly) where+  leaf _ a b = msum $+    [ a >>= \a -> b >>= \b -> if compare a b then Nothing else Just (TreeDiff a b)+    , fmap LeftOnly a, fmap RightOnly b+    ]++-- | Call 'treeDiffWith' using 'Prelude.(==)' as the comparison predicate.+treeDiff :: (Eq a, Ord p) => Tree p a -> Tree p a -> Tree p (TreeDiff a a)+treeDiff = treeDiffWith (==)+
+ src/dao-main.hs view
@@ -0,0 +1,122 @@+-- "src/dao-main.hs"  the Main module for the "dao" executable program.+-- Provides an interactive command line interface to the Dao System.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not,+-- please see <http://www.gnu.org/licenses/agpl.html>.+++-- {-# LANGUAGE TemplateHaskell #-}++module Main where++import           Dao+import           Dao.Predicate+import           Dao.PPrint++import           Data.Char++import           Control.Monad+import           Control.Monad.IO.Class++import           System.Environment+import           System.IO+--import           System.Console.Readline++----------------------------------------------------------------------------------------------------++version :: String+version = "0.0 (experimental)"++disclaimer :: String+disclaimer = unlines $+  [ "\"Dao\" version "++version+  , "Copyright (C) 2008-2014  Ramin Honary."+  , "This program comes with ABSOLUTELY NO WARRANTY."+  , "This is free software, and you are welcome to redistribute it under"+  , "the terms and conditions of the GNU Affero General Public License."+  , "Enter the command \":license\" for details."+  , "-----------------------------------------------"+  ]++inputLoop :: Exec (Maybe UStr)+inputLoop = do+  liftIO $ putStr "dao> " >> hFlush stdout+  closed <- liftIO $ hIsClosed stdin+  eof    <- liftIO isEOF+  if closed || eof+    then return Nothing+    else do+      -- hSetEcho stdin True+      str <- liftIO getLine+      ---------------------------------------------------+      --readline "dao> " >>= \str -> case str of+      --  Nothing  -> return Nothing+      --  Just str -> addHistory str >> return (Just str)+      case words (uchars str) of+        o | o==[":quit"   ] || o==[":", "quit"   ] -> return Nothing+        o | o==[":license"] || o==[":", "license"] -> liftIO (putStrLn license_text) >> inputLoop+        ((':':_) : _) -> do+          evalScriptString (dropWhile (\c -> isSpace c || c==':') str)+          inputLoop+        (a:cmds) | head a==':' -> do+          liftIO $ hPutStr stderr $ unwords $+            ["Error: unknown meta-command"] ++ if null cmds then [] else [show $ head cmds]+          inputLoop+        _ -> return $ Just $ toUStr str++main :: IO ()+main = do+  hSetBuffering stderr LineBuffering+  hSetBuffering stdout LineBuffering+  argv <- getArgs+  when (elem "--version" argv) (putStr disclaimer)+  argv <- return $ fmap ustr $ filter (/="--version") argv+  --initialize -- initialize the ReadLine library+  result <- setupDao $ do+    loadDaoStandardLibrary+    daoInitialize $ do+      loadEveryModule argv+      daoInputLoop inputLoop+      daoShutdown+  case result of+    OK    ()                -> return ()+    PFail (ExecReturn    o) -> maybe (return ()) (putStrLn . prettyShow) o+    PFail (err@ExecError{}) -> hPutStrLn stderr (prettyShow err)+    Backtrack               -> hPutStrLn stderr "(does not compute)"+  --restorePrompt -- shut-down the ReadLine library+  hPutStrLn stderr "Dao has exited."++license_text :: String+license_text = unlines $+  [ "Dao version: "++version+  , "Copyright (C) 2008-2014  Ramin Honary"+  , ""+  , "This program is free software: you can redistribute it and/or modify"+  , "it under the terms and conditions of the GNU General Public License as"+  , "published by the Free Software Foundation, either version 3 of the"+  , "license, or (at your option) any later version."+  , ""+  , "This program is distributed in the hope that it will be useful"+  , "WITHOUT ANY WARRANTY; without even the implied warranty of"+  , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the"+  , "GNU General Public License for more details."+  , ""+  , "You should have received a copy of the GNU General Public License"+  , "along with this program (see the file called \"LICENSE\"). If not,"+  , "please see <http://www.gnu.org/licenses/agpl.html>."+  ]+
+ tests/main.hs view
@@ -0,0 +1,26 @@+-- "tests/main.hs"  calls the main function of the Dao.Test module.+-- +-- Copyright (C) 2008-2014  Ramin Honary.+-- This file is part of the Dao System.+--+-- The Dao System 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.+-- +-- The Dao System is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program (see the file called "LICENSE"). If not, see+-- <http://www.gnu.org/licenses/agpl.html>.++module Main where+import qualified Dao.Test+import qualified Dao.CoreTests++main :: IO ()+main = Dao.Test.main Dao.CoreTests.unitTester+