packages feed

tamarin-prover-theory (empty) → 0.8.2.0

raw patch · 33 files changed

+11449/−0 lines, 33 filesdep +HUnitdep +arraydep +basesetup-changed

Dependencies added: HUnit, array, base, binary, bytestring, cmdargs, containers, deepseq, derive, directory, dlist, fclabels, filepath, mtl, parallel, parsec, process, safe, syb, tamarin-prover-term, tamarin-prover-utils, time, transformers, uniplate

Files

+ LICENSE view
@@ -0,0 +1,621 @@+                    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
+ Setup.hs view
@@ -0,0 +1,93 @@+import Distribution.Simple+main = defaultMain++{- Inferring the package version from git. Posted by https://github.com/hvr+ -+ - https://gist.github.com/656738++import Control.Exception+import Control.Monad+import Data.Maybe+import Data.Version+import Distribution.PackageDescription (PackageDescription(..), HookedBuildInfo, GenericPackageDescription(..))+import Distribution.Package (PackageIdentifier(..))+import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, UserHooks(..))+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Setup (BuildFlags(..), ConfigFlags(..))+import Distribution.Simple.Utils (die)+import System.Process (readProcess)+import Text.ParserCombinators.ReadP (readP_to_S)++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+         { confHook = myConfHook+         , buildHook = myBuildHook+         }++-- configure hook+myConfHook :: (GenericPackageDescription, HookedBuildInfo)+           -> ConfigFlags+           -> IO LocalBuildInfo+myConfHook (gpdesc, hbinfo) cfg = do+  let GenericPackageDescription {+        packageDescription = pdesc@PackageDescription {+           package = pkgIden }} = gpdesc++  gitVersion <- inferVersionFromGit (pkgVersion (package pdesc))++  let gpdesc' = gpdesc {+        packageDescription = pdesc {+           package = pkgIden { pkgVersion = gitVersion } } }++  -- putStrLn $ showVersion gitVersion++  confHook simpleUserHooks (gpdesc', hbinfo) cfg+++-- build hook+myBuildHook :: PackageDescription+            -> LocalBuildInfo+            -> UserHooks+            -> BuildFlags+            -> IO ()+myBuildHook pdesc lbinfo uhooks bflags = do+  let lastVersion = pkgVersion $ package pdesc++  gitVersion <- inferVersionFromGit lastVersion ++  when (gitVersion /= lastVersion) $+    die("The version reported by git '" ++ showVersion gitVersion +++        "' has changed since last time this package was configured (version was '" +++        showVersion lastVersion ++ "' back then), please re-configure package")++  buildHook simpleUserHooks pdesc lbinfo uhooks bflags++-- |Infer package version from Git tags. Uses `git describe` to infer 'Version'.+inferVersionFromGit :: Version -> IO Version+inferVersionFromGit version0 = do+  ver_line <- init `liftM` readProcess "git"+              [ "describe"+              , "--abbrev=5"+              , "--tags"+              , "--match=v[0-9].[0-9][0-9]"+              , "--dirty"+              , "--long"+              , "--always"+              ] ""++  -- ver_line <- return "v0.1-42-gf9f4eb3-dirty"+  putStrLn ver_line+  -- let versionStr = ver_line -- (head ver_line == 'v') `assert` replaceFirst '-' '.' (tail ver_line)+      -- Just version = listToMaybe [ p | (p, "") <- readP_to_S parseVersion versionStr ]++  return version0++{-+-- | Helper for replacing first occurence of character by another one.+replaceFirst :: Eq a => a -> a -> [a] -> [a]+replaceFirst _ _ [] = []+replaceFirst o r (x:xs) | o == x    = r : xs+                        | otherwise = x : replaceFirst o r xs+-}++-}
+ src/Theory.hs view
@@ -0,0 +1,950 @@+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Theory datatype and transformations on it.+module Theory (+  -- * Axioms+    Axiom(..)+  , axName+  , axFormula++  -- * Lemmas+  , LemmaAttribute(..)+  , TraceQuantifier(..)+  , Lemma+  , lName+  , lTraceQuantifier+  , lFormula+  , lAttributes+  , lProof+  , unprovenLemma+  , skeletonLemma++  -- * Theories+  , Theory(..)+  , TheoryItem(..)+  , thyName+  , thySignature+  , thyCache+  , thyItems+  , theoryRules+  , theoryLemmas+  , theoryAxioms+  , addAxiom+  , addLemma+  , removeLemma+  , lookupLemma+  , addComment+  , addStringComment+  , addFormalComment+  , cprRuleE++  -- ** Open theories+  , OpenTheory+  , defaultOpenTheory+  , addProtoRule+  , applyPartialEvaluation+  , addIntrRuleACs+  , normalizeTheory++  -- ** Closed theories+  , ClosedTheory+  , ClosedRuleCache(..) -- FIXME: this is only exported for the Binary instances+  , closeTheory+  , openTheory++  , ClosedProtoRule(..)++  , getLemmas+  , getIntrVariants+  , getProtoRuleEs+  , getProofContext+  , getClassifiedRules+  , getInjectiveFactInsts++  , getCaseDistinction++  -- ** Proving+  , ProofSkeleton+  , proveTheory++  -- ** Lemma references+  , lookupLemmaProof+  , modifyLemmaProof++  -- * Pretty printing+  , prettyFormalComment+  , prettyLemmaName+  , prettyAxiom+  , prettyLemma+  , prettyClosedTheory+  , prettyOpenTheory++  , prettyClosedSummary++  , prettyIntruderVariants+  , prettyTraceQuantifier++  -- * Convenience exports+  , module Theory.Model+  , module Theory.Proof++  ) where++import           Prelude                             hiding (id, (.))++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable                       (Foldable, foldMap)+import           Data.List+import           Data.Maybe+import           Data.Monoid                         (Sum(..))+import qualified Data.Set                            as S+import           Data.Traversable                    (Traversable, traverse)++import           Control.Basics+import           Control.Category+import           Control.DeepSeq+import           Control.Monad.Reader+import qualified Control.Monad.State                 as MS+import           Control.Parallel.Strategies++import           Extension.Data.Label                hiding (get)+import qualified Extension.Data.Label                as L++import           Theory.Model+import           Theory.Proof+import           Theory.Text.Pretty+import           Theory.Tools.AbstractInterpretation+import           Theory.Tools.InjectiveFactInstances+import           Theory.Tools.LoopBreakers+import           Theory.Tools.RuleVariants++------------------------------------------------------------------------------+-- Specific proof types+------------------------------------------------------------------------------++-- | Proof skeletons are used to represent proofs in open theories.+type ProofSkeleton    = Proof ()++-- | Convert a proof skeleton to an incremental proof without any sequent+-- annotations.+skeletonToIncrementalProof :: ProofSkeleton -> IncrementalProof+skeletonToIncrementalProof = fmap (fmap (const Nothing))++-- | Convert an incremental proof to a proof skeleton by dropping all+-- annotations.+incrementalToSkeletonProof :: IncrementalProof -> ProofSkeleton+incrementalToSkeletonProof = fmap (fmap (const ()))+++------------------------------------------------------------------------------+-- Commented sets of rewriting rules+------------------------------------------------------------------------------++-- | A protocol rewriting rule modulo E together with its possible assertion+-- soundness proof.+type OpenProtoRule = ProtoRuleE++-- | A closed proto rule lists its original rule modulo E, the corresponding+-- variant modulo AC, and if required the assertion soundness proof.+data ClosedProtoRule = ClosedProtoRule+       { _cprRuleE  :: ProtoRuleE             -- original rule modulo E+       , _cprRuleAC :: ProtoRuleAC            -- variant modulo AC+       }+       deriving( Eq, Ord, Show )++type OpenRuleCache = [IntrRuleAC]++data ClosedRuleCache = ClosedRuleCache+       { _crcRules            :: ClassifiedRules+       , _crcUntypedCaseDists :: [CaseDistinction]+       , _crcTypedCaseDists   :: [CaseDistinction]+       , _crcInjectiveFactInsts  :: S.Set FactTag+       }+       deriving( Eq, Ord, Show )+++$(mkLabels [''ClosedProtoRule, ''ClosedRuleCache])++instance HasRuleName ClosedProtoRule where+    ruleName = ruleName . L.get cprRuleE+++-- Relation between open and closed rule sets+---------------------------------------------++-- | All intruder rules of a set of classified rules.+intruderRules :: ClassifiedRules -> [IntrRuleAC]+intruderRules rules = do+    Rule (IntrInfo i) ps cs as <- joinAllRules rules+    return $ Rule i ps cs as++-- | Open a rule cache. Variants and precomputed case distinctions are dropped.+openRuleCache :: ClosedRuleCache -> OpenRuleCache+openRuleCache = intruderRules . L.get crcRules++-- | Open a protocol rule; i.e., drop variants and proof annotations.+openProtoRule :: ClosedProtoRule -> OpenProtoRule+openProtoRule = L.get cprRuleE++-- | Close a protocol rule; i.e., compute AC variant and typing assertion+-- soundness sequent, if required.+closeProtoRule :: MaudeHandle -> OpenProtoRule -> ClosedProtoRule+closeProtoRule hnd ruE = ClosedProtoRule ruE (variantsProtoRule hnd ruE)+-- | Close a rule cache. Hower, note that the+-- requires case distinctions are not computed here.+closeRuleCache :: [LNGuarded]        -- ^ Axioms to use.+               -> [LNGuarded]        -- ^ Typing lemmas to use.+               -> SignatureWithMaude -- ^ Signature of theory.+               -> [ClosedProtoRule]  -- ^ Protocol rules with variants.+               -> OpenRuleCache      -- ^ Intruder rules modulo AC.+               -> ClosedRuleCache    -- ^ Cached rules and case distinctions.+closeRuleCache axioms typAsms sig protoRules intrRulesAC =+    ClosedRuleCache+        classifiedRules untypedCaseDists typedCaseDists injFactInstances+  where+    ctxt0 = ProofContext+        sig classifiedRules injFactInstances UntypedCaseDist [] AvoidInduction+        (error "closeRuleCache: trace quantifier should not matter here")++    -- inj fact instances+    injFactInstances =+        simpleInjectiveFactInstances $ L.get cprRuleE <$> protoRules++    -- precomputing the case distinctions: we make sure to only add safety+    -- axioms. Otherwise, it wouldn't be sound to use the precomputed case+    -- distinctions for properties proven using induction.+    safetyAxioms     = filter isSafetyFormula axioms+    untypedCaseDists = precomputeCaseDistinctions ctxt0 safetyAxioms+    typedCaseDists   = refineWithTypingAsms typAsms ctxt0 untypedCaseDists++    -- classifying the rules+    rulesAC = (fmap IntrInfo                      <$> intrRulesAC) <|>+              ((fmap ProtoInfo . L.get cprRuleAC) <$> protoRules)++    anyOf ps = partition (\x -> any ($ x) ps)++    (nonProto, proto) = anyOf [isDestrRule, isConstrRule] rulesAC+    (constr, destr)   = anyOf [isConstrRule] nonProto++    -- and sort them into ClassifiedRules datastructure for later use in proofs+    classifiedRules = ClassifiedRules+      { _crConstruct  = constr+      , _crDestruct   = destr+      , _crProtocol   = proto+      }+++------------------------------------------------------------------------------+-- Axioms (Trace filters)+------------------------------------------------------------------------------++-- | An axiom describes a property that must hold for all traces. Axioms are+-- always used as lemmas in proofs.+data Axiom = Axiom+       { _axName    :: String+       , _axFormula :: LNFormula+       }+       deriving( Eq, Ord, Show )++$(mkLabels [''Axiom])+++------------------------------------------------------------------------------+-- Lemmas+------------------------------------------------------------------------------++-- | An attribute for a 'Lemma'.+data LemmaAttribute =+         TypingLemma+       | ReuseLemma+       | InvariantLemma+       deriving( Eq, Ord, Show )++-- | A 'TraceQuantifier' stating whether we check satisfiability of validity.+data TraceQuantifier = ExistsTrace | AllTraces+       deriving( Eq, Ord, Show )++-- | A lemma describes a property that holds in the context of a theory+-- together with a proof of its correctness.+data Lemma p = Lemma+       { _lName            :: String+       , _lTraceQuantifier :: TraceQuantifier+       , _lFormula         :: LNFormula+       , _lAttributes      :: [LemmaAttribute]+       , _lProof           :: p+       }+       deriving( Eq, Ord, Show )++$(mkLabels [''Lemma])+++-- Instances+------------++instance Functor Lemma where+    fmap f (Lemma n qua fm atts prf) = Lemma n qua fm atts (f prf)++instance Foldable Lemma where+    foldMap f = f . L.get lProof++instance Traversable Lemma where+    traverse f (Lemma n qua fm atts prf) = Lemma n qua fm atts <$> f prf+++-- Lemma queries+----------------------------------++-- | Convert a trace quantifier to a sequent trace quantifier.+toSystemTraceQuantifier :: TraceQuantifier -> SystemTraceQuantifier+toSystemTraceQuantifier AllTraces   = ExistsNoTrace+toSystemTraceQuantifier ExistsTrace = ExistsSomeTrace++-- | True iff the lemma can be used as a typing lemma.+isTypingLemma :: Lemma p -> Bool+isTypingLemma lem =+     (AllTraces == L.get lTraceQuantifier lem)+  && (TypingLemma `elem` L.get lAttributes lem)+++-- Lemma construction/modification+----------------------------------++-- | Create a new unproven lemma from a formula modulo E.+unprovenLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> LNFormula+              -> Lemma ProofSkeleton+unprovenLemma name atts qua fm = Lemma name qua fm atts (unproven ())++skeletonLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> LNFormula+              -> ProofSkeleton -> Lemma ProofSkeleton+skeletonLemma name atts qua fm = Lemma name qua fm atts++-- | The case-distinction kind allowed for a lemma+lemmaCaseDistKind :: Lemma p -> CaseDistKind+lemmaCaseDistKind lem+  | TypingLemma `elem` L.get lAttributes lem = UntypedCaseDist+  | otherwise                                = TypedCaseDist+++------------------------------------------------------------------------------+-- Theories+------------------------------------------------------------------------------++-- | A formal comment is a header together with the body of the comment.+type FormalComment = (String, String)++-- | A theory item built over the given rule type.+data TheoryItem r p =+       RuleItem r+     | LemmaItem (Lemma p)+     | AxiomItem Axiom+     | TextItem FormalComment+     deriving( Show, Eq, Ord, Functor )+++-- | A theory contains a single set of rewriting rules modeling a protocol+-- and the lemmas that+data Theory sig c r p = Theory {+         _thyName      :: String+       , _thySignature :: sig+       , _thyCache     :: c+       , _thyItems     :: [TheoryItem r p]+       }+       deriving( Eq, Ord, Show )++$(mkLabels [''Theory])++-- | Open theories can be extended. Invariants:+--   1. Lemma names are unique.+type OpenTheory =+    Theory SignaturePure [IntrRuleAC] OpenProtoRule ProofSkeleton+++-- | Closed theories can be proven. Invariants:+--     1. Lemma names are unique+--     2. All proof steps with annotated sequents are sound with respect to the+--        closed rule set of the theory.+--     3. Maude is running under the given handle.+type ClosedTheory =+    Theory SignatureWithMaude ClosedRuleCache ClosedProtoRule IncrementalProof++++-- Shared theory modification functions+---------------------------------------++-- | Fold a theory item.+foldTheoryItem+    :: (r -> a) -> (Axiom -> a) -> (Lemma p -> a) -> (FormalComment -> a)+    -> TheoryItem r p -> a+foldTheoryItem fRule fAxiom fLemma fText i = case i of+    RuleItem ru   -> fRule ru+    LemmaItem lem -> fLemma lem+    TextItem txt  -> fText txt+    AxiomItem ax  -> fAxiom ax++-- | Map a theory item.+mapTheoryItem :: (r -> r') -> (p -> p') -> TheoryItem r p -> TheoryItem r' p'+mapTheoryItem f g =+    foldTheoryItem (RuleItem . f) AxiomItem (LemmaItem . fmap g) TextItem++-- | All rules of a theory.+theoryRules :: Theory sig c r p -> [r]+theoryRules =+    foldTheoryItem return (const []) (const []) (const []) <=< L.get thyItems++-- | All axioms of a theory.+theoryAxioms :: Theory sig c r p -> [Axiom]+theoryAxioms =+    foldTheoryItem (const []) return (const []) (const []) <=< L.get thyItems++-- | All lemmas of a theory.+theoryLemmas :: Theory sig c r p -> [Lemma p]+theoryLemmas =+    foldTheoryItem (const []) (const []) return (const []) <=< L.get thyItems++-- | Add a new axiom. Fails, if axiom with the same name exists.+addAxiom :: Axiom -> Theory sig c r p -> Maybe (Theory sig c r p)+addAxiom l thy = do+    guard (isNothing $ lookupAxiom (L.get axName l) thy)+    return $ modify thyItems (++ [AxiomItem l]) thy++-- | Add a new lemma. Fails, if a lemma with the same name exists.+addLemma :: Lemma p -> Theory sig c r p -> Maybe (Theory sig c r p)+addLemma l thy = do+    guard (isNothing $ lookupLemma (L.get lName l) thy)+    return $ modify thyItems (++ [LemmaItem l]) thy++-- | Remove a lemma by name. Fails, if the lemma does not exist.+removeLemma :: String -> Theory sig c r p -> Maybe (Theory sig c r p)+removeLemma lemmaName thy = do+    _ <- lookupLemma lemmaName thy+    return $ modify thyItems (concatMap fItem) thy+  where+    fItem   = foldTheoryItem (return . RuleItem)+                             (return . AxiomItem)+                             check+                             (return . TextItem)+    check l = do guard (L.get lName l /= lemmaName); return (LemmaItem l)++-- | Find the axiom with the given name.+lookupAxiom :: String -> Theory sig c r p -> Maybe Axiom+lookupAxiom name = find ((name ==) . L.get axName) . theoryAxioms++-- | Find the lemma with the given name.+lookupLemma :: String -> Theory sig c r p -> Maybe (Lemma p)+lookupLemma name = find ((name ==) . L.get lName) . theoryLemmas++-- | Add a comment to the theory.+addComment :: Doc -> Theory sig c r p -> Theory sig c r p+addComment c = modify thyItems (++ [TextItem ("", render c)])++-- | Add a comment represented as a string to the theory.+addStringComment :: String -> Theory sig c r p -> Theory sig c r p+addStringComment = addComment . vcat . map text . lines++addFormalComment :: FormalComment -> Theory sig c r p -> Theory sig c r p+addFormalComment c = modify thyItems (++ [TextItem c])+++------------------------------------------------------------------------------+-- Open theory construction / modification+------------------------------------------------------------------------------++-- | Default theory+defaultOpenTheory :: OpenTheory+defaultOpenTheory = Theory "default" emptySignaturePure [] []++-- | Open a theory by dropping the closed world assumption and values whose+-- soundness dependens on it.+openTheory :: ClosedTheory -> OpenTheory+openTheory  (Theory n sig c items) =+    Theory n (toSignaturePure sig) (openRuleCache c)+      (map (mapTheoryItem openProtoRule incrementalToSkeletonProof) items)++-- | Find the open protocol rule with the given name.+lookupOpenProtoRule :: ProtoRuleName -> OpenTheory -> Maybe OpenProtoRule+lookupOpenProtoRule name =+    find ((name ==) . L.get rInfo) . theoryRules++-- | Add a new protocol rules. Fails, if a protocol rule with the same name+-- exists.+addProtoRule :: ProtoRuleE -> OpenTheory -> Maybe OpenTheory+addProtoRule ruE thy = do+    guard nameNotUsedForDifferentRule+    return $ modify thyItems (++ [RuleItem ruE]) thy+  where+    nameNotUsedForDifferentRule =+        maybe True ((ruE ==)) $ lookupOpenProtoRule (L.get rInfo ruE) thy+++-- | Add intruder proof rules.+addIntrRuleACs :: [IntrRuleAC] -> OpenTheory -> OpenTheory+addIntrRuleACs rs' = modify (thyCache) (\rs -> nub $ rs ++ rs')++-- | Normalize the theory representation such that they remain semantically+-- equivalent. Use this function when you want to compare two theories (quite+-- strictly) for semantic equality; e.g., when testing the parser.+normalizeTheory :: OpenTheory -> OpenTheory+normalizeTheory =+    L.modify thyCache sort+  . L.modify thyItems (\items -> do+      item <- items+      return $ case item of+          LemmaItem lem ->+              LemmaItem $ L.modify lProof stripProofAnnotations $ lem+          RuleItem _    -> item+          TextItem _    -> item+          AxiomItem _   -> item)+  where+    stripProofAnnotations :: ProofSkeleton -> ProofSkeleton+    stripProofAnnotations = fmap stripProofStepAnnotations+    stripProofStepAnnotations (ProofStep method ()) =+        ProofStep (case method of+                     Sorry _         -> Sorry Nothing+                     Contradiction _ -> Contradiction Nothing+                     _               -> method)+                  ()+++------------------------------------------------------------------------------+-- Closed theory querying / construction / modification+------------------------------------------------------------------------------++-- querying+-----------++-- | All lemmas.+getLemmas :: ClosedTheory -> [Lemma IncrementalProof]+getLemmas = theoryLemmas++-- | The variants of the intruder rules.+getIntrVariants :: ClosedTheory -> [IntrRuleAC]+getIntrVariants = intruderRules . L.get (crcRules . thyCache)++-- | All protocol rules modulo E.+getProtoRuleEs :: ClosedTheory -> [ProtoRuleE]+getProtoRuleEs = map openProtoRule . theoryRules++-- | Get the proof context for a lemma of the closed theory.+getProofContext :: Lemma a -> ClosedTheory -> ProofContext+getProofContext l thy = ProofContext+    ( L.get thySignature                    thy)+    ( L.get (crcRules . thyCache)           thy)+    ( L.get (crcInjectiveFactInsts . thyCache) thy)+    kind+    ( L.get (cases . thyCache)              thy)+    inductionHint+    (toSystemTraceQuantifier $ L.get lTraceQuantifier l)+  where+    kind    = lemmaCaseDistKind l+    cases   = case kind of UntypedCaseDist -> crcUntypedCaseDists+                           TypedCaseDist   -> crcTypedCaseDists+    inductionHint+      | any (`elem` [TypingLemma, InvariantLemma]) (L.get lAttributes l) = UseInduction+      | otherwise                                                        = AvoidInduction++-- | The facts with injective instances in this theory+getInjectiveFactInsts :: ClosedTheory -> S.Set FactTag+getInjectiveFactInsts = L.get (crcInjectiveFactInsts . thyCache)++-- | The classified set of rules modulo AC in this theory.+getClassifiedRules :: ClosedTheory -> ClassifiedRules+getClassifiedRules = L.get (crcRules . thyCache)++-- | The precomputed case distinctions.+getCaseDistinction :: CaseDistKind -> ClosedTheory -> [CaseDistinction]+getCaseDistinction UntypedCaseDist = L.get (crcUntypedCaseDists . thyCache)+getCaseDistinction TypedCaseDist   = L.get (crcTypedCaseDists . thyCache)+++-- construction+---------------++-- -- | Convert a lemma to the corresponding guarded formula.+-- lemmaToGuarded :: Lemma p -> Maybe LNGuarded+-- lemmaToGuarded lem =++-- | Close a theory by closing its associated rule set and checking the proof+-- skeletons and caching AC variants as well as precomputed case distinctions.+--+-- This function initializes the relation to the Maude process with the+-- correct signature. This is the right place to do that because in a closed+-- theory the signature may not change any longer.+closeTheory :: FilePath         -- ^ Path to the Maude executable.+            -> OpenTheory+            -> IO ClosedTheory+closeTheory maudePath thy0 = do+    sig <- toSignatureWithMaude maudePath $ L.get thySignature thy0+    return $ closeTheoryWithMaude sig thy0++-- | Close a theory given a maude signature. This signature must be valid for+-- the given theory.+closeTheoryWithMaude :: SignatureWithMaude -> OpenTheory -> ClosedTheory+closeTheoryWithMaude sig thy0 = do+      proveTheory (const True) checkProof+    $ Theory (L.get thyName thy0) sig cache items+  where+    cache      = closeRuleCache axioms typAsms sig rules (L.get thyCache thy0)+    checkProof = checkAndExtendProver (sorryProver Nothing)++    -- Maude / Signature handle+    hnd = L.get sigmMaudeHandle sig++    -- Close all theory items: in parallel (especially useful for variants)+    --+    -- NOTE that 'rdeepseq' is OK here, as the proof has not yet been checked+    -- and therefore no constraint systems will be unnecessarily cached.+    (items, _solveRel, _breakers) = (`runReader` hnd) $ addSolvingLoopBreakers+       ((closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq)+    closeTheoryItem = foldTheoryItem+       (RuleItem . closeProtoRule hnd)+       AxiomItem+       (LemmaItem . fmap skeletonToIncrementalProof)+       TextItem++    -- extract typing axioms and lemmas+    axioms  = do AxiomItem ax <- items+                 return $ formulaToGuarded_ $ L.get axFormula ax+    typAsms = do LemmaItem lem <- items+                 guard (isTypingLemma lem)+                 return $ formulaToGuarded_ $ L.get lFormula lem++    -- extract protocol rules+    rules = theoryRules (Theory errClose errClose errClose items)+    errClose = error "closeTheory"++    addSolvingLoopBreakers = useAutoLoopBreakersAC+        (liftToItem $ enumPrems . L.get cprRuleAC)+        (liftToItem $ enumConcs . L.get cprRuleAC)+        (liftToItem $ getDisj . L.get (pracVariants . rInfo . cprRuleAC))+        addBreakers+      where+        liftToItem f (RuleItem ru) = f ru+        liftToItem _ _             = []++        addBreakers bs (RuleItem ru) =+            RuleItem (L.set (pracLoopBreakers . rInfo . cprRuleAC) bs ru)+        addBreakers _  item = item++++-- Partial evaluation / abstract interpretation+-----------------------------------------------++-- | Apply partial evaluation.+applyPartialEvaluation :: EvaluationStyle -> ClosedTheory -> ClosedTheory+applyPartialEvaluation evalStyle thy0 =+    closeTheoryWithMaude sig $+    L.modify thyItems replaceProtoRules (openTheory thy0)+  where+    sig          = L.get thySignature thy0+    ruEs         = getProtoRuleEs thy0+    (st', ruEs') = (`runReader` L.get sigmMaudeHandle sig) $+                   partialEvaluation evalStyle ruEs++    replaceProtoRules [] = []+    replaceProtoRules (item:items)+      | isRuleItem item  =+          [ TextItem ("text", render ppAbsState)++          ] ++ map RuleItem ruEs' ++ filter (not . isRuleItem) items+      | otherwise        = item : replaceProtoRules items++    isRuleItem (RuleItem _) = True+    isRuleItem _            = False++    ppAbsState =+      (text $ " the abstract state after partial evaluation"+              ++ " contains " ++ show (S.size st') ++ " facts:") $--$+      (numbered' $ map prettyLNFact $ S.toList st') $--$+      (text $ "This abstract state results in " ++ show (length ruEs') +++              " refined multiset rewriting rules.\n" +++              "Note that the original number of multiset rewriting rules was "+              ++ show (length ruEs) ++ ".\n\n")++-- Applying provers+-------------------++-- | Prove both the assertion soundness as well as all lemmas of the theory. If+-- the prover fails on a lemma, then its proof remains unchanged.+proveTheory :: (Lemma IncrementalProof -> Bool)   -- ^ Lemma selector.+            -> Prover+            -> ClosedTheory+            -> ClosedTheory+proveTheory selector prover thy =+    modify thyItems ((`MS.evalState` []) . mapM prove) thy+  where+    prove item = case item of+      LemmaItem l0 -> do l <- MS.gets (LemmaItem . proveLemma l0)+                         MS.modify (l :)+                         return l+      _            -> do return item++    proveLemma lem preItems+      | selector lem = modify lProof add lem+      | otherwise    = lem+      where+        ctxt    = getProofContext lem thy+        sys     = mkSystem ctxt (theoryAxioms thy) preItems $ L.get lFormula lem+        add prf = fromMaybe prf $ runProver prover ctxt 0 sys prf++-- | Construct a constraint system for verifying the given formula.+mkSystem :: ProofContext -> [Axiom] -> [TheoryItem r p]+         -> LNFormula -> System+mkSystem ctxt axioms previousItems =+    -- Note that it is OK to add reusable lemmas directly to the system, as+    -- they do not change the considered set of traces. This is the key+    -- difference between lemmas and axioms.+    addLemmas+  . formulaToSystem (map (formulaToGuarded_ . L.get axFormula) axioms)+                    (L.get pcCaseDistKind ctxt)+                    (L.get pcTraceQuantifier ctxt)+  where+    addLemmas sys =+        insertLemmas (gatherReusableLemmas $ L.get sCaseDistKind sys) sys++    gatherReusableLemmas kind = do+        LemmaItem lem <- previousItems+        guard $    lemmaCaseDistKind lem <= kind+                && ReuseLemma `elem` L.get lAttributes lem+                && AllTraces == L.get lTraceQuantifier lem+        return $ formulaToGuarded_ $ L.get lFormula lem+++------------------------------------------------------------------------------+-- References to lemmas+------------------------------------------------------------------------------++-- | Lemmas are referenced by their name.+type LemmaRef = String++-- | Resolve a path in a theory.+lookupLemmaProof :: LemmaRef -> ClosedTheory -> Maybe IncrementalProof+lookupLemmaProof name thy = L.get lProof <$> lookupLemma name thy++-- | Modify the proof at the given lemma ref, if there is one. Fails if the+-- path is not present or if the prover fails.+modifyLemmaProof :: Prover -> LemmaRef -> ClosedTheory -> Maybe ClosedTheory+modifyLemmaProof prover name thy =+    modA thyItems changeItems thy+  where+    findLemma (LemmaItem lem) = name == L.get lName lem+    findLemma _               = False++    change preItems (LemmaItem lem) = do+         let ctxt = getProofContext lem thy+             sys  = mkSystem ctxt (theoryAxioms thy) preItems $ L.get lFormula lem+         lem' <- modA lProof (runProver prover ctxt 0 sys) lem+         return $ LemmaItem lem'+    change _ _ = error "LemmaProof: change: impossible"++    changeItems items = case break findLemma items of+        (pre, i:post) -> do+             i' <- change pre i+             return $ pre ++ i':post+        (_, []) -> Nothing+++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty print a formal comment+prettyFormalComment :: HighlightDocument d => String -> String -> d+prettyFormalComment "" body = multiComment_ [body]+prettyFormalComment header body = text $ header ++ "{*" ++ body ++ "*}"++-- | Pretty print a theory.+prettyTheory :: HighlightDocument d+             => (sig -> d) -> (c -> d) -> (r -> d) -> (p -> d)+             -> Theory sig c r p -> d+prettyTheory ppSig ppCache ppRule ppPrf thy = vsep $+    [ kwTheoryHeader $ text $ L.get thyName thy+    , lineComment_ "Function signature and definition of the equational theory E"+    , ppSig $ L.get thySignature thy+    , ppCache $ L.get thyCache thy+    ] +++    parMap rdeepseq ppItem (L.get thyItems thy) +++    [ kwEnd ]+  where+    ppItem = foldTheoryItem+        ppRule prettyAxiom (prettyLemma ppPrf) (uncurry prettyFormalComment)++-- | Pretty print the lemma name together with its attributes.+prettyLemmaName :: HighlightDocument d => Lemma p -> d+prettyLemmaName l = case L.get lAttributes l of+      [] -> text (L.get lName l)+      as -> text (L.get lName l) <->+            (brackets $ fsep $ punctuate comma $ map prettyLemmaAttribute as)+  where+    prettyLemmaAttribute TypingLemma    = text "typing"+    prettyLemmaAttribute ReuseLemma     = text "reuse"+    prettyLemmaAttribute InvariantLemma = text "use_induction"++-- | Pretty print an axiom.+prettyAxiom :: HighlightDocument d => Axiom -> d+prettyAxiom ax =+    kwAxiom <-> text (L.get axName ax) <> colon $-$+    (nest 2 $ doubleQuotes $ prettyLNFormula $ L.get axFormula ax) $-$+    (nest 2 $ if safety then lineComment_ "safety formula" else emptyDoc)+  where+    safety = isSafetyFormula $ formulaToGuarded_ $ L.get axFormula ax++-- | Pretty print a lemma.+prettyLemma :: HighlightDocument d => (p -> d) -> Lemma p -> d+prettyLemma ppPrf lem =+    kwLemma <-> prettyLemmaName lem <> colon $-$+    (nest 2 $+      sep [ prettyTraceQuantifier $ L.get lTraceQuantifier lem+          , doubleQuotes $ prettyLNFormula $ L.get lFormula lem+          ]+    )+    $-$+    ppLNFormulaGuarded (L.get lFormula lem)+    $-$+    ppPrf (L.get lProof lem)+  where+    ppLNFormulaGuarded fm = case formulaToGuarded fm of+        Left err -> multiComment $+            text "conversion to guarded formula failed:" $$+            nest 2 err+        Right gf -> case toSystemTraceQuantifier $ L.get lTraceQuantifier lem of+          ExistsNoTrace -> multiComment+            ( text "guarded formula characterizing all counter-examples:" $-$+              doubleQuotes (prettyGuarded (gnot gf)) )+          ExistsSomeTrace -> multiComment+            ( text "guarded formula characterizing all satisfying traces:" $-$+              doubleQuotes (prettyGuarded gf) )+++-- | Pretty-print a non-empty bunch of intruder rules.+prettyIntruderVariants :: HighlightDocument d => [IntrRuleAC] -> d+prettyIntruderVariants vs = vcat . intersperse (text "") $ map prettyIntrRuleAC vs++{-+-- | Pretty-print the intruder variants section.+prettyIntrVariantsSection :: HighlightDocument d => [IntrRuleAC] -> d+prettyIntrVariantsSection rules =+    prettyFormalComment "section" " Finite Variants of the Intruder Rules " $--$+    nest 1 (prettyIntruderVariants rules)+-}++-- | Pretty print an open rule together with its assertion soundness proof.+prettyOpenProtoRule :: HighlightDocument d => OpenProtoRule -> d+prettyOpenProtoRule = prettyProtoRuleE++prettyIncrementalProof :: HighlightDocument d => IncrementalProof -> d+prettyIncrementalProof = prettyProofWith ppStep (const id)+  where+    ppStep step = sep+      [ prettyProofMethod (psMethod step)+      , if isNothing (psInfo step) then multiComment_ ["unannotated"]+                                   else emptyDoc+      ]++-- | Pretty print an closed rule.+prettyClosedProtoRule :: HighlightDocument d => ClosedProtoRule -> d+prettyClosedProtoRule cru =+    (prettyProtoRuleE ruE) $--$+    (nest 2 $ prettyLoopBreakers (L.get rInfo ruAC) $-$ ppRuleAC)+  where+    ruAC = L.get cprRuleAC cru+    ruE  = L.get cprRuleE cru+    ppRuleAC+      | isTrivialProtoVariantAC ruAC ruE = multiComment_ ["has exactly the trivial AC variant"]+      | otherwise                        = multiComment $ prettyProtoRuleAC ruAC++-- | Pretty print an open theory.+prettyOpenTheory :: HighlightDocument d => OpenTheory -> d+prettyOpenTheory =+    prettyTheory prettySignaturePure+                 (const emptyDoc) prettyOpenProtoRule prettyProof+                 -- prettyIntrVariantsSection prettyOpenProtoRule prettyProof++-- | Pretty print a closed theory.+prettyClosedTheory :: HighlightDocument d => ClosedTheory -> d+prettyClosedTheory thy =+    prettyTheory prettySignatureWithMaude+                 ppInjectiveFactInsts+                 -- (prettyIntrVariantsSection . intruderRules . L.get crcRules)+                 prettyClosedProtoRule+                 prettyIncrementalProof+                 thy+  where+    ppInjectiveFactInsts crc =+        case S.toList $ L.get crcInjectiveFactInsts crc of+            []   -> emptyDoc+            tags -> lineComment $ sep+                      [ text "looping facts with injective instances:"+                      , nest 2 $ fsepList (text . showFactTagArity) tags ]++prettyClosedSummary :: Document d => ClosedTheory -> d+prettyClosedSummary thy =+    vcat lemmaSummaries+  where+    lemmaSummaries = do+        LemmaItem lem  <- L.get thyItems thy+        -- Note that here we are relying on the invariant that all proof steps+        -- with a 'Just' annotation follow from the application of+        -- 'execProofMethod' to their parent and are valid in the sense that+        -- the application of 'execProofMethod' to their method and constraint+        -- system is guaranteed to succeed.+        --+        -- This is guaranteed initially by 'closeTheory' and is (must be)+        -- maintained by the provers being applied to the theory using+        -- 'modifyLemmaProof' or 'proveTheory'. Note that we could check the+        -- proof right before computing its status. This is however quite+        -- expensive, as it requires recomputing all intermediate constraint+        -- systems.+        --+        -- TODO: The whole consruction seems a bit hacky. Think of a more+        -- principled constrution with better correctness guarantees.+        let (status, Sum siz) = foldProof proofStepSummary $ L.get lProof lem+            quantifier = (toSystemTraceQuantifier $ L.get lTraceQuantifier lem)+            analysisType = parens $ prettyTraceQuantifier $ L.get lTraceQuantifier lem+        return $ text (L.get lName lem) <-> analysisType <> colon <->+                 text (showProofStatus quantifier status) <->+                 parens (integer siz <-> text "steps")++    proofStepSummary = proofStepStatus &&& const (Sum (1::Integer))+++-- | Pretty print a 'TraceQuantifier'.+prettyTraceQuantifier :: Document d => TraceQuantifier -> d+prettyTraceQuantifier ExistsTrace = text "exists-trace"+prettyTraceQuantifier AllTraces   = text "all-traces"+++-- Instances: FIXME: Sort them into the right files+--------------------------------------------------++$( derive makeBinary ''TheoryItem)+$( derive makeBinary ''LemmaAttribute)+$( derive makeBinary ''TraceQuantifier)+$( derive makeBinary ''Axiom)+$( derive makeBinary ''Lemma)+$( derive makeBinary ''ClosedProtoRule)+$( derive makeBinary ''ClosedRuleCache)+$( derive makeBinary ''Theory)++$( derive makeNFData ''TheoryItem)+$( derive makeNFData ''LemmaAttribute)+$( derive makeNFData ''TraceQuantifier)+$( derive makeNFData ''Axiom)+$( derive makeNFData ''Lemma)+$( derive makeNFData ''ClosedProtoRule)+$( derive makeNFData ''ClosedRuleCache)+$( derive makeNFData ''Theory)+
+ src/Theory/Constraint/Solver.hs view
@@ -0,0 +1,79 @@+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- The public interface of the constraint solver, which implements all+-- constraint reduction rules and together with a rule application heuristic.+module Theory.Constraint.Solver (++  -- * Constraint systems+    module Theory.Constraint.System++  -- * Proof contexts+  -- | The proof context captures all relevant information about the context+  -- in which we are using the constraint solver. These are things like the+  -- signature of the message theory, the multiset rewriting rules of the+  -- protocol, the available precomputed case distinctions, whether induction+  -- should be applied or not, whether typed or untyped case distinctions are+  -- used, and whether we are looking for the existence of a trace or proving+  -- the absence of any trace satisfying the constraint system.+  , ProofContext(..)+  , pcSignature+  , pcRules+  , pcCaseDists+  , pcUseInduction+  , pcCaseDistKind+  , pcTraceQuantifier+  , pcInjectiveFactInsts++  , InductionHint(..)++  , ClassifiedRules(..)+  , joinAllRules+  , crProtocol+  , crConstruct+  , crDestruct++  -- * Constraint reduction rules++  -- ** Contradictions+  -- | All rules that reduce a constraint system to the empty set of+  -- constraint systems. The 'Contradiction' datatype stores the information+  -- about the contradiction for later display to the user.+  , Contradiction+  , contradictions++  -- ** Precomputed case distinctions+  -- | For better speed, we precompute case distinctions. This is especially+  -- important for getting rid of all chain constraints before actually+  -- starting to verify security properties.+  , CaseDistinction+  , cdGoal+  , cdCases++  , precomputeCaseDistinctions+  , refineWithTypingAsms+  , unsolvedChainConstraints++  -- * Proof methods+  -- | Proof methods are the external to the constraint solver. They allow its+  -- small step execution. This module also provides the heuristics for+  -- selecting the best proof method to apply to a constraint system.+  , module Theory.Constraint.Solver.ProofMethod++  -- ** Convenience export+  , module Logic.Connectives++  ) where++import           Logic.Connectives+import           Theory.Constraint.Solver.CaseDistinctions+import           Theory.Constraint.Solver.Contradictions+import           Theory.Constraint.Solver.ProofMethod+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System++
+ src/Theory/Constraint/Solver/CaseDistinctions.hs view
@@ -0,0 +1,318 @@+-- |+-- Copyright   : (c) 2011,2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Big-step proofs using case distinctions on the possible sources of a fact.+module Theory.Constraint.Solver.CaseDistinctions (+  -- * Precomputed case distinctions++  -- ** Queries+    unsolvedChainConstraints++  -- ** Construction+  , precomputeCaseDistinctions+  , refineWithTypingAsms++  -- ** Application+  , solveWithCaseDistinction++  ) where++import           Prelude                                 hiding (id, (.))+import           Safe++import           Data.Foldable                           (asum)+import qualified Data.Map                                as M+import           Data.Maybe                              (isJust)+import qualified Data.Set                                as S++import           Control.Basics+import           Control.Category+import           Control.Monad.Disj+import           Control.Monad.Reader+import           Control.Monad.State                     (gets)+import           Control.Parallel.Strategies++import           Text.PrettyPrint.Highlight++import           Extension.Data.Label+import           Extension.Prelude++import           Theory.Constraint.Solver.Contradictions (contradictorySystem)+import           Theory.Constraint.Solver.Goals+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Simplify+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++------------------------------------------------------------------------------+-- Precomputing case distinctions+------------------------------------------------------------------------------++-- | The number of remaining chain constraints of each case.+unsolvedChainConstraints :: CaseDistinction -> [Int]+unsolvedChainConstraints =+    map (length . unsolvedChains . snd) . getDisj . get cdCases+++-- Construction+---------------++-- | The initial case distinction if the given goal is required and the+-- given typing assumptions are justified.+initialCaseDistinction+    :: ProofContext+    -> [LNGuarded] -- ^ Axioms.+    -> Goal+    -> CaseDistinction+initialCaseDistinction ctxt axioms goal =+    CaseDistinction goal cases+  where+    polish ((name, se), _) = ([name], se)+    se0   = insertLemmas axioms $ emptySystem UntypedCaseDist+    cases = fmap polish $+        runReduction instantiate ctxt se0 (avoid (goal, se0))+    instantiate = do+        insertGoal goal False+        solveGoal goal++-- | Refine a source case distinction by applying the additional proof step.+refineCaseDistinction+    :: ProofContext+    -> Reduction (a, [String])  -- proof step with result and path extension+    -> CaseDistinction+    -> ([a], CaseDistinction)+refineCaseDistinction ctxt proofStep th =+    ( map fst $ getDisj refinement+    , set cdCases (snd <$> refinement) th )+  where+    fs         = avoid th+    refinement = do+        (names, se)   <- get cdCases th+        ((x, names'), se') <- fst <$> runReduction proofStep ctxt se fs+        return (x, (combine names names', se'))++    -- Combine names such that the coerce rule is blended out.+    combine []            ns' = ns'+    combine ("coerce":ns) ns' = combine ns ns'+    combine (n       :_)  _   = [n]++-- | Solves all chain and splitting goals as well as all premise goals solvable+-- with one of the given precomputed requires case distinction theorems, while+-- repeatedly simplifying the proof state.+--+-- Returns the names of the steps applied.+solveAllSafeGoals :: [CaseDistinction] -> Reduction [String]+solveAllSafeGoals ths =+    solve []+  where+    safeGoal _       (_,   (_, LoopBreaker)) = False+    safeGoal doSplit (goal, _              ) =+      case goal of+        ChainG _ _    -> True+        ActionG _ fa  -> not (isKUFact fa)+        PremiseG _ fa -> not (isKUFact fa)+        DisjG _       -> doSplit+        -- Uncomment to get more extensive case splitting+        -- SplitG _   -> doSplit+        SplitG _      -> False++    usefulGoal (_, (_, Useful)) = True+    usefulGoal _                = False++    solve caseNames = do+        simplifySystem+        ctxt <- ask+        contradictoryIf =<< gets (contradictorySystem ctxt)+        goals  <- gets openGoals+        chains <- gets unsolvedChains+        -- try to either solve a safe goal or use one of the precomputed case+        -- distinctions+        let noChainGoals = null [ () | (ChainG _ _, _) <- goals ]+            -- we perform equation splits, if there is a chain goal starting+            -- from a message variable; i.e., a chain constraint that is no+            -- open goal.+            splitAllowed = noChainGoals && not (null chains)+            safeGoals    = fst <$> filter (safeGoal splitAllowed) goals+            usefulGoals  = fst <$> filter usefulGoal goals+            nextStep        =+                ((fmap return . solveGoal) <$> headMay safeGoals) <|>+                (asum $ map (solveWithCaseDistinction ctxt ths) usefulGoals)+        case nextStep of+          Nothing   -> return $ caseNames+          Just step -> solve . (caseNames ++) =<< step+++------------------------------------------------------------------------------+-- Applying precomputed case distinctions+------------------------------------------------------------------------------++-- | Match a precomputed 'CaseDistinction' to a goal.+matchToGoal+    :: ProofContext     -- ^ Proof context used for refining the case distinction.+    -> CaseDistinction  -- ^ Case distinction to use.+    -> Goal             -- ^ Goal to match+    -> Maybe (Reduction [String])+    -- ^ A constraint reduction step to apply the resulting case distinction.+    -- Note that this step assumes that the theorem has been imported using+    -- 'someInst' into the context that this reduction is executed in.+    --+    -- FIXME: This is a mess. Factor code such that this inter-dependency+    -- between 'applyCaseDistinction' and 'matchToGoal' goes away.+matchToGoal ctxt th goalTerm =+  case (goalTerm, get cdGoal th) of+    ( PremiseG      (iTerm, premIdxTerm) faTerm+     ,PremiseG pPat@(iPat,  _          ) faPat  ) ->+        let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in+        case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of+            []      -> Nothing+            subst:_ -> Just $ genericApply subst $+                -- add the missing edge to each case of the theorem+                modify sEdges (substNodePrem pPat (iPat, premIdxTerm))++    (ActionG iTerm faTerm, ActionG iPat faPat) ->+        let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in+        case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of+            []      -> Nothing+            subst:_ -> Just $ genericApply subst id++    -- No other matches possible, as we only precompute case distinctions for+    -- premises and KU-actions.+    _ -> Nothing+  where+    genericApply subst systemModifier = do+        void (solveSubstEqs SplitNow subst)+        (names, sysTh) <- disjunctionOfList $ getDisj $ get cdCases th+        conjoinSystem (systemModifier sysTh)+        return names++    substNodePrem from to = S.map+        (\ e@(Edge c p) -> if p == from then Edge c to else e)++-- | Try to solve a premise goal or 'Ded' action using the first precomputed+-- case distinction with a matching premise.+solveWithCaseDistinction :: ProofContext+                         -> [CaseDistinction]+                         -> Goal+                         -> Maybe (Reduction [String])+solveWithCaseDistinction hnd ths goal = do+    -- goal <- toBigStepGoal goal0+    asum [ applyCaseDistinction hnd th goal | th <- ths ]++-- | Apply a precomputed case distinction theorem to a required fact.+applyCaseDistinction :: ProofContext+                     -> CaseDistinction    -- ^ Case distinction theorem.+                     -> Goal               -- ^ Required goal+                     -> Maybe (Reduction [String])+applyCaseDistinction ctxt th goal+  | isJust $ matchToGoal ctxt th goal = Just $ do+        markGoalAsSolved "precomputed" goal+        thRenamed <- rename th+        fromJustNote "applyCaseDistinction: impossible" $+            matchToGoal ctxt thRenamed goal++  | otherwise = Nothing++-- | Saturate the case distinctions with respect to each other such that no+-- additional splitting is introduced; i.e., only rules with a single or no+-- conclusion are used for the saturation.+saturateCaseDistinctions+    :: ProofContext -> [CaseDistinction] -> [CaseDistinction]+saturateCaseDistinctions ctxt =+    go+  where+    go ths =+        if any or (changes `using` parList rdeepseq)+          then go ths'+          else ths'+      where+        (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths+        goodTh th  = length (getDisj (get cdCases th)) <= 1+        solver     = do names <- solveAllSafeGoals (filter goodTh ths)+                        return (not $ null names, names)++-- | Precompute a saturated set of case distinctions.+precomputeCaseDistinctions+    :: ProofContext+    -> [LNGuarded]       -- ^ Axioms.+    -> [CaseDistinction]+precomputeCaseDistinctions ctxt axioms =+    map cleanupCaseNames $ saturateCaseDistinctions ctxt rawCaseDists+  where+    cleanupCaseNames = modify cdCases $ fmap $ first $+        filter (not . null)+      . map (filter (`elem` '_' : ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']))++    rawCaseDists =+        initialCaseDistinction ctxt axioms <$> (protoGoals ++ msgGoals)++    -- construct case distinction starting from facts from non-special rules+    protoGoals = someProtoGoal <$> absProtoFacts+    msgGoals   = someKUGoal <$> absMsgFacts++    getProtoFact (Fact KUFact _ ) = mzero+    getProtoFact (Fact KDFact _ ) = mzero+    getProtoFact fa               = return fa++    absFact (Fact tag ts) = (tag, length ts)++    nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ]++    someProtoGoal :: (FactTag, Int) -> Goal+    someProtoGoal (tag, arity) =+        PremiseG (someNodeId, PremIdx 0) (Fact tag (nMsgVars arity))++    someKUGoal :: LNTerm -> Goal+    someKUGoal m = ActionG someNodeId (kuFact m)++    someNodeId = LVar "i" LSortNode 0++    -- FIXME: Also use facts from proof context.+    rules = get pcRules ctxt+    absProtoFacts = sortednub $ do+        ru <- joinAllRules rules+        fa <- absFact <$> (getProtoFact =<< (get rConcs ru ++ get rPrems ru))+        -- exclude facts handled specially by the prover+        guard (not $ fst fa `elem` [OutFact, InFact, FreshFact])+        return fa++    absMsgFacts :: [LNTerm]+    absMsgFacts = asum $ sortednub $+      [ do return $ lit $ Var (LVar "t" LSortFresh 1)++      , [ fAppNonAC (s,k) $ nMsgVars k+        | (s,k) <- S.toList . allFunctionSymbols  . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt+        , (s,k) `S.notMember` implicitFunSig, k > 0 ]+      ]++-- | Refine a set of case distinction by exploiting additional typing+-- assumptions.+refineWithTypingAsms+    :: [LNGuarded]        -- ^ Typing assumptions to use.+    -> ProofContext       -- ^ Proof context to use.+    -> [CaseDistinction]  -- ^ Original, untyped case distinctions.+    -> [CaseDistinction]  -- ^ Refined, typed case distinctions.+refineWithTypingAsms assumptions ctxt cases0 =+    fmap (modifySystems removeFormulas) $+    saturateCaseDistinctions ctxt $+    modifySystems updateSystem <$> cases0+  where+    modifySystems   = modify cdCases . fmap . second+    updateSystem se =+        modify sFormulas (S.union (S.fromList assumptions)) $+        set sCaseDistKind TypedCaseDist                     $ se+    removeFormulas =+        modify sGoals (M.filterWithKey isNoDisjGoal)+      . set sFormulas S.empty+      . set sSolvedFormulas S.empty++    isNoDisjGoal (DisjG _)  _ = False+    isNoDisjGoal _          _ = True+++
+ src/Theory/Constraint/Solver/Contradictions.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns    #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- This is the public interface for constructing and deconstructing constraint+-- systems. The interface for performing constraint solving provided by+-- "Theory.Constraint.Solver".+module Theory.Constraint.Solver.Contradictions (++  -- * Contradictory constraint systems+    Contradiction(..)+  , substCreatesNonNormalTerms+  , contradictions+  , contradictorySystem++  -- ** Pretty-printing+  , prettyContradiction++  ) where++import           Prelude                        hiding (id, (.))++import           Data.Binary+import qualified Data.DAG.Simple                as D (cyclic, reachableSet)+import           Data.DeriveTH+import qualified Data.Foldable                  as F+import           Data.List+import qualified Data.Map                       as M+import           Data.Maybe                     (fromMaybe)+import           Data.Monoid+import qualified Data.Set                       as S+import           Safe                           (headMay)++import           Control.Basics+import           Control.Category+import           Control.DeepSeq+import           Control.Monad.Reader++import qualified Extension.Data.Label           as L+import           Extension.Prelude++import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty++import           Term.Rewriting.Norm            (maybeNotNfSubterms, nf')+++------------------------------------------------------------------------------+-- Contradictions+------------------------------------------------------------------------------++-- | Reasons why a constraint 'System' can be contradictory.+data Contradiction =+    Cyclic                         -- ^ The paths are cyclic.+  | NonNormalTerms                 -- ^ Has terms that are not in normal form.+  -- | NonLastNode                    -- ^ Has a non-silent node after the last node.+  | ForbiddenExp                   -- ^ Forbidden Exp-down rule instance+  | NonInjectiveFactInstance (NodeId, NodeId, NodeId)+    -- ^ Contradicts that certain facts have unique instances.+  | IncompatibleEqs                -- ^ Incompatible equalities.+  | FormulasFalse                  -- ^ False in formulas+  | SuperfluousLearn LNTerm NodeId -- ^ A term is derived both before and after a learn+  | NodeAfterLast (NodeId, NodeId) -- ^ There is a node after the last node.+  deriving( Eq, Ord, Show )+++-- | 'True' if the constraint system is contradictory.+contradictorySystem :: ProofContext -> System -> Bool+contradictorySystem ctxt = not . null . contradictions ctxt++-- | All CR-rules reducing a constraint system to *⟂* represented as a list of+-- trivial contradictions. Note that some constraint systems are also removed+-- because they have no unifier. This is part of unification. Note also that+-- *S_{¬,\@}* is handled as part of *S_∀*.+contradictions :: ProofContext -> System -> [Contradiction]+contradictions ctxt sys = F.asum+    -- CR-rule **+    [ guard (D.cyclic $ rawLessRel sys)             *> pure Cyclic+    -- CR-rule *N1*+    , guard (hasNonNormalTerms sig sys)             *> pure NonNormalTerms+    -- CR-rule *N7*+    , guard (hasForbiddenExp sys)                   *> pure ForbiddenExp+    -- CR-rules *S_≐* and *S_≈* are implemented via the equation store+    , guard (eqsIsFalse $ L.get sEqStore sys)       *> pure IncompatibleEqs+    -- CR-rules *S_⟂*, *S_{¬,last,1}*, *S_{¬,≐}*, *S_{¬,≈}*+    , guard (S.member gfalse $ L.get sFormulas sys) *> pure FormulasFalse+    ]+    +++    -- This rule is not yet documented. It removes constraint systems that+    -- require a unique fact to be present in the system state more than once.+    -- Unique facts are declared as part of the specification of the rule+    -- system.+    (NonInjectiveFactInstance <$> nonInjectiveFactInstances ctxt sys)+    +++    -- TODO: Document corresponding constratint reduction rule.+    (NodeAfterLast <$> nodesAfterLast sys)+  where+    sig = L.get pcSignature ctxt++-- | True iff there are terms in the node constraints that are not in normal form wrt.+-- to 'Term.Rewriting.Norm.norm' (DH/AC).+hasNonNormalTerms :: SignatureWithMaude -> System -> Bool+hasNonNormalTerms sig se =+    any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se)+  where hnd = L.get sigmMaudeHandle sig++-- | Returns all (sub)terms of node constraints that may be not in normal form.+maybeNonNormalTerms :: MaudeHandle -> System -> [LNTerm]+maybeNonNormalTerms hnd se =+    sortednub . concatMap getTerms . M.elems . L.get sNodes $ se+  where getTerms (Rule _ ps cs as) = do+          f <- ps++cs++as+          t <- factTerms f+          maybeNotNfSubterms (mhMaudeSig hnd) t++substCreatesNonNormalTerms :: MaudeHandle -> System -> LNSubstVFresh -> Bool+substCreatesNonNormalTerms hnd se =+    \subst -> any (not . nfApply subst) terms+  where terms = maybeNonNormalTerms hnd se+        nfApply subst0 t = t == t'  || nf' t' `runReader` hnd+          where tvars = freesList t+                subst = restrictVFresh tvars subst0+                t'  = apply (freshToFreeAvoidingFast subst tvars) t++-- | True if there is no @EXP-down@ rule that should be replaced by an+-- @EXP-up@ rule.+hasForbiddenExp :: System -> Bool+hasForbiddenExp se =+    any (isForbiddenExp) $ M.elems $ L.get sNodes se++-- | @isForbiddenExp ru@ returns @True@ if @ru@ is not allowed in+-- a normal dependency graph.+--+-- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]+-- >                         [Fact KDFact [expTagToTerm IsExp, Exp p1 (Mult x2 x3)]] [])+-- > False+-- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]+-- >                         [Fact KDFact [expTagToTerm IsExp, Exp p1 x2]] [])+-- > True+--+isForbiddenExp :: Rule a -> Bool+isForbiddenExp ru = fromMaybe False $ do+    [p1,p2] <- return $ L.get rPrems ru+    [conc]  <- return $ L.get rConcs ru+    (DnK, viewTerm2 -> FExp _ _) <- kFactView p1+    (UpK, b                    ) <- kFactView p2+    (DnK, viewTerm2 -> FExp g c) <- kFactView conc++    -- For a forbidden exp the following conditions must hold: g must be of+    -- sort 'pub' and the required inputs for c are already required by b+    return $    sortOfLNTerm g == LSortPub+             && (inputTerms c \\ inputTerms b == [])+  where+    -- The required components to construct the message.+    inputTerms :: LNTerm -> [LNTerm]+    inputTerms (viewTerm2 -> FMult ts)    = concatMap inputTerms ts+    inputTerms (viewTerm2 -> FInv t1)     = inputTerms t1+    inputTerms (viewTerm2 -> FPair t1 t2) = inputTerms t1 ++ inputTerms t2+    inputTerms t                          = [t]++-- | Compute all contradictions to injective fact instances.+--+-- Formally, they are computed as follows. Let 'f' be a fact symbol with+-- injective instances. Let i, j, and k be temporal variables ordered+-- according to+--+--   i < j < k+--+-- and let there be an edge from (i,u) to (k,w) for some indices u and v+--+-- Then, we have a contradiction if both the premise (k,w) that requires a+-- fact 'f(t,...)' and there is a premise (j,v) requiring a fact 'f(t,...)'.+--+-- These two premises would have to be merged, but cannot due to the ordering+-- constraint 'j < k'.+nonInjectiveFactInstances :: ProofContext -> System -> [(NodeId, NodeId, NodeId)]+nonInjectiveFactInstances ctxt se = do+    Edge c@(i, _) (k, _) <- S.toList $ L.get sEdges se+    let kFaPrem            = nodeConcFact c se+        kTag               = factTag kFaPrem+        kTerm              = firstTerm kFaPrem+        conflictingFact fa = factTag fa == kTag && firstTerm fa == kTerm++    guard (kTag `S.member` L.get pcInjectiveFactInsts ctxt)+    j <- S.toList $ D.reachableSet [i] less++    let isCounterExample = (j /= i) && (j /= k) &&+                           maybe False checkRule (M.lookup j $ L.get sNodes se)++        -- FIXME: There should be a weaker version of the rule that just+        -- introduces the constraint 'k < j || k == j' here.+        checkRule jRu    = any conflictingFact (L.get rPrems jRu) &&+                           k `S.member` D.reachableSet [j] less++    guard isCounterExample+    return (i, j, k) -- counter-example to unique fact instances+  where+    less      = rawLessRel se+    firstTerm = headMay . factTerms++-- | The node-ids that must be instantiated to the trace, but are temporally+-- after the last node.+nodesAfterLast :: System -> [(NodeId, NodeId)]+nodesAfterLast sys = case L.get sLastAtom sys of+  Nothing -> []+  Just i  -> do j <- S.toList $ D.reachableSet [i] $ rawLessRel sys+                guard (j /= i && isInTrace sys j)+                return (i, j)+++-- | Pretty-print a 'Contradiction'.+prettyContradiction :: Document d => Contradiction -> d+prettyContradiction contra = case contra of+    Cyclic                       -> text "cyclic"+    IncompatibleEqs              -> text "incompatible equalities"+    NonNormalTerms               -> text "non-normal terms"+    ForbiddenExp                 -> text "non-normal exponentiation instance"+    NonInjectiveFactInstance cex -> text $ "non-injective facts " ++ show cex+    FormulasFalse                -> text "from formulas"+    SuperfluousLearn m v         ->+        doubleQuotes (prettyLNTerm m) <->+        text ("derived before and after") <->+        doubleQuotes (prettyNodeId v)+    NodeAfterLast (i,j)       ->+        text $ "node " ++ show j ++ " after last node " ++ show i+++-- Instances+------------++instance HasFrees Contradiction where+  foldFrees f (SuperfluousLearn t v)       = foldFrees f t `mappend` foldFrees f v+  foldFrees f (NonInjectiveFactInstance x) = foldFrees f x+  foldFrees f (NodeAfterLast x)            = foldFrees f x+  foldFrees _ _                            = mempty++  mapFrees f (SuperfluousLearn t v)       = SuperfluousLearn <$> mapFrees f t <*> mapFrees f v+  mapFrees f (NonInjectiveFactInstance x) = NonInjectiveFactInstance <$> mapFrees f x+  mapFrees f (NodeAfterLast x)            = NodeAfterLast <$> mapFrees f x+  mapFrees _ c                            = pure c++$( derive makeBinary ''Contradiction)+$( derive makeNFData ''Contradiction)
+ src/Theory/Constraint/Solver/Goals.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns  #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- The constraint reduction rules, which are not enforced as invariants in+-- "Theory.Constraint.Solver.Reduction".+--+-- A goal represents a possible application of a rule that may result in+-- multiple cases or even non-termination (if applied repeatedly). These goals+-- are computed as the list of 'openGoals'. See+-- "Theory.Constraint.Solver.ProofMethod" for the public interface to solving+-- goals and the implementation of heuristics.+module Theory.Constraint.Solver.Goals (+    Usefulness(..)+  , AnnotatedGoal+  , openGoals+  , solveGoal+  ) where++import           Prelude                                 hiding (id, (.))++import qualified Data.DAG.Simple                         as D (cyclic)+import           Data.Foldable                           (foldMap)+import qualified Data.Map                                as M+import qualified Data.Monoid                             as Mono+import qualified Data.Set                                as S++import           Control.Basics+import           Control.Category+import           Control.Monad.Disj+import           Control.Monad.State                     (gets)++import           Extension.Data.Label++import           Theory.Constraint.Solver.Contradictions (substCreatesNonNormalTerms)+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++------------------------------------------------------------------------------+-- Extracting Goals+------------------------------------------------------------------------------++data Usefulness =+    Useful+  -- ^ A goal that is likely to result in progress.+  | LoopBreaker+  -- ^ A goal that is delayed to avoid immediate termination.+  | ProbablyConstructible+  -- ^ A goal that is likely to be constructible by the adversary.+  | CurrentlyDeducible+  -- ^ A message that is deducible for the current solution.+  deriving (Show, Eq, Ord)++-- | Goals annotated with their number and usefulness.+type AnnotatedGoal = (Goal, (Integer, Usefulness))+++-- Instances+------------++-- | The list of goals that must be solved before a solution can be extracted.+-- Each goal is annotated with its age and an indicator for its usefulness.+openGoals :: System -> [AnnotatedGoal]+openGoals sys = do+    (goal, status) <- M.toList $ get sGoals sys+    let solved = get gsSolved status+    -- check whether the goal is still open+    guard $ case goal of+        ActionG _ (kFactView -> Just (UpK, m)) ->+          not $    solved+                || isMsgVar m || sortOfLNTerm m == LSortPub+                -- handled by 'insertAction'+                || isPair m || isInverse m || isProduct m+                || isNullaryFunction m+        ActionG _ _                               -> not solved+        PremiseG _ _                              -> not solved+        -- Technically the 'False' disj would be a solvable goal. However, we+        -- have a separate proof method for this, i.e., contradictions.+        DisjG (Disj [])                           -> False+        DisjG _                                   -> not solved++        ChainG c _     ->+          case kFactView (nodeConcFact c sys) of+              Just (DnK,  m) | isMsgVar m -> False+                             | otherwise  -> not solved+              fa -> error $ "openChainGoals: impossible fact: " ++ show fa++        -- FIXME: Split goals may be duplicated, we always have to check+        -- explicitly if they still exist.+        SplitG idx -> splitExists (get sEqStore sys) idx++    let+        useful = case goal of+          _ | get gsLoopBreaker status              -> LoopBreaker+          ActionG i (kFactView -> Just (UpK, m))+              -- if there are KU-guards then all knowledge goals are useful+            | hasKUGuards             -> Useful+            | currentlyDeducible i m  -> CurrentlyDeducible+            | probablyConstructible m -> ProbablyConstructible+          _                           -> Useful++    return (goal, (get gsNr status, useful))+  where+    existingDeps = rawLessRel sys+    hasKUGuards  =+        any ((KUFact `elem`) . guardFactTags) $ S.toList $ get sFormulas sys++    checkTermLits :: (LSort -> Bool) -> LNTerm -> Bool+    checkTermLits p =+        Mono.getAll . foldMap (Mono.All . p . sortOfLit)+      where+        sortOfLit (Con n) = sortOfName n+        sortOfLit (Var v) = lvarSort v++    -- KU goals of messages that are likely to be constructible by the+    -- adversary. These are terms that do not contain a fresh name or a fresh+    -- name variable. For protocols without loops they are very likely to be+    -- constructible. For protocols with loops, such terms have to be given+    -- similar priority as loop-breakers.+    probablyConstructible  = checkTermLits (LSortFresh /=)++    -- KU goals of messages that are currently deducible. Either because they+    -- are composed of public names only or because they can be extracted from+    -- a sent message using unpairing or inversion only.+    currentlyDeducible i m = checkTermLits (LSortPub ==) m || extractible i m++    extractible i m = or $ do+        (j, ru) <- M.toList $ get sNodes sys+        -- We cannot deduce a message from a last node.+        guard (not $ isLast sys j)+        let derivedMsgs = concatMap toplevelTerms $+                [ t | Fact OutFact [t] <- get rConcs ru] <|>+                [ t | Just (DnK, t)    <- kFactView <$> get rConcs ru]+        -- m is deducible from j without an immediate contradiction+        -- if it is a derived message of 'ru' and the dependency does+        -- not make the graph cyclic.+        return $ m `elem` derivedMsgs &&+                 not (D.cyclic ((j, i) : existingDeps))++    toplevelTerms t@(destPair -> Just (t1, t2)) =+        t : toplevelTerms t1 ++ toplevelTerms t2+    toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1+    toplevelTerms t = [t]+++++------------------------------------------------------------------------------+-- Solving 'Goal's+------------------------------------------------------------------------------++-- | @solveGoal rules goal@ enumerates all possible cases of how this goal+-- could be solved in the context of the given @rules@. For each case, a+-- sensible case-name is returned.+solveGoal :: Goal -> Reduction String+solveGoal goal = do+    -- mark before solving, as representation might change due to unification+    markGoalAsSolved "directly" goal+    rules <- askM pcRules+    case goal of+      ActionG i fa  -> solveAction  (nonSilentRules rules) (i, fa)+      PremiseG p fa ->+           solvePremise (get crProtocol rules ++ get crConstruct rules) p fa+      ChainG c p    -> solveChain (get crDestruct  rules) (c, p)+      SplitG i      -> solveSplit i+      DisjG disj    -> solveDisjunction disj++-- The follwoing functions are internal to 'solveGoal'. Use them with great+-- care.++-- | CR-rule *S_at*: solve an action goal.+solveAction :: [RuleAC]          -- ^ All rules labelled with an action+            -> (NodeId, LNFact)  -- ^ The action we are looking for.+            -> Reduction String  -- ^ A sensible case name.+solveAction rules (i, fa) = do+    mayRu <- M.lookup i <$> getM sNodes+    showRuleCaseName <$> case mayRu of+        Nothing -> do ru  <- labelNodeId i rules+                      act <- disjunctionOfList $ get rActs ru+                      void (solveFactEqs SplitNow [Equal fa act])+                      return ru++        Just ru -> do unless (fa `elem` get rActs ru) $ do+                          act <- disjunctionOfList $ get rActs ru+                          void (solveFactEqs SplitNow [Equal fa act])+                      return ru++-- | CR-rules *DG_{2,P}* and *DG_{2,d}*: solve a premise with a direct edge+-- from a unifying conclusion or using a destruction chain.+--+-- Note that *In*, *Fr*, and *KU* facts are solved directly when adding a+-- 'ruleNode'.+--+solvePremise :: [RuleAC]       -- ^ All rules with a non-K-fact conclusion.+             -> NodePrem       -- ^ Premise to solve.+             -> LNFact         -- ^ Fact required at this premise.+             -> Reduction String -- ^ Case name to use.+solvePremise rules p faPrem+  | isKDFact faPrem = do+      iLearn    <- freshLVar "vl" LSortNode+      mLearn    <- varTerm <$> freshLVar "t" LSortMsg+      let concLearn = kdFact mLearn+          premLearn = outFact mLearn+          -- !! Make sure that you construct the correct rule!+          ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] []+          cLearn = (iLearn, ConcIdx 0)+          pLearn = (iLearn, PremIdx 0)+      modM sNodes  (M.insert iLearn ruLearn)+      insertChain cLearn p+      solvePremise rules pLearn premLearn++  | otherwise = do+      (ru, c, faConc) <- insertFreshNodeConc rules+      insertEdges [(c, faConc, faPrem, p)]+      return $ showRuleCaseName ru++-- | CR-rule *DG2_chain*: solve a chain constraint.+solveChain :: [RuleAC]              -- ^ All destruction rules.+           -> (NodeConc, NodePrem)  -- ^ The chain to extend by one step.+           -> Reduction String      -- ^ Case name to use.+solveChain rules (c, p) = do+    faConc  <- gets $ nodeConcFact c+    (do -- solve it by a direct edge+        faPrem <- gets $ nodePremFact p+        insertEdges [(c, faConc, faPrem, p)]+        let m = case kFactView faConc of+                  Just (DnK, m') -> m'+                  _              -> error $ "solveChain: impossible"+            caseName (viewTerm -> FApp o _) = showFunSymName o+            caseName t                      = show t+        return $ caseName m+     `disjunction`+     do -- extend it with one step+        cRule <- gets $ nodeRule (nodeConcNode c)+        (i, ru)     <- insertFreshNode rules+        -- contradicts normal form condition:+        -- no edge from dexp to dexp KD premise+        -- (this condition replaces the exp/noexp tags)+        contradictoryIf (isDexpRule cRule && isDexpRule ru)+        (v, faPrem) <- disjunctionOfList $ enumPrems ru+        insertEdges [(c, faConc, faPrem, (i, v))]+        markGoalAsSolved "directly" (PremiseG (i, v) faPrem)+        insertChain (i, ConcIdx 0) p+        return $ showRuleCaseName ru+     )+  where+    isDexpRule ru = case get rInfo ru of+        IntrInfo (DestrRule n) | n == expSymString -> True+        _                                          -> False++-- | Solve an equation split. There is no corresponding CR-rule in the rule+-- system on paper because there we eagerly split over all variants of a rule.+-- In practice, this is too expensive and we therefore use the equation store+-- to delay these splits.+solveSplit :: SplitId -> Reduction String+solveSplit x = do+    split <- gets ((`performSplit` x) . get sEqStore)+    let errMsg = error "solveSplit: inexistent split-id"+    store      <- maybe errMsg disjunctionOfList split+    -- FIXME: Simplify this interaction with the equation store+    hnd        <- getMaudeHandle+    substCheck <- gets (substCreatesNonNormalTerms hnd)+    store'     <- simp hnd substCheck store+    contradictoryIf (eqsIsFalse store')+    sEqStore =: store'+    return "split"++-- | CR-rule *S_disj*: solve a disjunction of guarded formulas using a case+-- distinction.+--+-- In contrast to the paper, we use n-ary disjunctions and also split over all+-- of them at once.+solveDisjunction :: Disj LNGuarded -> Reduction String+solveDisjunction disj = do+    (i, gfm) <- disjunctionOfList $ zip [(1::Int)..] $ getDisj disj+    insertFormula gfm+    return $ "case_" ++ show i+
+ src/Theory/Constraint/Solver/ProofMethod.hs view
@@ -0,0 +1,420 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ViewPatterns    #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Proof methods and heuristics: the external small-step interface to the+-- constraint solver.+module Theory.Constraint.Solver.ProofMethod (+  -- * Proof methods+    CaseName+  , ProofMethod(..)+  , execProofMethod++  -- ** Heuristics+  , GoalRanking(..)+  , goalRankingName+  , rankProofMethods++  , Heuristic+  , roundRobinHeuristic+  , useHeuristic++  -- ** Pretty Printing+  , prettyProofMethod++) where++import           Data.Binary+import           Data.DeriveTH+import           Data.Function                             (on)+import           Data.Label                                hiding (get)+import qualified Data.Label                                as L+import           Data.List+import qualified Data.Map                                  as M+import           Data.Monoid+import           Data.Ord                                  (comparing)+import qualified Data.Set                                  as S+import           Extension.Prelude                         (sortOn)++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.Bind+import qualified Control.Monad.Trans.PreciseFresh          as Precise++import           Theory.Constraint.Solver.CaseDistinctions+import           Theory.Constraint.Solver.Contradictions+import           Theory.Constraint.Solver.Goals+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Simplify+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------------++-- | @uniqueListBy eq changes xs@ zips the @changes@ with all sequences equal+-- elements in the list.+--+-- > uniqueListBy compare id (const [ (++ show i) | i <- [1..] ]) ["a","b","a"] =+-- > ["a1","b","a2"]+--+uniqueListBy :: (a -> a -> Ordering) -> (a -> a) -> (Int -> [a -> a]) -> [a] -> [a]+uniqueListBy ord single distinguish xs0 =+      map fst+    $ sortBy (comparing snd)+    $ concat $ map uniquify $ groupBy (\x y -> ord (fst x) (fst y) == EQ)+    $ sortBy (ord `on` fst)+    $ zip xs0 [(0::Int)..]+  where+    uniquify []      = error "impossible"+    uniquify [(x,i)] = [(single x, i)]+    uniquify xs      = zipWith (\f (x,i) -> (f x, i)) dist xs+      where+        dist = distinguish $ length xs+++------------------------------------------------------------------------------+-- Proof Methods+------------------------------------------------------------------------------++-- | Every case in a proof is uniquely named.+type CaseName = String++-- | Sound transformations of sequents.+data ProofMethod =+    Sorry (Maybe String)                 -- ^ Proof was not completed+  | Solved                               -- ^ An attack was fond+  | Simplify                             -- ^ A simplification step.+  | SolveGoal Goal                       -- ^ A goal that was solved.+  | Contradiction (Maybe Contradiction)  -- ^ A contradiction could be+                                         -- derived, possibly with a reason.+  | Induction                            -- ^ Use inductive strengthening on+                                         -- the single formula constraint in+                                         -- the system.+  deriving( Eq, Ord, Show )++instance HasFrees ProofMethod where+    foldFrees f (SolveGoal g)     = foldFrees f g+    foldFrees f (Contradiction c) = foldFrees f c+    foldFrees _ _                 = mempty++    mapFrees f (SolveGoal g)     = SolveGoal <$> mapFrees f g+    mapFrees f (Contradiction c) = Contradiction <$> mapFrees f c+    mapFrees _ method            = pure method+++-- Proof method execution+-------------------------+++-- @execMethod rules method se@ checks first if the @method@ is applicable to+-- the sequent @se@. Then, it applies the @method@ to the sequent under the+-- assumption that the @rules@ describe all rewriting rules in scope.+--+-- NOTE that the returned systems have their free substitution fully applied+-- and all variable indices reset.+execProofMethod :: ProofContext+                -> ProofMethod -> System -> Maybe (M.Map CaseName System)+execProofMethod ctxt method sys =+    M.map cleanupSystem <$>+      case method of+        Sorry _                  -> return M.empty+        Solved+          | null (openGoals sys) -> return M.empty+          | otherwise            -> Nothing+        SolveGoal goal+          | goal `M.member` L.get sGoals sys -> execSolveGoal goal+          | otherwise                      -> Nothing+        Simplify                 -> singleCase (/=) simplifySystem+        Induction                -> execInduction+        Contradiction _+          | null (contradictions ctxt sys) -> Nothing+          | otherwise                      -> Just M.empty+  where+    -- at this point it is safe to remove the free substitution, as all+    -- systems have it fully applied (by the virtue of a call to+    -- simplifySystem). We also reset the variable indices here.+    cleanupSystem =+         (`Precise.evalFresh` Precise.nothingUsed)+       . (`evalBindT` noBindings)+       . someInst+       . set sSubst emptySubst+++    -- expect only one or no subcase in the given case distinction+    singleCase check m =+        case map fst $ getDisj $ execReduction m ctxt sys (avoid sys) of+          []                      -> return $ M.empty+          [sys'] | check sys sys' -> return $ M.singleton "" sys'+                 | otherwise      -> mzero+          syss                    ->+               return $ M.fromList (zip (map show [(1::Int)..]) syss)++    -- solve the given goal+    -- PRE: Goal must be valid in this system.+    execSolveGoal goal = do+        return $ makeCaseNames $ map fst $ getDisj $+            runReduction solver ctxt sys (avoid sys)+      where+        ths    = L.get pcCaseDists ctxt+        solver = do name <- maybe (solveGoal goal)+                                  (fmap $ concat . intersperse "_")+                                  (solveWithCaseDistinction ctxt ths goal)+                    simplifySystem+                    return name++        makeCaseNames =+            M.fromListWith (error "case names not unique")+          . uniqueListBy (comparing fst) id distinguish+          where+            distinguish n =+                [ (\(x,y) -> (x ++ "_case_" ++ pad (show i), y))+                | i <- [(1::Int)..] ]+              where+                l      = length (show n)+                pad cs = replicate (l - length cs) '0' ++ cs++    -- Apply induction: possible if the system contains only+    -- a single, last-free, closed formula.+    execInduction+      | sys == sys0 =+          case S.toList $ L.get sFormulas sys of+            [gf] -> case ginduct gf of+                      Right (bc, sc) -> Just $ insCase "empty_trace"     bc+                                             $ insCase "non_empty_trace" sc+                                             $ M.empty+                      _              -> Nothing+            _    -> Nothing++      | otherwise = Nothing+      where+        sys0 = set sFormulas (L.get sFormulas sys)+             $ set sLemmas (L.get sLemmas sys)+             $ emptySystem (L.get sCaseDistKind sys)++        insCase name gf = M.insert name (set sFormulas (S.singleton gf) sys)++------------------------------------------------------------------------------+-- Heuristics+------------------------------------------------------------------------------++-- | The different available functions to rank goals with respect to their+-- order of solving in a constraint system.+data GoalRanking =+    GoalNrRanking+  | UsefulGoalNrRanking+  | SmartRanking Bool+  deriving( Eq, Ord, Show )++-- | The name/explanation of a 'GoalRanking'.+goalRankingName :: GoalRanking -> String+goalRankingName ranking =+    "Goals sorted according to " ++ case ranking of+        GoalNrRanking                -> "their order of creation"+        UsefulGoalNrRanking          -> "their usefulness and order of creation"+        SmartRanking useLoopBreakers -> smart useLoopBreakers+   where+     smart b = "the 'smart' heuristic (loop breakers " +++               (if b then "allowed" else "delayed") ++ ")."++-- | Use a 'GoalRanking' to sort a list of 'AnnotatedGoal's stemming from the+-- given constraint 'System'.+rankGoals :: GoalRanking -> System -> [AnnotatedGoal] -> [AnnotatedGoal]+rankGoals ranking = case ranking of+    GoalNrRanking       -> \_sys -> goalNrRanking+    UsefulGoalNrRanking ->+        \_sys -> sortOn (\(_, (nr, useless)) -> (useless, nr))+    SmartRanking useLoopsBreakers -> smartRanking useLoopsBreakers++-- | Use a 'GoalRanking' to generate the ranked, list of possible+-- 'ProofMethod's and their corresponding results in this 'ProofContext' and+-- for this 'System'. If the resulting list is empty, then the constraint+-- system is solved.+rankProofMethods :: GoalRanking -> ProofContext -> System+                 -> [(ProofMethod, (M.Map CaseName System, String))]+rankProofMethods ranking ctxt sys = do+    (m, expl) <-+            (contradiction <$> contradictions ctxt sys)+        <|> (case L.get pcUseInduction ctxt of+               AvoidInduction -> [(Simplify, ""), (Induction, "")]+               UseInduction   -> [(Induction, ""), (Simplify, "")]+            )+        <|> (solveGoalMethod <$> (rankGoals ranking sys $ openGoals sys))+    case execProofMethod ctxt m sys of+      Just cases -> return (m, (cases, expl))+      Nothing    -> []+  where+    contradiction c                    = (Contradiction (Just c), "")+    solveGoalMethod (goal, (nr, usefulness)) =+      ( SolveGoal goal+      , "nr. " ++ show nr ++ case usefulness of+                               Useful                -> ""+                               LoopBreaker           -> " (loop breaker)"+                               ProbablyConstructible -> " (probably constructible)"+                               CurrentlyDeducible    -> " (currently deducible)"+      )++newtype Heuristic = Heuristic [GoalRanking]+    deriving( Eq, Ord, Show )++-- | Smart constructor for heuristics. Schedules the goal rankings in a+-- round-robin fashion dependent on the proof depth.+roundRobinHeuristic :: [GoalRanking] -> Heuristic+roundRobinHeuristic = Heuristic++-- | Use a heuristic to schedule a 'GoalRanking' according to the given+-- proof-depth.+useHeuristic :: Heuristic -> Int -> GoalRanking+useHeuristic (Heuristic []      ) = error "useHeuristic: empty list of rankings"+useHeuristic (Heuristic rankings) =+    ranking+  where+    n = length rankings++    ranking depth+      | depth < 0 = error $ "useHeuristic: negative proof depth " ++ show depth+      | otherwise = rankings !! (depth `mod` n)++++{-+-- | Schedule the given local-heuristics in a round-robin fashion.+roundRobinHeuristic :: [GoalRanking] -> Heuristic+roundRobinHeuristic []       = error "roundRobin: empty list of rankings"+roundRobinHeuristic rankings =+    methods+  where+    n = length rankings++    methods depth ctxt sys+      | depth < 0 = error $ "roundRobin: negative proof depth " ++ show depth+      | otherwise =+          ( name+          ,     ((Contradiction . Just) <$> contradictions ctxt sys)+            <|> (case L.get pcUseInduction ctxt of+                   AvoidInduction -> [Simplify, Induction]+                   UseInduction   -> [Induction, Simplify]+                )+            <|> ((SolveGoal . fst) <$> (ranking sys $ openGoals sys))+          )+      where+        (name, ranking) = rankings !! (depth `mod` n)+-}++-- | Sort annotated goals according to their number.+goalNrRanking :: [AnnotatedGoal] -> [AnnotatedGoal]+goalNrRanking = sortOn (fst . snd)++-- | A ranking function tuned for the automatic verification of+-- classical security protocols that exhibit a well-founded protocol premise+-- fact flow.+smartRanking :: Bool   -- True if PremiseG loop-breakers should not be delayed+             -> System+             -> [AnnotatedGoal] -> [AnnotatedGoal]+smartRanking allowPremiseGLoopBreakers sys =+    sortOnUsefulness . unmark . sortDecisionTree solveFirst . goalNrRanking+  where+    sortOnUsefulness = sortOn (tagUsefulness . snd . snd)++    tagUsefulness Useful                = 0 :: Int+    tagUsefulness ProbablyConstructible = 1+    tagUsefulness LoopBreaker           = 1+    tagUsefulness CurrentlyDeducible    = 2++    unmark | allowPremiseGLoopBreakers = map unmarkPremiseG+           | otherwise                 = id++    unmarkPremiseG (goal@(PremiseG _ _), (nr, _)) = (goal, (nr, Useful))+    unmarkPremiseG annGoal                        = annGoal++    solveFirst =+        [ isChainGoal . fst+        , isDisjGoal . fst+        , isNonLoopBreakerProtoFactGoal+        , isStandardActionGoal . fst+        , isFreshKnowsGoal . fst+        , isSplitGoalSmall . fst+        , isDoubleExpGoal . fst+        , isNoLargeSplitGoal . fst ]+        -- move the rest (mostly more expensive KU-goals) before expensive+        -- equation splits++    -- FIXME: This small split goal preferral is quite hacky when using+    -- induction. The problem is that we may end up solving message premise+    -- goals all the time instead performing a necessary split. We should make+    -- sure that a split does not get too old.+    smallSplitGoalSize = 3++    isNonLoopBreakerProtoFactGoal (PremiseG _ fa, (_, Useful)) = not $ isKFact fa+    isNonLoopBreakerProtoFactGoal _                            = False++    msgPremise (ActionG _ fa) = do (UpK, m) <- kFactView fa; return m+    msgPremise _              = Nothing++    isFreshKnowsGoal goal = case msgPremise goal of+        Just (viewTerm -> Lit (Var lv)) | lvarSort lv == LSortFresh -> True+        _                                                           -> False++    isDoubleExpGoal goal = case msgPremise goal of+        Just (viewTerm2 -> FExp  _ (viewTerm2 -> FMult _)) -> True+        _                                                  -> False++    -- Be conservative on splits that don't exist.+    isSplitGoalSmall (SplitG sid) =+        maybe False (<= smallSplitGoalSize) $ splitSize (L.get sEqStore sys) sid+    isSplitGoalSmall _            = False++    isNoLargeSplitGoal goal@(SplitG _) = isSplitGoalSmall goal+    isNoLargeSplitGoal _               = True++    -- | @sortDecisionTree xs ps@ returns a reordering of @xs@+    -- such that the sublist satisfying @ps!!0@ occurs first,+    -- then the sublist satisfying @ps!!1@, and so on.+    sortDecisionTree :: [a -> Bool] -> [a] -> [a]+    sortDecisionTree []     xs = xs+    sortDecisionTree (p:ps) xs = sat ++ sortDecisionTree ps nonsat+      where (sat, nonsat) = partition p xs++++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty-print a proof method.+prettyProofMethod :: HighlightDocument d => ProofMethod -> d+prettyProofMethod method = case method of+    Solved               -> keyword_ "SOLVED" <-> lineComment_ "trace found"+    Induction            -> keyword_ "induction"+    Sorry reason         ->+        fsep [keyword_ "sorry", maybe emptyDoc lineComment_ reason]+    SolveGoal goal       ->+        keyword_ "solve(" <-> prettyGoal goal <-> keyword_ ")"+    Simplify             -> keyword_ "simplify"+    Contradiction reason ->+        sep [ keyword_ "contradiction"+            , maybe emptyDoc (lineComment . prettyContradiction) reason+            ]++++-- Derived instances+--------------------++$( derive makeBinary ''ProofMethod)+$( derive makeBinary ''GoalRanking)+$( derive makeBinary ''Heuristic)++$( derive makeNFData ''ProofMethod)+$( derive makeNFData ''GoalRanking)+$( derive makeNFData ''Heuristic)
+ src/Theory/Constraint/Solver/Reduction.hs view
@@ -0,0 +1,665 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns  #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- A monad for writing constraint reduction steps together with basic steps+-- for inserting nodes, edges, actions, and equations and applying+-- substitutions.+module Theory.Constraint.Solver.Reduction (+  -- * The constraint 'Reduction' monad+    Reduction+  , execReduction+  , runReduction++  -- ** Change management+  , ChangeIndicator(..)+  , whenChanged+  , applyChangeList+  , whileChanging++  -- ** Accessing the 'ProofContext'+  , getProofContext+  , getMaudeHandle++  -- ** Inserting nodes, edges, and atoms+  , labelNodeId+  , insertFreshNode+  , insertFreshNodeConc++  , insertGoal+  , insertAtom+  , insertEdges+  , insertChain+  , insertAction+  , insertLess+  , insertFormula+  , reducibleFormula++  -- ** Goal management+  , markGoalAsSolved+  , removeSolvedSplitGoals++  -- ** Substitution application+  , substSystem+  , substNodes+  , substEdges+  , substLastAtom+  , substLessAtoms+  , substFormulas+  , substSolvedFormulas++  -- ** Solving equalities+  , SplitStrategy(..)++  , solveNodeIdEqs+  , solveTermEqs+  , solveFactEqs+  , solveRuleEqs+  , solveSubstEqs++  -- ** Conjunction with another constraint 'System'+  , conjoinSystem++  -- ** Convenience export+  , module Logic.Connectives++  ) where++import           Debug.Trace+import           Prelude                                 hiding (id, (.))++import qualified Data.Foldable                           as F+import qualified Data.Map                                as M+import qualified Data.Set                                as S+import           Data.List                               (mapAccumL)+import           Safe++import           Control.Basics+import           Control.Category+import           Control.Monad.Bind+import           Control.Monad.Disj+import           Control.Monad.Reader+import           Control.Monad.State                     (StateT, execStateT, gets, runStateT)++import           Text.PrettyPrint.Class++import           Extension.Data.Label+import           Extension.Data.Monoid                   (Monoid(..))+import           Extension.Prelude++import           Logic.Connectives++import           Theory.Constraint.Solver.Contradictions+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++------------------------------------------------------------------------------+-- The constraint reduction monad+------------------------------------------------------------------------------++-- | A constraint reduction step. Its state is the current constraint system,+-- it can generate fresh names, split over cases, and access the proof+-- context.+type Reduction = StateT System (FreshT (DisjT (Reader ProofContext)))+++-- Executing reductions+-----------------------++-- | Run a constraint reduction. Returns a list of constraint systems whose+-- combined solutions are equal to the solutions of the given system. This+-- property is obviously not enforced, but it must be respected by all+-- functions of type 'Reduction'.+runReduction :: Reduction a -> ProofContext -> System -> FreshState+             -> Disj ((a, System), FreshState)+runReduction m ctxt se fs =+    Disj $ (`runReader` ctxt) $ runDisjT $ (`runFreshT` fs) $ runStateT m se++-- | Run a constraint reduction returning only the updated constraint systems+-- and the new freshness states.+execReduction :: Reduction a -> ProofContext -> System -> FreshState+              -> Disj (System, FreshState)+execReduction m ctxt se fs =+    Disj $ (`runReader` ctxt) . runDisjT . (`runFreshT` fs) $ execStateT m se+++-- Change management+--------------------++-- | Indicate whether the constraint system was changed or not.+data ChangeIndicator = Unchanged | Changed+       deriving( Eq, Ord, Show )++instance Monoid ChangeIndicator where+    mempty = Unchanged++    Changed   `mappend` _         = Changed+    _         `mappend` Changed   = Changed+    Unchanged `mappend` Unchanged = Unchanged++-- | Return 'True' iff there was a change.+wasChanged :: ChangeIndicator -> Bool+wasChanged Changed   = True+wasChanged Unchanged = False++-- | Only apply a monadic action, if there has been a change.+whenChanged :: Monad m => ChangeIndicator -> m () -> m ()+whenChanged = when . wasChanged++-- | Apply a list of changes to the proof state.+applyChangeList :: [Reduction ()] -> Reduction ChangeIndicator+applyChangeList []      = return Unchanged+applyChangeList changes = sequence_ changes >> return Changed++-- | Execute a 'Reduction' as long as it results in changes. Indicate whether+-- at least one change was performed.+whileChanging :: Reduction ChangeIndicator -> Reduction ChangeIndicator+whileChanging reduction =+    go Unchanged+  where+    go indicator = do indicator' <- reduction+                      case indicator' of+                          Unchanged -> return indicator+                          Changed   -> go     indicator'+++-- Accessing the proof context+------------------------------++-- | Retrieve the 'ProofContext'.+getProofContext :: Reduction ProofContext+getProofContext = ask++-- | Retrieve the 'MaudeHandle' from the 'ProofContext'.+getMaudeHandle :: Reduction MaudeHandle+getMaudeHandle = askM pcMaudeHandle+++-- Inserting (fresh) nodes into the constraint system+-----------------------------------------------------++-- | Insert a fresh rule node labelled with a fresh instance of one of the+-- rules and return one of the conclusions.+insertFreshNodeConc :: [RuleAC] -> Reduction (RuleACInst, NodeConc, LNFact)+insertFreshNodeConc rules = do+    (i, ru) <- insertFreshNode rules+    (v, fa) <- disjunctionOfList $ enumConcs ru+    return (ru, (i, v), fa)++-- | Insert a fresh rule node labelled with a fresh instance of one of the rules+-- and solve it's 'Fr', 'In', and 'KU' premises immediatly.+insertFreshNode :: [RuleAC] -> Reduction (NodeId, RuleACInst)+insertFreshNode rules = do+    i <- freshLVar "vr" LSortNode+    (,) i <$> labelNodeId i rules++-- | Label a node-id with a fresh instance of one of the rules and+-- solve it's 'Fr', 'In', and 'KU' premises immediatly.+--+-- PRE: Node must not yet be labelled with a rule.+labelNodeId :: NodeId -> [RuleAC] -> Reduction RuleACInst+labelNodeId = \i rules -> do+    (ru, mrconstrs) <- importRule =<< disjunctionOfList rules+    solveRuleConstraints mrconstrs+    modM sNodes (M.insert i ru)+    exploitPrems i ru+    return ru+  where+    -- | Import a rule with all its variables renamed to fresh variables.+    importRule ru = someRuleACInst ru `evalBindT` noBindings++    mkISendRuleAC m = return $ Rule (IntrInfo (ISendRule))+                                    [kuFact m] [inFact m] [kLogFact m]+++    mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule []))+                           [] [freshFact m] []++    exploitPrems i ru = mapM_ (exploitPrem i ru) (enumPrems ru)++    exploitPrem i ru (v, fa) = case fa of+        -- CR-rule *DG2_2* specialized for *In* facts.+        Fact InFact [m] -> do+            j <- freshLVar "vf" LSortNode+            ruKnows <- mkISendRuleAC m+            modM sNodes (M.insert j ruKnows)+            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v))+            exploitPrems j ruKnows++        -- CR-rule *DG2_2* specialized for *Fr* facts.+        Fact FreshFact [m] -> do+            j <- freshLVar "vf" LSortNode+            modM sNodes (M.insert j (mkFreshRuleAC m))+            unless (isFreshVar m) $ do+                -- 'm' must be of sort fresh ==> enforce via unification+                n <- varTerm <$> freshLVar "n" LSortFresh+                void (solveTermEqs SplitNow [Equal m n])+            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v))++          -- CR-rule *DG2_{2,u}*: solve a KU-premise by inserting the+          -- corresponding KU-actions before this node.+        _ | isKUFact fa -> do+              j <- freshLVar "vk" LSortNode+              insertLess j i+              void (insertAction j fa)++          -- Store premise goal for later processing using CR-rule *DG2_2*+          | otherwise -> insertGoal (PremiseG (i,v) fa) (v `elem` breakers)+      where+        breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru++-- | Insert a chain constrain.+insertChain :: NodeConc -> NodePrem -> Reduction ()+insertChain c p = insertGoal (ChainG c p) False++-- | Insert an edge constraint. CR-rule *DG1_2* is enforced automatically,+-- i.e., the fact equalities are enforced.+insertEdges :: [(NodeConc, LNFact, LNFact, NodePrem)] -> Reduction ()+insertEdges edges = do+    void (solveFactEqs SplitNow [ Equal fa1 fa2 | (_, fa1, fa2, _) <- edges ])+    modM sEdges (\es -> foldr S.insert es [ Edge c p | (c,_,_,p) <- edges])++-- | Insert an 'Action' atom. Ensures that (almost all) trivial *KU* actions+-- are solved immediately using rule *S_{at,u,triv}*. We currently avoid+-- adding intermediate products. Indicates whether nodes other than the given+-- action have been added to the constraint system.+--+-- FIXME: Ensure that intermediate products are also solved before stating+-- that no rule is applicable.+insertAction :: NodeId -> LNFact -> Reduction ChangeIndicator+insertAction i fa = do+    present <- (goal `M.member`) <$> getM sGoals+    if present+      then do return Unchanged+      else do insertGoal goal False+              case kFactView fa of+                Just (UpK, viewTerm2 -> FPair m1 m2) ->+                    requiresKU m1 *> requiresKU m2 *> return Changed++                Just (UpK, viewTerm2 -> FInv m) ->+                    requiresKU m *> return Changed++                Just (UpK, viewTerm2 -> FMult ms) ->+                    mapM_ requiresKU ms *> return Changed++                _ -> return Unchanged+  where+    goal = ActionG i fa+    -- Here we rely on the fact that the action is new. Otherwise, we might+    -- loop due to generating new KU-nodes that are merged immediately.+    requiresKU t = do+      j <- freshLVar "vk" LSortNode+      let faKU = kuFact t+      insertLess j i+      void (insertAction j faKU)++-- | Insert a 'Less' atom. @insertLess i j@ means that *i < j* is added.+insertLess :: NodeId -> NodeId -> Reduction ()+insertLess i j = modM sLessAtoms (S.insert (i, j))++-- | Insert a 'Last' atom and ensure their uniqueness.+insertLast :: NodeId -> Reduction ChangeIndicator+insertLast i = do+    lst <- getM sLastAtom+    case lst of+      Nothing -> setM sLastAtom (Just i) >> return Unchanged+      Just j  -> solveNodeIdEqs [Equal i j]++-- | Insert an atom. Returns 'Changed' if another part of the constraint+-- system than the set of actions was changed.+insertAtom :: LNAtom -> Reduction ChangeIndicator+insertAtom ato = case ato of+    EqE x y       -> solveTermEqs SplitNow [Equal x y]+    Action i fa   -> insertAction (ltermNodeId' i) fa+    Less i j      -> do insertLess (ltermNodeId' i) (ltermNodeId' j)+                        return Unchanged+    Last i        -> insertLast (ltermNodeId' i)++-- | Insert a 'Guarded' formula. Ensures that existentials, conjunctions, negated+-- last atoms, and negated less atoms, are immediately solved using the rules+-- *S_exists*, *S_and*, *S_not,last*, and *S_not,less*. Only the inserted+-- formula is marked as solved. Other intermediate formulas are not marked.+insertFormula :: LNGuarded -> Reduction ()+insertFormula = do+    insert True+  where+    insert mark fm = do+        formulas       <- getM sFormulas+        solvedFormulas <- getM sSolvedFormulas+        insert' mark formulas solvedFormulas fm++    insert' mark formulas solvedFormulas fm+      | fm `S.member` formulas       = return ()+      | fm `S.member` solvedFormulas = return ()+      | otherwise = case fm of+          GAto ato -> do+              markAsSolved+              void (insertAtom (bvarToLVar ato))++          -- CR-rule *S_∧*+          GConj fms -> do+              markAsSolved+              mapM_ (insert False) (getConj fms)++          -- Store for later applications of CR-rule *S_∨*+          GDisj disj -> do+              modM sFormulas (S.insert fm)+              insertGoal (DisjG disj) False++          -- CR-rule *S_∃*+          GGuarded Ex ss as gf -> do+              -- must always mark as solved, as we otherwise may repeatedly+              -- introduce fresh variables.+              modM sSolvedFormulas $ S.insert fm+              xs <- mapM (uncurry freshLVar) ss+              let body = gconj (map GAto as ++ [gf])+              insert False (substBound (zip [0..] (reverse xs)) body)++          -- CR-rule *S_{¬,⋖}*+          GGuarded All [] [Less i j] gf  | gf == gfalse -> do+              markAsSolved+              insert False (gdisj [GAto (EqE i j), GAto (Less j i)])++          -- CR-rule: FIXME add this rule to paper+          GGuarded All [] [EqE i@(bltermNodeId -> Just _)+                               j@(bltermNodeId -> Just _) ] gf+            | gf == gfalse -> do+                markAsSolved+                insert False (gdisj [GAto (Less i j), GAto (Less j i)])++          -- CR-rule *S_{¬,last}*+          GGuarded All [] [Last i]   gf  | gf == gfalse -> do+              markAsSolved+              lst <- getM sLastAtom+              j <- case lst of+                     Nothing  -> do j <- freshLVar "last" LSortNode+                                    void (insertLast j)+                                    return (varTerm (Free j))+                     Just j -> return (varTerm (Free j))+              insert False $ gdisj [ GAto (Less j i), GAto (Less i j) ]++          -- Guarded All quantification: store for saturation+          GGuarded All _ _ _ -> modM sFormulas (S.insert fm)+      where+        markAsSolved = when mark $ modM sSolvedFormulas $ S.insert fm++-- | 'True' iff the formula can be reduced by one of the rules implemented in+-- 'insertFormula'.+reducibleFormula :: LNGuarded -> Bool+reducibleFormula fm = case fm of+    GAto _                        -> True+    GConj _                       -> True+    GGuarded Ex _ _ _             -> True+    GGuarded All [] [Less _ _] gf -> gf == gfalse+    GGuarded All [] [Last _]   gf -> gf == gfalse+    _                             -> False+++-- Goal management+------------------++-- | Combine the status of two goals.+combineGoalStatus :: GoalStatus -> GoalStatus -> GoalStatus+combineGoalStatus (GoalStatus solved1 age1 loops1)+                  (GoalStatus solved2 age2 loops2) =+    GoalStatus (solved1 || solved2) (min age1 age2) (loops1 || loops2)++-- | Insert a goal and its status with a new age. Merge status if goal exists.+insertGoalStatus :: Goal -> GoalStatus -> Reduction ()+insertGoalStatus goal status = do+    age <- getM sNextGoalNr+    modM sGoals $ M.insertWith' combineGoalStatus goal (set gsNr age status)+    sNextGoalNr =: succ age++-- | Insert a 'Goal' and store its age.+insertGoal :: Goal -> Bool -> Reduction ()+insertGoal goal looping = insertGoalStatus goal (GoalStatus False 0 looping)++-- | Mark the given goal as solved.+markGoalAsSolved :: String -> Goal -> Reduction ()+markGoalAsSolved how goal =+    case goal of+      ActionG _ _     -> updateStatus+      PremiseG _ fa+        | isKDFact fa -> modM sGoals $ M.delete goal+        | otherwise   -> updateStatus+      ChainG _ _      -> modM sGoals $ M.delete goal+      SplitG _        -> updateStatus+      DisjG disj      -> modM sFormulas       (S.delete $ GDisj disj) >>+                         modM sSolvedFormulas (S.insert $ GDisj disj) >>+                         updateStatus+  where+    updateStatus = do+        mayStatus <- M.lookup goal <$> getM sGoals+        case mayStatus of+          Just status -> trace (msg status) $+              modM sGoals $ M.insert goal $ set gsSolved True status+          Nothing     -> trace ("markGoalAsSolved: inexistent goal " ++ show goal) $ return ()++    msg status = render $ nest 2 $ fsep $+        [ text ("solved goal nr. "++ show (get gsNr status))+          <-> parens (text how) <> colon+        , nest 2 (prettyGoal goal) ]++removeSolvedSplitGoals :: Reduction ()+removeSolvedSplitGoals = do+    goals    <- getM sGoals+    existent <- splitExists <$> getM sEqStore+    sequence_ [ modM sGoals $ M.delete goal+              | goal@(SplitG i) <- M.keys goals, not (existent i) ]+++-- Substitution+---------------++-- | Apply the current substitution of the equation store to the remainder of+-- the sequent.+substSystem :: Reduction ChangeIndicator+substSystem = do+    c1 <- substNodes+    substEdges+    substLastAtom+    substLessAtoms+    substFormulas+    substSolvedFormulas+    substLemmas+    c2 <- substGoals+    substNextGoalNr+    return (c1 <> c2)++-- no invariants to maintain here+substEdges, substLessAtoms, substLastAtom, substFormulas,+  substSolvedFormulas, substLemmas, substNextGoalNr :: Reduction ()++substEdges          = substPart sEdges+substLessAtoms      = substPart sLessAtoms+substLastAtom       = substPart sLastAtom+substFormulas       = substPart sFormulas+substSolvedFormulas = substPart sSolvedFormulas+substLemmas         = substPart sLemmas+substNextGoalNr     = return ()+++-- | Apply the current substitution of the equation store to a part of the+-- sequent. This is an internal function.+substPart :: Apply a => (System :-> a) -> Reduction ()+substPart l = do subst <- getM sSubst+                 modM l (apply subst)++-- | Apply the current substitution of the equation store the nodes of the+-- constraint system. Indicates whether additional equalities were added to+-- the equations store.+substNodes :: Reduction ChangeIndicator+substNodes =+    substNodeIds <* ((modM sNodes . M.map . apply) =<< getM sSubst)++-- | @setNodes nodes@ normalizes the @nodes@ such that node ids are unique and+-- then updates the @sNodes@ field of the proof state to the corresponding map.+-- Return @True@ iff new equalities have been added to the equation store.+setNodes :: [(NodeId, RuleACInst)] -> Reduction ChangeIndicator+setNodes nodes0 = do+    sNodes =: M.fromList nodes+    if null ruleEqs then                                    return Unchanged+                    else solveRuleEqs SplitLater ruleEqs >> return Changed+  where+    -- merge nodes with equal node id+    (ruleEqs, nodes) = first concat $ unzip $ map merge $ groupSortOn fst nodes0++    merge []            = unreachable "setNodes"+    merge (keep:remove) = (map (Equal (snd keep) . snd) remove, keep)++-- | Apply the current substitution of the equation store to the node ids and+-- ensure uniqueness of the labels, as required by rule *U_lbl*. Indicates+-- whether there where new equalities added to the equations store.+substNodeIds :: Reduction ChangeIndicator+substNodeIds =+    whileChanging $ do+        subst <- getM sSubst+        nodes <- gets (map (first (apply subst)) . M.toList . get sNodes)+        setNodes nodes++-- | Substitute all goals. Keep the ones with the lower nr.+substGoals :: Reduction ChangeIndicator+substGoals = do+    subst <- getM sSubst+    goals <- M.toList <$> getM sGoals+    sGoals =: M.empty+    changes <- forM goals $ \(goal, status) -> case goal of+        -- Look out for KU-actions that might need to be solved again.+        ActionG i fa@(kFactView -> Just (UpK, m))+          | (isMsgVar m || isProduct m) && (apply subst m /= m) ->+              insertAction i (apply subst fa)+        _ -> do modM sGoals $+                  M.insertWith' combineGoalStatus (apply subst goal) status+                return Unchanged++    return (mconcat changes)+++-- Conjoining two constraint systems+------------------------------------++-- | @conjoinSystem se@ conjoins the logical information in @se@ to the+-- constraint system. It assumes that the free variables in @se@ are shared+-- with the free variables in the proof state.+conjoinSystem :: System -> Reduction ()+conjoinSystem sys = do+    kind <- getM sCaseDistKind+    unless (kind == get sCaseDistKind sys) $+        error "conjoinSystem: typing-kind mismatch"+    joinSets sSolvedFormulas+    joinSets sLemmas+    joinSets sEdges+    F.mapM_ insertLast                 $ get sLastAtom    sys+    F.mapM_ (uncurry insertLess)       $ get sLessAtoms   sys+    -- split-goals are not valid anymore+    mapM_   (uncurry insertGoalStatus) $ filter (not . isSplitGoal . fst) $ M.toList $ get sGoals sys+    F.mapM_ insertFormula $ get sFormulas sys+    -- update nodes+    _ <- (setNodes . (M.toList (get sNodes sys) ++) . M.toList) =<< getM sNodes+    -- conjoin equation store+    eqs <- getM sEqStore+    let (eqs',splitIds) = (mapAccumL addDisj eqs (map snd . getConj $ get sConjDisjEqs sys))+    setM sEqStore eqs'+    -- add split-goals for all disjunctions of sys+    mapM_  (`insertGoal` False) $ SplitG <$> splitIds+    void (solveSubstEqs SplitNow $ get sSubst sys)+    -- Propagate substitution changes. Ignore change indicator, as it is+    -- assumed to be 'Changed' by default.+    void substSystem+  where+    joinSets :: Ord a => (System :-> S.Set a) -> Reduction ()+    joinSets proj = modM proj (`S.union` get proj sys)++-- Unification via the equation store+-------------------------------------++-- | 'SplitStrategy' denotes if the equation store should be split into+-- multiple equation stores.+data SplitStrategy = SplitNow | SplitLater++-- The 'ChangeIndicator' indicates whether at least one non-trivial equality+-- was solved.++-- | @noContradictoryEqStore@ suceeds iff the equation store is not+-- contradictory.+noContradictoryEqStore :: Reduction ()+noContradictoryEqStore = (contradictoryIf . eqsIsFalse) =<< getM sEqStore++-- | Add a list of term equalities to the equation store. And+--  split resulting disjunction of equations according+--  to given split strategy.+--+-- Note that updating the remaining parts of the constraint system with the+-- substitution has to be performed using a separate call to 'substSystem'.+solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> Reduction ChangeIndicator+solveTermEqs splitStrat eqs0 =+    case filter (not . evalEqual) eqs0 of+      []  -> do return Unchanged+      eqs1 -> do+        hnd <- getMaudeHandle+        se  <- gets id+        (eqs2, maySplitId) <- addEqs hnd eqs1 =<< getM sEqStore+        setM sEqStore+            =<< simp hnd (substCreatesNonNormalTerms hnd se)+            =<< case (maySplitId, splitStrat) of+                  (Just splitId, SplitNow) -> disjunctionOfList+                                                $ fromJustNote "solveTermEqs"+                                                $ performSplit eqs2 splitId+                  (Just splitId, SplitLater) -> do+                      insertGoal (SplitG splitId) False+                      return eqs2+                  _                        -> return eqs2+        noContradictoryEqStore+        return Changed++-- | Add a list of equalities in substitution form to the equation store+solveSubstEqs :: SplitStrategy -> LNSubst -> Reduction ChangeIndicator+solveSubstEqs split subst =+    solveTermEqs split [Equal (varTerm v) t | (v, t) <- substToList subst]++-- | Add a list of node equalities to the equation store.+solveNodeIdEqs :: [Equal NodeId] -> Reduction ChangeIndicator+solveNodeIdEqs = solveTermEqs SplitNow . map (fmap varTerm)++-- | Add a list of fact equalities to the equation store, if possible.+solveFactEqs :: SplitStrategy -> [Equal LNFact] -> Reduction ChangeIndicator+solveFactEqs split eqs = do+    contradictoryIf (not $ all evalEqual $ map (fmap factTag) eqs)+    solveListEqs (solveTermEqs split) $ map (fmap factTerms) eqs++-- | Add a list of rule equalities to the equation store, if possible.+solveRuleEqs :: SplitStrategy -> [Equal RuleACInst] -> Reduction ChangeIndicator+solveRuleEqs split eqs = do+    contradictoryIf (not $ all evalEqual $ map (fmap (get rInfo)) eqs)+    solveListEqs (solveFactEqs split) $+        map (fmap (get rConcs)) eqs ++ map (fmap (get rPrems)) eqs+        ++ map (fmap (get rActs)) eqs++-- | Solve a number of equalities between lists interpreted as free terms+-- using the given solver for solving the entailed per-element equalities.+solveListEqs :: ([Equal a] -> Reduction b) -> [(Equal [a])] -> Reduction b+solveListEqs solver eqs = do+    contradictoryIf (not $ all evalEqual $ map (fmap length) eqs)+    solver $ concatMap flatten eqs+  where+    flatten (Equal l r) = zipWith Equal l r++-- | Solve the constraints associated with a rule.+solveRuleConstraints :: Maybe RuleACConstrs -> Reduction ()+solveRuleConstraints (Just eqConstr) = do+    hnd <- getMaudeHandle+    (eqs, splitId) <- addRuleVariants eqConstr <$> getM sEqStore+    insertGoal (SplitG splitId) False+    -- do not use expensive substCreatesNonNormalTerms here+    setM sEqStore =<< simp hnd (const False) eqs+    noContradictoryEqStore+solveRuleConstraints Nothing = return ()+
+ src/Theory/Constraint/Solver/Simplify.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- This module implements all rules that do not result in case distinctions+-- and equation solving. Some additional cases may although result from+-- splitting over multiple AC-unifiers. Note that a few of these rules are+-- implemented directly in the methods for inserting constraints to the+-- constraint system.  These methods are provided by+-- "Theory.Constraint.Solver.Reduction".+--+module Theory.Constraint.Solver.Simplify (++  simplifySystem++  ) where++import           Debug.Trace++import           Prelude                            hiding (id, (.))++import qualified Data.DAG.Simple                    as D+import           Data.Data+import           Data.Either                        (partitionEithers)+import qualified Data.Foldable                      as F+import           Data.List+import qualified Data.Map                           as M+import           Data.Monoid                        (Monoid(..))+import qualified Data.Set                           as S++import           Control.Basics+import           Control.Category+import           Control.Monad.Disj+import           Control.Monad.Fresh+import           Control.Monad.Reader+import           Control.Monad.State                (gets)+++import           Extension.Data.Label+import           Extension.Prelude++import           Theory.Constraint.Solver.Goals+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty+++-- | Apply CR-rules that don't result in case splitting until the constraint+-- system does not change anymore.+simplifySystem :: Reduction ()+simplifySystem = do+    -- Start simplification, indicating that some change happened+    go (0 :: Int) [Changed]+    -- Add all ordering constraint implied by CR-rule *N6*.+    exploitUniqueMsgOrder+    -- Remove equation split goals that do not exist anymore+    removeSolvedSplitGoals+  where+    go n changes0+      -- We stop as soon as all simplification steps have been run without+      -- reporting any change to the constraint systemm.+      | Unchanged == mconcat changes0 = return ()+      | otherwise                     = do+          -- Store original system for reporting+          se0 <- gets id+          -- Perform one initial substitution. We do not have to consider its+          -- changes as 'substSystem' is idempotent.+          void substSystem+          -- Perform one simplification pass.+          (c1,c2,c3) <- enforceNodeUniqueness+          c4 <- enforceEdgeUniqueness+          c5 <- solveUniqueActions+          c6 <- reduceFormulas+          c7 <- evalFormulaAtoms+          c8 <- insertImpliedFormulas++          -- Report on looping behaviour if necessary+          let changes = filter ((Changed ==) . snd) $+                [ ("unique fresh instances (DG4)",        c1)+                , ("unique K↓-facts (N5↓)",               c2)+                , ("unique K↑-facts (N5↑)",               c3)+                , ("unique (linear) edges (DG2 and DG3)", c4)+                , ("solve unambiguous actions (S_@)",     c5)+                , ("decompose trace formula",             c6)+                , ("propagate atom valuation to formula", c7)+                , ("saturate under ∀-clauses (S_∀)",      c8)+                ]+              traceIfLooping+                | n <= 10   = id+                | otherwise = trace $ render $ vsep+                    [ text "Simplifier iteration" <-> int n <> colon+                    , fsep $ text "The reduction-rules for" :+                             (punctuate comma $ map (text . fst) changes) +++                             [text "were applied to the following constraint system."]+                    , nest 2 (prettySystem se0)+                    ]++          traceIfLooping $ go (n + 1) (map snd changes)+++-- | CR-rule *N6*: add ordering constraints between all KU-actions and+-- KD-conclusions.+exploitUniqueMsgOrder :: Reduction ()+exploitUniqueMsgOrder = do+    kdConcs   <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKDConcs)+    kuActions <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKUActions)+    -- We can add all elements where we have an intersection+    F.mapM_ (uncurry insertLess) $ M.intersectionWith (,) kdConcs kuActions++-- | CR-rules *DG4*, *N5_u*, and *N5_d*: enforcing uniqueness of *Fresh* rule+-- instances, *KU*-actions, and *KD*-conclusions.+--+-- Returns 'Changed' if a change was done.+enforceNodeUniqueness :: Reduction (ChangeIndicator, ChangeIndicator, ChangeIndicator)+enforceNodeUniqueness =+    (,,)+      <$> (merge (const $ return Unchanged) freshRuleInsts)+      <*> (merge (solveRuleEqs SplitNow)    kdConcs)+      <*> (merge (solveFactEqs SplitNow)    kuActions)+  where+    -- *DG4*+    freshRuleInsts se = do+        (i, ru) <- M.toList $ get sNodes se+        guard (isFreshRule ru)+        return (ru, ((), i))  -- no need to merge equal rules++    -- *N5_d*+    kdConcs sys = (\(i, ru, m) -> (m, (ru, i))) <$> allKDConcs sys++    -- *N5_u*+    kuActions se = (\(i, fa, m) -> (m, (fa, i))) <$> allKUActions se++    merge :: Ord b+          => ([Equal a] -> Reduction ChangeIndicator)+             -- ^ Equation solver for 'Equal a'+          -> (System -> [(b,(a,NodeId))])+             -- ^ Candidate selector+          -> Reduction ChangeIndicator                  --+    merge solver candidates = do+        changes <- gets (map mergers . groupSortOn fst . candidates)+        mconcat <$> sequence changes+      where+        mergers []                          = unreachable "enforceUniqueness"+        mergers ((_,(xKeep, iKeep)):remove) =+            mappend <$> solver         (map (Equal xKeep . fst . snd) remove)+                    <*> solveNodeIdEqs (map (Equal iKeep . snd . snd) remove)+++-- | CR-rules *DG2_1* and *DG3*: merge multiple incoming edges to all facts+-- and multiple outgoing edges from linear facts.+enforceEdgeUniqueness :: Reduction ChangeIndicator+enforceEdgeUniqueness = do+    se <- gets id+    let edges = S.toList (get sEdges se)+    (<>) <$> mergeNodes eSrc eTgt edges+         <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges)+  where+    -- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th+    -- conclusion of node @v@ is a linear fact.+    proveLinearConc se (v, i) =+        maybe False (isLinearFact . (get (rConc i))) $+            M.lookup v $ get sNodes se++    -- merge the nodes on the 'mergeEnd' for edges that are equal on the+    -- 'compareEnd'+    mergeNodes mergeEnd compareEnd edges+      | null eqs  = return Unchanged+      | otherwise = do+            -- all indices of merged premises and conclusions must be equal+            contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs])+            -- nodes must be equal+            solveNodeIdEqs $ map (fmap fst) eqs+      where+        eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges++        merge _    []            = error "exploitEdgeProps: impossible"+        merge proj (keep:remove) = map (Equal (proj keep) . proj) remove++-- | Special version of CR-rule *S_at*, which is only applied to solve actions+-- that are guaranteed not to result in case splits.+solveUniqueActions :: Reduction ChangeIndicator+solveUniqueActions = do+    rules       <- nonSilentRules <$> askM pcRules+    actionAtoms <- gets unsolvedActionAtoms++    -- FIXME: We might cache the result of this static computation in the+    -- proof-context, e.g., in the 'ClassifiedRules'.+    let uniqueActions = [ x | [x] <- group (sort ruleActions) ]+        ruleActions   = [ (tag, length ts)+                        | ru <- rules, Fact tag ts <- get rActs ru ]++        isUnique (Fact tag ts) = (tag, length ts) `elem` uniqueActions++        trySolve (i, fa)+          | isUnique fa = solveGoal (ActionG i fa) >> return Changed+          | otherwise   = return Unchanged++    mconcat <$> mapM trySolve actionAtoms++-- | Reduce all formulas as far as possible. See 'insertFormula' for the+-- CR-rules exploited in this step. Note that this step is normally only+-- required to decompose the formula in the initial constraint system.+reduceFormulas :: Reduction ChangeIndicator+reduceFormulas = do+    formulas <- getM sFormulas+    applyChangeList $ do+        fm <- S.toList formulas+        guard (reducibleFormula fm)+        return $ do modM sFormulas $ S.delete fm+                    insertFormula fm++-- | Try to simplify the atoms contained in the formulas. See+-- 'partialAtomValuation' for an explanation of what CR-rules are exploited+-- here.+evalFormulaAtoms :: Reduction ChangeIndicator+evalFormulaAtoms = do+    ctxt      <- ask+    valuation <- gets (partialAtomValuation ctxt)+    formulas  <- getM sFormulas+    applyChangeList $ do+        fm <- S.toList formulas+        case simplifyGuarded valuation fm of+          Just fm' -> return $ do+              case fm of+                GDisj disj -> markGoalAsSolved "simplified" (DisjG disj)+                _          -> return ()+              modM sFormulas       $ S.delete fm+              modM sSolvedFormulas $ S.insert fm+              insertFormula fm'+          Nothing  -> []++-- | A partial valuation for atoms. The return value of this function is+-- interpreted as follows.+--+-- @partialAtomValuation ctxt sys ato == Just True@ if for every valuation+-- @theta@ satisfying the graph constraints and all atoms in the constraint+-- system @sys@, the atom @ato@ is also satisfied by @theta@.+--+-- The interpretation for @Just False@ is analogous. @Nothing@ is used to+-- represent *unknown*.+--+partialAtomValuation :: ProofContext -> System -> LNAtom -> Maybe Bool+partialAtomValuation ctxt sys =+    eval+  where+    runMaude   = (`runReader` get pcMaudeHandle ctxt)+    before     = alwaysBefore sys+    lessRel    = rawLessRel sys+    nodesAfter = \i -> filter (i /=) $ S.toList $ D.reachableSet [i] lessRel++    -- | 'True' iff there in every solution to the system the two node-ids are+    -- instantiated to a different index *in* the trace.+    nonUnifiableNodes :: NodeId -> NodeId -> Bool+    nonUnifiableNodes i j = maybe False (not . runMaude) $+        (unifiableRuleACInsts) <$> M.lookup i (get sNodes sys)+                               <*> M.lookup j (get sNodes sys)++    -- | Try to evaluate the truth value of this atom in all models of the+    -- constraint system 'sys'.+    eval ato = case ato of+          Action (ltermNodeId' -> i) fa+            | ActionG i fa `M.member` get sGoals sys -> Just True+            | otherwise ->+                case M.lookup i (get sNodes sys) of+                  Just ru+                    | any (fa ==) (get rActs ru)                                -> Just True+                    | all (not . runMaude . unifiableLNFacts fa) (get rActs ru) -> Just False+                  _                                                             -> Nothing++          Less (ltermNodeId' -> i) (ltermNodeId' -> j)+            | i == j || j `before` i             -> Just False+            | i `before` j                       -> Just True+            | isLast sys i && isInTrace sys j    -> Just False+            | isLast sys j && isInTrace sys i &&+              nonUnifiableNodes i j              -> Just True+            | otherwise                          -> Nothing++          EqE x y+            | x == y                                -> Just True+            | not (runMaude (unifiableLNTerms x y)) -> Just False+            | otherwise                             ->+                case (,) <$> ltermNodeId x <*> ltermNodeId y of+                  Just (i, j)+                    | i `before` j || j `before` i  -> Just False+                    | nonUnifiableNodes i j         -> Just False+                  _                                 -> Nothing++          Last (ltermNodeId' -> i)+            | isLast sys i                       -> Just True+            | any (isInTrace sys) (nodesAfter i) -> Just False+            | otherwise ->+                case get sLastAtom sys of+                  Just j | nonUnifiableNodes i j -> Just False+                  _                              -> Nothing++++-- | CR-rule *S_∀*: insert all newly implied formulas.+insertImpliedFormulas :: Reduction ChangeIndicator+insertImpliedFormulas = do+    sys <- gets id+    hnd <- getMaudeHandle+    applyChangeList $ do+        clause  <- (S.toList $ get sFormulas sys) +++                   (S.toList $ get sLemmas sys)+        implied <- impliedFormulas hnd sys clause+        if ( implied `S.notMember` get sFormulas sys &&+             implied `S.notMember` get sSolvedFormulas sys )+          then return (insertFormula implied)+          else []++-- | @impliedFormulas se imp@ returns the list of guarded formulas that are+-- implied by @se@.+impliedFormulas :: MaudeHandle -> System -> LNGuarded -> [LNGuarded]+impliedFormulas hnd sys gf0 =+    case openGuarded gf `evalFresh` avoid gf of+      Just (All, _vs, antecedent, succedent) -> do+        let (actions, otherAtoms) = partitionEithers $ map prepare antecedent+            succedent'             = gall [] otherAtoms succedent+        subst <- candidateSubsts emptySubst actions+        return $ unskolemizeLNGuarded $ applySkGuarded subst succedent'+      _ -> []+  where+    gf = skolemizeGuarded gf0++    prepare (Action i fa) = Left (i, fa)+    prepare ato           = Right (fmap (fmapTerm (fmap Free)) ato)++    sysActions = do (i, fa) <- allActions sys+                    return (skolemizeTerm (varTerm i), skolemizeFact fa)++    candidateSubsts subst []     = do+        return subst+    candidateSubsts subst (a:as) = do+        sysAct <- sysActions+        subst' <- (`runReader` hnd) $ matchAction sysAct (applySkAction subst a)+        candidateSubsts (compose subst' subst) as+++------------------------------------------------------------------------------+-- Terms, facts, and formulas with skolem constants+------------------------------------------------------------------------------++-- | A constant type that supports names and skolem constants. We use the+-- skolem constants to represent fixed free variables from the constraint+-- system during matching the atoms of a guarded clause to the atoms of the+-- constraint system.+data SkConst = SkName  Name+             | SkConst LVar+             deriving( Eq, Ord, Show, Data, Typeable )++type SkTerm    = VTerm SkConst LVar+type SkFact    = Fact SkTerm+type SkSubst   = Subst SkConst LVar+type SkGuarded = LGuarded SkConst++-- | A term with skolem constants and bound variables+type BSkTerm   = VTerm SkConst BLVar++-- | An term with skolem constants and bound variables+type BSkAtom   = Atom BSkTerm++instance IsConst SkConst+++-- Skolemization of terms without bound variables.+--------------------------------------------------++skolemizeTerm :: LNTerm -> SkTerm+skolemizeTerm = fmapTerm conv+ where+  conv :: Lit Name LVar -> Lit SkConst LVar+  conv (Var v) = Con (SkConst v)+  conv (Con n) = Con (SkName n)++skolemizeFact :: LNFact -> Fact SkTerm+skolemizeFact = fmap skolemizeTerm++skolemizeAtom :: BLAtom -> BSkAtom+skolemizeAtom = fmap skolemizeBTerm++skolemizeGuarded :: LNGuarded -> SkGuarded+skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom)++applySkTerm :: SkSubst -> SkTerm -> SkTerm+applySkTerm subst t = applyVTerm subst t++applySkFact :: SkSubst -> SkFact -> SkFact+applySkFact subst = fmap (applySkTerm subst)++applySkAction :: SkSubst -> (SkTerm,SkFact) -> (SkTerm,SkFact)+applySkAction subst (t,f) = (applySkTerm subst t, applySkFact subst f)+++-- Skolemization of terms with bound variables.+-----------------------------------------------++skolemizeBTerm :: VTerm Name BLVar -> BSkTerm+skolemizeBTerm = fmapTerm conv+ where+  conv :: Lit Name BLVar -> Lit SkConst BLVar+  conv (Var (Free x))  = Con (SkConst x)+  conv (Var (Bound b)) = Var (Bound b)+  conv (Con n)         = Con (SkName n)++unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar+unskolemizeBTerm t = fmapTerm conv t+ where+  conv :: Lit SkConst BLVar -> Lit Name BLVar+  conv (Con (SkConst x)) = Var (Free x)+  conv (Var (Bound b))   = Var (Bound b)+  conv (Var (Free v))    = error $ "unskolemizeBTerm: free variable " +++                                   show v++" found in "++show t+  conv (Con (SkName n))  = Con n++unskolemizeBLAtom :: BSkAtom -> BLAtom+unskolemizeBLAtom = fmap unskolemizeBTerm++unskolemizeLNGuarded :: SkGuarded -> LNGuarded+unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom)++applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar+applyBSkTerm subst =+    go+  where+    go t = case viewTerm t of+      Lit l     -> applyBLLit l+      FApp o as -> fApp o (map go as)++    applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar+    applyBLLit l@(Var (Free v)) =+        maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)+    applyBLLit l                = lit l++applyBSkAtom :: SkSubst -> Atom (VTerm SkConst BLVar) -> Atom (VTerm SkConst BLVar)+applyBSkAtom subst = fmap (applyBSkTerm subst)++applySkGuarded :: SkSubst -> LGuarded SkConst -> LGuarded SkConst+applySkGuarded subst = mapGuardedAtoms (const $ applyBSkAtom subst)++-- Matching+-----------++matchAction :: (SkTerm, SkFact) ->  (SkTerm, SkFact) -> WithMaude [SkSubst]+matchAction (i1, fa1) (i2, fa2) =+    solveMatchLTerm sortOfSkol (i1 `matchWith` i2 <> fa1 `matchFact` fa2)+  where+    sortOfSkol (SkName  n) = sortOfName n+    sortOfSkol (SkConst v) = lvarSort v
+ src/Theory/Constraint/Solver/Types.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeOperators      #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Common types for our constraint solver. They must be declared jointly+-- because there is a recursive dependency between goals, proof contexts, and+-- case distinctions.+module Theory.Constraint.Solver.Types (++  -- * Proof context+    ProofContext(..)+  , InductionHint(..)++  , pcSignature+  , pcRules+  , pcInjectiveFactInsts+  , pcCaseDists+  , pcCaseDistKind+  , pcUseInduction+  , pcTraceQuantifier+  , pcMaudeHandle++  -- ** Classified rules+  , ClassifiedRules(..)+  , emptyClassifiedRules+  , crConstruct+  , crDestruct+  , crProtocol+  , joinAllRules+  , nonSilentRules++  -- * Precomputed case distinctions.+  , CaseDistinction(..)++  , cdGoal+  , cdCases++  ) where++import           Prelude                  hiding (id, (.))++import           Data.Binary+import           Data.DeriveTH+import           Data.Label               hiding (get)+import qualified Data.Label               as L+import           Data.Monoid              (Monoid(..))+import qualified Data.Set                 as S++import           Control.Basics+import           Control.Category+import           Control.DeepSeq++import           Logic.Connectives+import           Theory.Constraint.System+import           Theory.Model+++----------------------------------------------------------------------+-- ClassifiedRules+----------------------------------------------------------------------++data ClassifiedRules = ClassifiedRules+     { _crProtocol      :: [RuleAC] -- all protocol rules+     , _crDestruct      :: [RuleAC] -- destruction rules+     , _crConstruct     :: [RuleAC] -- construction rules+     }+     deriving( Eq, Ord, Show )++$(mkLabels [''ClassifiedRules])++-- | The empty proof rule set.+emptyClassifiedRules :: ClassifiedRules+emptyClassifiedRules = ClassifiedRules [] [] []++-- | @joinAllRules rules@ computes the union of all rules classified in+-- @rules@.+joinAllRules :: ClassifiedRules -> [RuleAC]+joinAllRules (ClassifiedRules a b c) = a ++ b ++ c++-- | Extract all non-silent rules.+nonSilentRules :: ClassifiedRules -> [RuleAC]+nonSilentRules = filter (not . null . L.get rActs) . joinAllRules+++------------------------------------------------------------------------------+-- Proof Context+------------------------------------------------------------------------------++-- | A big-step case distinction.+data CaseDistinction = CaseDistinction+     { _cdGoal     :: Goal   -- start goal of case distinction+       -- disjunction of named sequents with premise being solved; each name+       -- being the path of proof steps required to arrive at these cases+     , _cdCases    :: Disj ([String], System)+     }+     deriving( Eq, Ord, Show )++data InductionHint = UseInduction | AvoidInduction+       deriving( Eq, Ord, Show )++-- | A proof context contains the globally fresh facts, classified rewrite+-- rules and the corresponding precomputed premise case distinction theorems.+data ProofContext = ProofContext+       { _pcSignature          :: SignatureWithMaude+       , _pcRules              :: ClassifiedRules+       , _pcInjectiveFactInsts :: S.Set FactTag+       , _pcCaseDistKind       :: CaseDistKind+       , _pcCaseDists          :: [CaseDistinction]+       , _pcUseInduction       :: InductionHint+       , _pcTraceQuantifier    :: SystemTraceQuantifier+       }+       deriving( Eq, Ord, Show )++$(mkLabels [''ProofContext, ''CaseDistinction])+++-- | The 'MaudeHandle' of a proof-context.+pcMaudeHandle :: ProofContext :-> MaudeHandle+pcMaudeHandle = sigmMaudeHandle . pcSignature++-- Instances+------------++instance HasFrees CaseDistinction where+    foldFrees f th =+        foldFrees f (L.get cdGoal th)   `mappend`+        foldFrees f (L.get cdCases th)++    mapFrees f th = CaseDistinction <$> mapFrees f (L.get cdGoal th)+                                    <*> mapFrees f (L.get cdCases th)+++-- NFData+---------++$( derive makeBinary ''CaseDistinction)+$( derive makeBinary ''ClassifiedRules)+$( derive makeBinary ''InductionHint)++$( derive makeNFData ''CaseDistinction)+$( derive makeNFData ''ClassifiedRules)+$( derive makeNFData ''InductionHint)
+ src/Theory/Constraint/System.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeOperators      #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- This is the public interface for constructing and deconstructing constraint+-- systems. The interface for performing constraint solving provided by+-- "Theory.Constraint.Solver".+module Theory.Constraint.System (+  -- * Constraints+    module Theory.Constraint.System.Constraints++  -- * Constraint systems+  , System++  -- ** Construction+  , emptySystem++  , SystemTraceQuantifier(..)+  , formulaToSystem++  -- ** Node constraints+  , sNodes+  , allKDConcs++  , nodeRule+  , nodeConcNode+  , nodePremNode+  , nodePremFact+  , nodeConcFact+  , resolveNodePremFact+  , resolveNodeConcFact++  -- ** Actions+  , allActions+  , allKUActions+  , unsolvedActionAtoms+  -- FIXME: The two functions below should also be prefixed with 'unsolved'+  , kuActionAtoms+  , standardActionAtoms++  -- ** Edge and chain constraints+  , sEdges+  , unsolvedChains++  -- ** Temporal ordering+  , sLessAtoms++  , rawLessRel+  , rawEdgeRel++  , alwaysBefore+  , isInTrace++  -- ** The last node+  , sLastAtom+  , isLast++  -- ** Equations+  , module Theory.Tools.EquationStore+  , sEqStore+  , sSubst+  , sConjDisjEqs++  -- ** Formulas+  , sFormulas+  , sSolvedFormulas++  -- ** Lemmas+  , sLemmas+  , insertLemmas++  -- ** Keeping track of typing assumptions+  , CaseDistKind(..)+  , sCaseDistKind++  -- ** Goals+  , GoalStatus(..)+  , gsSolved+  , gsLoopBreaker+  , gsNr++  , sGoals+  , sNextGoalNr++  -- * Pretty-printing+  , prettySystem+  , prettyNonGraphSystem++  ) where++import           Prelude                              hiding (id, (.))++import           Data.Binary+import qualified Data.DAG.Simple                      as D+import           Data.DeriveTH+import           Data.List                            (foldl', partition)+import qualified Data.Map                             as M+import           Data.Maybe                           (fromMaybe)+import           Data.Monoid                          (Monoid(..))+import qualified Data.Set                             as S++import           Control.Basics+import           Control.Category+import           Control.DeepSeq++import           Data.Label                           ((:->), mkLabels)+import qualified Extension.Data.Label                 as L++import           Logic.Connectives+import           Theory.Constraint.System.Constraints+import           Theory.Model+import           Theory.Text.Pretty+import           Theory.Tools.EquationStore++++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++-- | Whether we are checking for the existence of a trace satisfiying a the+-- current constraint system or whether we're checking that no traces+-- satisfies the current constraint system.+data SystemTraceQuantifier = ExistsSomeTrace | ExistsNoTrace+       deriving( Eq, Ord, Show )++-- | Case dinstinction kind that are allowed. The order of the kinds+-- corresponds to the subkinding relation: untyped < typed.+data CaseDistKind = UntypedCaseDist | TypedCaseDist+       deriving( Eq )++instance Show CaseDistKind where+    show UntypedCaseDist = "untyped"+    show TypedCaseDist   = "typed"++instance Ord CaseDistKind where+    compare UntypedCaseDist UntypedCaseDist = EQ+    compare UntypedCaseDist TypedCaseDist   = LT+    compare TypedCaseDist   UntypedCaseDist = GT+    compare TypedCaseDist   TypedCaseDist   = EQ++-- | The status of a 'Goal'. Use its 'Semigroup' instance to combine the+-- status info of goals that collapse.+data GoalStatus = GoalStatus+    { _gsSolved :: Bool+       -- True if the goal has been solved already.+    , _gsNr :: Integer+       -- The number of the goal: we use it to track the creation order of+       -- goals.+    , _gsLoopBreaker :: Bool+       -- True if this goal should be solved with care because it may lead to+       -- non-termination.+    }+    deriving( Eq, Ord, Show )++-- | A constraint system.+data System = System+    { _sNodes          :: M.Map NodeId RuleACInst+    , _sEdges          :: S.Set Edge+    , _sLessAtoms      :: S.Set (NodeId, NodeId)+    , _sLastAtom       :: Maybe NodeId+    , _sEqStore        :: EqStore+    , _sFormulas       :: S.Set LNGuarded+    , _sSolvedFormulas :: S.Set LNGuarded+    , _sLemmas         :: S.Set LNGuarded+    , _sGoals          :: M.Map Goal GoalStatus+    , _sNextGoalNr     :: Integer+    , _sCaseDistKind   :: CaseDistKind+    }+    -- NOTE: Don't forget the update 'substSystem' in+    -- "Constraint.Solver.Reduction" when adding further fields to the+    -- constraint system.+    deriving( Eq, Ord )++$(mkLabels [''System, ''GoalStatus])+++-- Further accessors+--------------------++-- | Label to access the free substitution of the equation store.+sSubst :: System :-> LNSubst+sSubst = eqsSubst . sEqStore++-- | Label to access the conjunction of disjunctions of fresh substutitution in+-- the equation store.+sConjDisjEqs :: System :-> Conj (SplitId, S.Set (LNSubstVFresh))+sConjDisjEqs = eqsConj . sEqStore++++------------------------------------------------------------------------------+-- Constraint system construction+------------------------------------------------------------------------------++-- | The empty constraint system, which is logically equivalent to true.+emptySystem :: CaseDistKind -> System+emptySystem = System+    M.empty S.empty S.empty Nothing emptyEqStore+    S.empty S.empty S.empty+    M.empty 0++-- | Returns the constraint system that has to be proven to show that given+-- formula holds in the context of the given theory.+formulaToSystem :: [LNGuarded]           -- ^ Axioms to add+                -> CaseDistKind          -- ^ Case distinction kind+                -> SystemTraceQuantifier -- ^ Trace quantifier+                -> LNFormula+                -> System+formulaToSystem axioms kind traceQuantifier fm =+      insertLemmas safetyAxioms+    $ L.set sFormulas (S.singleton gf2)+    $ (emptySystem kind)+  where+    (safetyAxioms, otherAxioms) = partition isSafetyFormula axioms+    gf0 = formulaToGuarded_ fm+    gf1 = case traceQuantifier of+      ExistsSomeTrace -> gf0+      ExistsNoTrace   -> gnot gf0+    -- Non-safety axioms must be added to the formula, as they render the set+    -- of traces non-prefix-closed, which makes the use of induction unsound.+    gf2 = gconj $ gf1 : otherAxioms++-- | Add a lemma / additional assumption to a constraint system.+insertLemma :: LNGuarded -> System -> System+insertLemma =+    go+  where+    go (GConj conj) = foldr (.) id $ map go $ getConj conj+    go fm           = L.modify sLemmas (S.insert fm)++-- | Add lemmas / additional assumptions to a constraint system.+insertLemmas :: [LNGuarded] -> System -> System+insertLemmas fms sys = foldl' (flip insertLemma) sys fms++------------------------------------------------------------------------------+-- Queries+------------------------------------------------------------------------------+++-- Nodes+------------++-- | A list of all KD-conclusions in the 'System'.+allKDConcs :: System -> [(NodeId, RuleACInst, LNTerm)]+allKDConcs sys = do+    (i, ru)                            <- M.toList $ L.get sNodes sys+    (_, kFactView -> Just (DnK, m)) <- enumConcs ru+    return (i, ru, m)++-- | @nodeRule v@ accesses the rule label of node @v@ under the assumption that+-- it is present in the sequent.+nodeRule :: NodeId -> System -> RuleACInst+nodeRule v se =+    fromMaybe errMsg $ M.lookup v $ L.get sNodes se+  where+    errMsg = error $+        "nodeRule: node '" ++ show v ++ "' does not exist in sequent\n" +++        render (nest 2 $ prettySystem se)+++-- | @nodePremFact prem se@ computes the fact associated to premise @prem@ in+-- sequent @se@ under the assumption that premise @prem@ is a a premise in+-- @se@.+nodePremFact :: NodePrem -> System -> LNFact+nodePremFact (v, i) se = L.get (rPrem i) $ nodeRule v se++-- | @nodePremNode prem@ is the node that this premise is referring to.+nodePremNode :: NodePrem -> NodeId+nodePremNode = fst++-- | All facts associated to this node premise.+resolveNodePremFact :: NodePrem -> System -> Maybe LNFact+resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se)++-- | The fact associated with this node conclusion, if there is one.+resolveNodeConcFact :: NodeConc -> System -> Maybe LNFact+resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se)++-- | @nodeConcFact (NodeConc (v, i))@ accesses the @i@-th conclusion of the+-- rule associated with node @v@ under the assumption that @v@ is labeled with+-- a rule that has an @i@-th conclusion.+nodeConcFact :: NodeConc -> System -> LNFact+nodeConcFact (v, i) = L.get (rConc i) . nodeRule v++-- | 'nodeConcNode' @c@ compute the node-id of the node conclusion @c@.+nodeConcNode :: NodeConc -> NodeId+nodeConcNode = fst+++-- Actions+----------++-- | All actions that hold in a sequent.+unsolvedActionAtoms :: System -> [(NodeId, LNFact)]+unsolvedActionAtoms sys =+      do (ActionG i fa, status) <- M.toList (L.get sGoals sys)+         guard (not $ L.get gsSolved status)+         return (i, fa)++-- | All actions that hold in a sequent.+allActions :: System -> [(NodeId, LNFact)]+allActions sys =+      unsolvedActionAtoms sys+  <|> do (i, ru) <- M.toList $ L.get sNodes sys+         (,) i <$> L.get rActs ru++-- | All actions that hold in a sequent.+allKUActions :: System -> [(NodeId, LNFact, LNTerm)]+allKUActions sys = do+    (i, fa@(kFactView -> Just (UpK, m))) <- allActions sys+    return (i, fa, m)++-- | The standard actions, i.e., non-KU-actions.+standardActionAtoms :: System -> [(NodeId, LNFact)]+standardActionAtoms = filter (not . isKUFact . snd) . unsolvedActionAtoms++-- | All KU-actions.+kuActionAtoms :: System -> [(NodeId, LNFact, LNTerm)]+kuActionAtoms sys = do+    (i, fa@(kFactView -> Just (UpK, m))) <- unsolvedActionAtoms sys+    return (i, fa, m)++-- Destruction chains+---------------------++-- | All unsolved destruction chains in the constraint system.+unsolvedChains :: System -> [(NodeConc, NodePrem)]+unsolvedChains sys = do+    (ChainG from to, status) <- M.toList $ L.get sGoals sys+    guard (not $ L.get gsSolved status)+    return (from, to)+++-- The temporal order+---------------------++-- | @(from,to)@ is in @rawEdgeRel se@ iff we can prove that there is an+-- edge-path from @from@ to @to@ in @se@ without appealing to transitivity.+rawEdgeRel :: System -> [(NodeId, NodeId)]+rawEdgeRel sys = map (nodeConcNode *** nodePremNode) $+     [(from, to) | Edge from to <- S.toList $ L.get sEdges sys]+  ++ unsolvedChains sys++-- | @(from,to)@ is in @rawLessRel se@ iff we can prove that there is a path+-- (possibly using the 'Less' relation) from @from@ to @to@ in @se@ without+-- appealing to transitivity.+rawLessRel :: System -> [(NodeId,NodeId)]+rawLessRel se = S.toList (L.get sLessAtoms se) ++ rawEdgeRel se++-- | Returns a predicate that is 'True' iff the first argument happens before+-- the second argument in all models of the sequent.+alwaysBefore :: System -> (NodeId -> NodeId -> Bool)+alwaysBefore sys =+    check -- lessRel is cached for partial applications+  where+    lessRel   = rawLessRel sys+    check i j =+         -- speed-up check by first checking less-atoms+         ((i, j) `S.member` L.get sLessAtoms sys)+      || (j `S.member` D.reachableSet [i] lessRel)++-- | 'True' iff the given node id is guaranteed to be instantiated to an+-- index in the trace.+isInTrace :: System -> NodeId -> Bool+isInTrace sys i =+     i `M.member` L.get sNodes sys+  || isLast sys i+  || any ((i ==) . fst) (unsolvedActionAtoms sys)++-- | 'True' iff the given node id is guaranteed to be instantiated to the last+-- index of the trace.+isLast :: System -> NodeId -> Bool+isLast sys i = Just i == L.get sLastAtom sys++++------------------------------------------------------------------------------+-- Pretty printing                                                          --+------------------------------------------------------------------------------++-- | Pretty print a sequent+prettySystem :: HighlightDocument d => System -> d+prettySystem se = vcat $+    map combine+      [ ("nodes",          vcat $ map prettyNode $ M.toList $ L.get sNodes se)+      , ("actions",        fsepList ppActionAtom $ unsolvedActionAtoms se)+      , ("edges",          fsepList prettyEdge   $ S.toList $ L.get sEdges se)+      , ("less",           fsepList prettyLess   $ S.toList $ L.get sLessAtoms se)+      , ("unsolved goals", prettyGoals False se)+      ]+    ++ [prettyNonGraphSystem se]+  where+    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]+    ppActionAtom (i, fa) = prettyNAtom (Action (varTerm i) fa)++-- | Pretty print the non-graph part of the sequent; i.e. equation store and+-- clauses.+prettyNonGraphSystem :: HighlightDocument d => System -> d+prettyNonGraphSystem se = vsep $ map combine+  [ ("last",            maybe (text "none") prettyNodeId $ L.get sLastAtom se)+  , ("formulas",        vsep $ map prettyGuarded $ S.toList $ L.get sFormulas se)+  , ("equations",       prettyEqStore $ L.get sEqStore se)+  , ("lemmas",          vsep $ map prettyGuarded $ S.toList $ L.get sLemmas se)+  , ("allowed cases",   text $ show $ L.get sCaseDistKind se)+  , ("solved formulas", vsep $ map prettyGuarded $ S.toList $ L.get sSolvedFormulas se)+  , ("solved goals",    prettyGoals True se)+  ]+  where+    combine (header, d)  = fsep [keyword_ header <> colon, nest 2 d]++-- | Pretty print solved or unsolved goals.+prettyGoals :: HighlightDocument d => Bool -> System -> d+prettyGoals solved sys = vsep $ do+    (goal, status) <- M.toList $ L.get sGoals sys+    guard (solved == L.get gsSolved status)+    let nr  = L.get gsNr status+        loopBreaker | L.get gsLoopBreaker status = " (loop breaker)"+                    | otherwise                  = ""+    return $ prettyGoal goal <-> lineComment_ ("nr: " ++ show nr ++ loopBreaker)+++-- Additional instances+-----------------------++deriving instance Show System++instance Apply CaseDistKind where+    apply = const id++instance HasFrees CaseDistKind where+    foldFrees = const mempty+    mapFrees  = const pure++instance HasFrees GoalStatus where+    foldFrees = const mempty+    mapFrees  = const pure++instance HasFrees System where+    foldFrees fun (System a b c d e f g h i j k) =+        foldFrees fun a `mappend`+        foldFrees fun b `mappend`+        foldFrees fun c `mappend`+        foldFrees fun d `mappend`+        foldFrees fun e `mappend`+        foldFrees fun f `mappend`+        foldFrees fun g `mappend`+        foldFrees fun h `mappend`+        foldFrees fun i `mappend`+        foldFrees fun j `mappend`+        foldFrees fun k++    mapFrees fun (System a b c d e f g h i j k) =+        System <$> mapFrees fun a+               <*> mapFrees fun b+               <*> mapFrees fun c+               <*> mapFrees fun d+               <*> mapFrees fun e+               <*> mapFrees fun f+               <*> mapFrees fun g+               <*> mapFrees fun h+               <*> mapFrees fun i+               <*> mapFrees fun j+               <*> mapFrees fun k+++$( derive makeBinary ''CaseDistKind)+$( derive makeBinary ''GoalStatus)+$( derive makeBinary ''System)+$( derive makeBinary ''SystemTraceQuantifier)++$( derive makeNFData ''CaseDistKind)+$( derive makeNFData ''GoalStatus)+$( derive makeNFData ''System)+$( derive makeNFData ''SystemTraceQuantifier)
+ src/Theory/Constraint/System/Constraints.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell    #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Types representing constraints.+module Theory.Constraint.System.Constraints (+  -- * Guarded formulas+    module Theory.Constraint.System.Guarded++  -- * Graph constraints+  , NodePrem+  , NodeConc+  , Edge(..)+  , Less++  -- * Goal constraints+  , Goal(..)+  , isActionGoal+  , isStandardActionGoal+  , isPremiseGoal+  , isChainGoal+  , isSplitGoal+  , isDisjGoal++  -- ** Pretty-printing+  , prettyNode+  , prettyNodePrem+  , prettyNodeConc+  , prettyEdge+  , prettyLess+  , prettyGoal+  ) where++import           Data.Binary+import           Data.DeriveTH+import           Data.Generics+import           Extension.Data.Monoid            (Monoid(..))++import           Control.Basics+import           Control.DeepSeq++import           Text.PrettyPrint.Class+import           Text.Unicode++import           Logic.Connectives+import           Theory.Constraint.System.Guarded+import           Theory.Model+import           Theory.Text.Pretty+import           Theory.Tools.EquationStore++------------------------------------------------------------------------------+-- Graph part of a sequent                                                  --+------------------------------------------------------------------------------++-- | A premise of a node.+type NodePrem = (NodeId, PremIdx)++-- | A conclusion of a node.+type NodeConc = (NodeId, ConcIdx)++-- | A labeled edge in a derivation graph.+data Edge = Edge {+      eSrc :: NodeConc+    , eTgt :: NodePrem+    }+  deriving (Show, Ord, Eq, Data, Typeable)++-- | A *⋖* constraint between 'NodeId's.+type Less = (NodeId, NodeId)++-- Instances+------------++instance Apply Edge where+    apply subst (Edge from to) = Edge (apply subst from) (apply subst to)++instance HasFrees Edge where+    foldFrees f (Edge x y) = foldFrees f x `mappend` foldFrees f y+    mapFrees  f (Edge x y) = Edge <$> mapFrees f x <*> mapFrees f y+++------------------------------------------------------------------------------+-- Goals+------------------------------------------------------------------------------++-- | A 'Goal' denotes that a constraint reduction rule is applicable, which+-- might result in case splits. We either use a heuristic to decide what goal+-- to solve next or leave the choice to user (in case of the interactive UI).+data Goal =+       ActionG LVar LNFact+       -- ^ An action that must exist in the trace.+     | ChainG NodeConc NodePrem+       -- A destruction chain.+     | PremiseG NodePrem LNFact+       -- ^ A premise that must have an incoming direct edge.+     | SplitG SplitId+       -- ^ A case split over equalities.+     | DisjG (Disj LNGuarded)+       -- ^ A case split over a disjunction.+     deriving( Eq, Ord, Show )++-- Indicators+-------------++isActionGoal :: Goal -> Bool+isActionGoal (ActionG _ _) = True+isActionGoal _             = False++isStandardActionGoal :: Goal -> Bool+isStandardActionGoal (ActionG _ fa) = not (isKUFact fa)+isStandardActionGoal _              = False++isPremiseGoal :: Goal -> Bool+isPremiseGoal (PremiseG _ _) = True+isPremiseGoal _              = False++isChainGoal :: Goal -> Bool+isChainGoal (ChainG _ _) = True+isChainGoal _            = False++isSplitGoal :: Goal -> Bool+isSplitGoal (SplitG _) = True+isSplitGoal _          = False++isDisjGoal :: Goal -> Bool+isDisjGoal (DisjG _) = True+isDisjGoal _         = False++++-- Instances+------------++instance HasFrees Goal where+    foldFrees f goal = case goal of+        ActionG i fa  -> foldFrees f i <> foldFrees f fa+        PremiseG p fa -> foldFrees f p <> foldFrees f fa+        ChainG c p    -> foldFrees f c <> foldFrees f p+        SplitG i      -> foldFrees f i+        DisjG x       -> foldFrees f x++    mapFrees f goal = case goal of+        ActionG i fa  -> ActionG  <$> mapFrees f i <*> mapFrees f fa+        PremiseG p fa -> PremiseG <$> mapFrees f p <*> mapFrees f fa+        ChainG c p    -> ChainG   <$> mapFrees f c <*> mapFrees f p+        SplitG i      -> SplitG   <$> mapFrees f i+        DisjG x       -> DisjG    <$> mapFrees f x++instance Apply Goal where+    apply subst goal = case goal of+        ActionG i fa  -> ActionG  (apply subst i) (apply subst fa)+        PremiseG p fa -> PremiseG (apply subst p) (apply subst fa)+        ChainG c p    -> ChainG   (apply subst c) (apply subst p)+        SplitG i      -> SplitG   (apply subst i)+        DisjG x       -> DisjG    (apply subst x)+++------------------------------------------------------------------------------+-- Pretty printing                                                          --+------------------------------------------------------------------------------++-- | Pretty print a node.+prettyNode :: HighlightDocument d => (NodeId, RuleACInst) -> d+prettyNode (v,ru) = prettyNodeId v <> colon <-> prettyRuleACInst ru++-- | Pretty print a node conclusion.+prettyNodeConc :: HighlightDocument d => NodeConc -> d+prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i)++-- | Pretty print a node premise.+prettyNodePrem :: HighlightDocument d => NodePrem -> d+prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i)++-- | Pretty print a edge as @src >-i--j-> tgt@.+prettyEdge :: HighlightDocument d => Edge -> d+prettyEdge (Edge c p) =+    prettyNodeConc c <-> operator_ ">-->" <-> prettyNodePrem p++-- | Pretty print a less-atom as @src < tgt@.+prettyLess :: HighlightDocument d => Less -> d+prettyLess (i, j) = prettyNAtom $ Less (varTerm i) (varTerm j)++-- | Pretty print a goal.+prettyGoal :: HighlightDocument d => Goal -> d+prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa)+prettyGoal (ChainG c p)   =+    prettyNodeConc c <-> operator_ "~~>" <-> prettyNodePrem p+prettyGoal (PremiseG (i, (PremIdx v)) fa) =+    -- Note that we can use "▷" for conclusions once we need them.+    prettyLNFact fa <-> text ("▶" ++ subscript (show v)) <-> prettyNodeId i+    -- prettyNodePrem p <> brackets (prettyLNFact fa)+prettyGoal (DisjG (Disj []))  = text "Disj" <-> operator_ "(⊥)"+prettyGoal (DisjG (Disj gfs)) = fsep $+    punctuate (operator_ "  ∥") (map (nest 1 . parens . prettyGuarded) gfs)+    -- punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs)+prettyGoal (SplitG x) =+    text "splitEqs" <> parens (text $ show (unSplitId x))++-- Derived instances+--------------------++$( derive makeBinary ''Edge)+$( derive makeBinary ''Goal)++$( derive makeNFData ''Edge)+$( derive makeNFData ''Goal)
+ src/Theory/Constraint/System/Dot.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators   #-}+-- |+-- Copyright   : (c) 2010, 2011 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Conversion of the graph part of a sequent to a Graphviz Dot file.+module Theory.Constraint.System.Dot (+    nonEmptyGraph+  , dotSystemLoose+  , dotSystemCompact+  , compressSystem+  , BoringNodeStyle(..)+  ) where++import           Data.Char                (isSpace)+import           Data.Color+import qualified Data.DAG.Simple          as D+import qualified Data.Foldable            as F+import           Data.List+import qualified Data.Map                 as M+import           Data.Maybe+import           Data.Monoid              (Any(..))+import qualified Data.Set                 as S+import           Safe++import           Extension.Data.Label+import           Extension.Prelude++import           Control.Basics+import           Control.Monad.Reader+import           Control.Monad.State      (StateT, evalStateT)++import qualified Text.Dot                 as D+import           Text.PrettyPrint.Class++import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty       (opAction)++-- | 'True' iff the dotted system will be a non-empty graph.+nonEmptyGraph :: System -> Bool+nonEmptyGraph sys = not $+    M.null (get sNodes sys) && null (unsolvedActionAtoms sys) &&+    null (unsolvedChains sys) &&+    S.null (get sEdges sys) && S.null (get sLessAtoms sys)++type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double)+type SeDot = ReaderT (System, NodeColorMap) (StateT DotState D.Dot)++-- | State to avoid multiple drawing of the same entity.+data DotState = DotState {+    _dsNodes   :: M.Map NodeId   D.NodeId+  , _dsPrems   :: M.Map NodePrem D.NodeId+  , _dsConcs   :: M.Map NodeConc D.NodeId+  , _dsSingles :: M.Map (NodeConc, NodePrem) D.NodeId+  }++$(mkLabels [''DotState])++-- | Lift a 'D.Dot' action.+liftDot :: D.Dot a -> SeDot a+liftDot = lift . lift++-- | All edges in a bipartite graph that have neither start point nor endpoint+-- in common with any other edge.+singleEdges :: (Ord a, Ord b) => [(a,b)] -> [(a,b)]+singleEdges es =+    singles fst es `intersect` singles snd es+  where+    singles proj = concatMap single . groupOn proj . sortOn proj+    single []  = error "impossible"+    single [x] = return x+    single _   = mzero++-- | Get a lighter color.+lighter :: HSV Double -> RGB Double+lighter = hsvToRGB -- fmap (\c -> 1 - 0.3*(1-c)) . hsvToRGB++-- | Ensure that a 'SeDot' action is only executed once by querying and+-- updating the 'DotState' accordingly.+dotOnce :: Ord k+        => (DotState :-> M.Map k D.NodeId) -- ^ Accessor to map storing this type of actions.+        -> k                               -- ^ Action index.+        -> SeDot D.NodeId                  -- ^ Action to execute only once.+        -> SeDot D.NodeId+dotOnce mapL k dot = do+    i <- join $ (maybe dot return . M.lookup k) `liftM` getM mapL+    modM mapL (M.insert k i)+    return i++dotNode :: NodeId -> SeDot D.NodeId+dotNode v = dotOnce dsNodes v $ do+    (se, colorMap) <- ask+    let nodes = get sNodes se+        dot info moreStyle facts = do+            vId <- liftDot $ D.node $ [("label", show v ++ info),("shape","ellipse")]+                                      ++ moreStyle+            _ <- facts vId+            return vId++    case M.lookup v nodes of+      Nothing -> do+          dot "" [] (const $ return ()) -- \vId -> do+              {-+              premIds <- mapM dotPrem+                           [ NodePremFact v fa+                           | SeRequires v' fa <- S.toList $ get sRequires se+                           , v == v' ]+              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]+              -}+      Just ru -> do+          let+              color     = M.lookup (get rInfo ru) colorMap+              nodeColor = maybe "white" (rgbToHex . lighter) color+          dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do+              premIds <- mapM dotPrem+                           [ (v,i) | (i,_) <- enumPrems ru ]+              concIds <- mapM dotConc+                           [ (v,i) | (i,_) <- enumConcs ru ]+              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]+              sequence_ [ dotIntraRuleEdge vId concId | concId <- concIds ]+  where+    label ru = " : " ++ render nameAndActs+      where+        nameAndActs =+            ruleInfo (prettyProtoRuleName . get praciName) prettyIntrRuleACInfo (get rInfo ru) <->+            brackets (vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)++-- | An edge from a rule node to its premises or conclusions.+dotIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()+dotIntraRuleEdge from to = liftDot $ D.edge from to [("color","gray")]++{-+-- | An edge from a rule node to some of its premises or conclusions.+dotNonFixedIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()+dotNonFixedIntraRuleEdge from to =+    liftDot $ D.edge from to [("color","steelblue")]+-}++-- | The style of a node displaying a fact.+factNodeStyle :: LNFact -> [(String,String)]+factNodeStyle fa+  | isJust (kFactView fa) = []+  | otherwise             = [("fillcolor","gray85"),("style","filled")]++-- | An edge that shares no endpoints with another edge and is therefore+-- contracted.+--+-- FIXME: There may be too many edges being contracted.+dotSingleEdge :: (NodeConc, NodePrem) -> SeDot D.NodeId+dotSingleEdge edge@(_, to) = dotOnce dsSingles edge $ do+    se <- asks fst+    let fa    = nodePremFact to se+        label = render $ prettyLNFact fa+    liftDot $ D.node $ [("label", label),("shape", "hexagon")]+                       ++ factNodeStyle fa++-- | A compressed edge.+dotTrySingleEdge :: Eq c+                 => ((NodeConc, NodePrem) -> c) -> c+                 -> SeDot D.NodeId -> SeDot D.NodeId+dotTrySingleEdge sel x dot = do+    singles <- getM dsSingles+    maybe dot (return . snd) $ find ((x ==) . sel . fst) $ M.toList singles++-- | Premises.+dotPrem :: NodePrem -> SeDot D.NodeId+dotPrem prem@(v, i) =+    dotOnce dsPrems prem $ dotTrySingleEdge snd prem $ do+        nodes <- asks (get sNodes . fst)+        let ppPrem = show prem -- FIXME: Use better pretty printing here+            (label, moreStyle) = fromMaybe (ppPrem, []) $ do+                ru <- M.lookup v nodes+                fa <- lookupPrem i ru+                return ( render $ prettyLNFact fa+                       , factNodeStyle fa+                       )+        liftDot $ D.node $ [("label", label),("shape",shape)]+                           ++ moreStyle+  where+    shape = "invtrapezium"++-- | Conclusions.+dotConc :: NodeConc -> SeDot D.NodeId+dotConc =+    dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium"+  where+    dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 =+        dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do+            let x = unwrap x0+            nodes <- asks (get sNodes . fst)+            let (label, moreStyle) = fromMaybe (show x, []) $ do+                    ru <- M.lookup (fst x) nodes+                    fa <- (`atMay` snd x) $ get ruleSel ru+                    return ( render $ prettyLNFact fa+                           , factNodeStyle fa+                           )+            liftDot $ D.node $ [("label", label),("shape",shape)]+                               ++ moreStyle++++-- | Convert the sequent to a 'D.Dot' action representing this sequent as a+-- graph in the GraphViz format. The style is loose in the sense that each+-- premise and conclusion gets its own node.+dotSystemLoose :: System -> D.Dot ()+dotSystemLoose se =+    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $+    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do+        liftDot $ setDefaultAttributes+        -- draw single edges with matching facts.+        mapM_ dotSingleEdge $ singleEdges $ do+            Edge from to <- S.toList $ get sEdges se+            -- FIXME: ensure that conclusion and premise are equal+            guard (nodeConcFact from se == nodePremFact to se)+            return (from, to)+        sequence_ $ do+            (v, ru) <- M.toList $ get sNodes se+            (i, _)  <- enumConcs ru+            return (dotConc (v, i))+        sequence_ $ do+            (v, ru) <- M.toList $ get sNodes se+            (i, _)  <- enumPrems ru+            return (dotPrem (v,i))+        -- FIXME: Also dot unsolved actions.+        mapM_ dotNode     $ M.keys   $ get sNodes     se+        mapM_ dotEdge     $ S.toList $ get sEdges     se+        mapM_ dotChain    $            unsolvedChains se+        mapM_ dotLess     $ S.toList $ get sLessAtoms se+  where+    dotEdge  (Edge src tgt)  = do+        mayNid <- M.lookup (src,tgt) `liftM` getM dsSingles+        maybe (dotGenEdge [] src tgt) (const $ return ()) mayNid++    dotChain (src, tgt) =+        dotGenEdge [("style","dashed"),("color","green")] src tgt++    dotLess (src, tgt) = do+        srcId <- dotNode src+        tgtId <- dotNode tgt+        liftDot $ D.edge srcId tgtId+            [("color","black"),("style","dotted")] -- FIXME: Reactivate,("constraint","false")]+            -- setting constraint to false ignores less-edges when ranking nodes.++    dotGenEdge style src tgt = do+        srcId <- dotConc src+        tgtId <- dotPrem tgt+        liftDot $ D.edge srcId tgtId style+++-- | Set default attributes for nodes and edges.+setDefaultAttributes :: D.Dot ()+setDefaultAttributes = do+  D.attribute ("nodesep","0.3")+  D.attribute ("ranksep","0.3")+  D.nodeAttributes [("fontsize","8"),("fontname","Helvetica"),("width","0.3"),("height","0.2")]+  D.edgeAttributes [("fontsize","8"),("fontname","Helvetica")]+++-- | Compute a color map for nodes labelled with a proof rule info of one of+-- the given rules.+nodeColorMap :: [RuleACInst] -> NodeColorMap+nodeColorMap rules =+    M.fromList $+      [ (get rInfo ru, getColor (gIdx, mIdx))+      | (gIdx, grp) <- groups, (mIdx, ru) <- zip [0..] grp ]+  where+    groupIdx ru | isDestrRule ru                   = 0+                | isConstrRule ru                  = 2+                | isFreshRule ru || isISendRule ru = 3+                | otherwise                        = 1++    -- groups of rules labeled with their index in the group+    groups = [ (gIdx, [ ru | ru <- rules, gIdx == groupIdx ru])+             | gIdx <- [0..3]+             ]++    -- color for each member of a group+    colors = M.fromList $ lightColorGroups intruderHue (map (length . snd) groups)+    getColor idx = fromMaybe (HSV 0 1 1) $ M.lookup idx colors++    -- The hue of the intruder rules+    intruderHue :: Double+    intruderHue = 18 / 360++------------------------------------------------------------------------------+-- Record based dotting+------------------------------------------------------------------------------++-- | The style for nodes of the intruder.+data BoringNodeStyle = FullBoringNodes | CompactBoringNodes+    deriving( Eq, Ord, Show )+++-- | Dot a node in record based (compact) format.+dotNodeCompact :: BoringNodeStyle -> NodeId -> SeDot D.NodeId+dotNodeCompact boringStyle v = dotOnce dsNodes v $ do+    (se, colorMap) <- ask+    let hasOutgoingEdge =+            or [ v == v' | Edge (v', _) _ <- S.toList $ get sEdges se ]+    case M.lookup v $ get sNodes se of+      Nothing -> case filter ((v ==) . fst) (unsolvedActionAtoms se) of+        [] -> mkSimpleNode (show v) []+        as -> let lbl = (fsep $ punctuate comma $ map (prettyLNFact . snd) as)+                        <-> opAction <-> text (show v)+                  attrs | any (isKUFact . snd) as = [("color","gray")]+                        | otherwise               = [("color","darkblue")]+              in mkSimpleNode (render lbl) attrs+      Just ru -> do+          let color     = M.lookup (get rInfo ru) colorMap+              nodeColor = maybe "white" (rgbToHex . lighter) color+              attrs     = [("fillcolor", nodeColor),("style","filled")]+          ids <- mkNode ru attrs hasOutgoingEdge+          let prems = [ ((v, i), nid) | (Just (Left i),  nid) <- ids ]+              concs = [ ((v, i), nid) | (Just (Right i), nid) <- ids ]+          modM dsPrems $ M.union $ M.fromList prems+          modM dsConcs $ M.union $ M.fromList concs+          return $ fromJust $ lookup Nothing ids+  where++    mkSimpleNode lbl attrs =+        liftDot $ D.node $ [("label", lbl),("shape","ellipse")] ++ attrs++    mkNode ru attrs hasOutgoingEdge+      -- single node, share node-id for all premises and conclusions+      | boringStyle == CompactBoringNodes &&+        (isIntruderRule ru || isFreshRule ru) = do+            let lbl | hasOutgoingEdge = show v ++ " : " ++ showRuleCaseName ru+                    | otherwise       = concatMap snd as+            nid <- mkSimpleNode lbl []+            return [ (key, nid) | (key, _) <- ps ++ as ++ cs ]+      -- full record syntax+      | otherwise =+            fmap snd $ liftDot $ (`D.record` attrs) $+            D.vcat $ map D.hcat $ map (map (uncurry D.portField)) $+            filter (not . null) [ps, as, cs]+      where+        ps = renderRow [ (Just (Left i),  prettyLNFact p) | (i, p) <- enumPrems ru ]+        as = renderRow [ (Nothing,        ruleLabel ) ]+        cs = renderRow [ (Just (Right i), prettyLNFact c) | (i, c) <- enumConcs ru ]++        ruleLabel =+            prettyNodeId v <-> colon <-> text (showRuleCaseName ru) <>+            (brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)++        renderRow annDocs =+          zipWith (\(ann, _) lbl -> (ann, lbl)) annDocs $+            -- magic factor 1.3 compensates for space gained due to+            -- non-propertional font+            renderBalanced 100 (max 30 . round . (* 1.3)) (map snd annDocs)++        renderBalanced :: Double           -- ^ Total available width+                       -> (Double -> Int)  -- ^ Convert available space to actual line-width.+                       -> [Doc]            -- ^ Initial documents+                       -> [String]         -- ^ Rendered documents+        renderBalanced _          _    []   = []+        renderBalanced totalWidth conv docs =+            zipWith (\w d -> widthRender (conv (ratio * w)) d) usedWidths docs+          where+            oneLineRender  = renderStyle (defaultStyle { mode = OneLineMode })+            widthRender w  = scaleIndent . renderStyle (defaultStyle { lineLength = w })+            usedWidths     = map (fromIntegral . length . oneLineRender) docs+            ratio          = totalWidth / sum usedWidths+            scaleIndent line = case span isSpace line of+              (spaces, rest) ->+                  -- spaces are not wide-enough by default => scale them up+                  let n = (1.5::Double) * fromIntegral (length spaces)+                  in  replicate (round n) ' ' ++ rest++++-- | Dot a sequent in compact form (one record per rule), if there is anything+-- to draw.+dotSystemCompact :: BoringNodeStyle -> System -> D.Dot ()+dotSystemCompact boringStyle se =+    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $+    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do+        liftDot $ setDefaultAttributes+        mapM_ (dotNodeCompact boringStyle) $ M.keys $ get sNodes       se+        mapM_ (dotNodeCompact boringStyle . fst) $ unsolvedActionAtoms se+        F.mapM_ dotEdge                            $ get sEdges        se+        F.mapM_ dotChain                           $ unsolvedChains    se+        F.mapM_ dotLess                            $ get sLessAtoms    se+  where+    missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)]+    dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem+    dotConcC conc = dotOnce dsConcs conc $ missingNode "trapezium" $ prettyNodeConc conc+    dotEdge (Edge src tgt)  = do+        let check p = maybe False p (resolveNodePremFact tgt se) ||+                      maybe False p (resolveNodeConcFact src se)+            attrs | check isProtoFact =+                      [("style","bold"),("weight","10.0")] +++                      (guard (check isPersistentFact) >> [("color","gray50")])+                  | check isKFact     = [("color","orangered2")]+                  | otherwise         = [("color","gray30")]+        dotGenEdge attrs src tgt++    dotGenEdge style src tgt = do+        srcId <- dotConcC src+        tgtId <- dotPremC tgt+        liftDot $ D.edge srcId tgtId style++    dotChain (src, tgt) =+        dotGenEdge [("style","dashed"),("color","green")] src tgt++    dotLess (src, tgt) = do+        srcId <- dotNodeCompact boringStyle src+        tgtId <- dotNodeCompact boringStyle tgt+        liftDot $ D.edge srcId tgtId+            [("color","black"),("style","dotted")] -- FIXME: reactivate ,("constraint","false")]+            -- setting constraint to false ignores less-edges when ranking nodes.+++------------------------------------------------------------------------------+-- Compressed versions of a sequent+------------------------------------------------------------------------------++-- | Drop 'Less' atoms entailed by the edges of the 'System'.+dropEntailedOrdConstraints :: System -> System+dropEntailedOrdConstraints se =+    modify sLessAtoms (S.filter (not . entailed)) se+  where+    edges               = rawEdgeRel se+    entailed (from, to) = to `S.member` D.reachableSet [from] edges++-- | Unsound compression of the sequent that drops fully connected learns and+-- knows nodes.+compressSystem :: System -> System+compressSystem se0 =+    foldl' (flip tryHideNodeId) se (frees (get sLessAtoms se, get sNodes se))+  where+    se = dropEntailedOrdConstraints se0++-- | @hideTransferNode v se@ hides node @v@ in sequent @se@ if it is a+-- transfer node; i.e., a node annotated with a rule that is one of the+-- special intruder rules or a rule with with at most one premise and+-- at most one conclusion and both premises and conclusions have incoming+-- respectively outgoing edges.+--+-- The compression is chosen such that unly uninteresting nodes are that have+-- no open goal are suppressed.+tryHideNodeId :: NodeId -> System -> System+tryHideNodeId v se = fromMaybe se $ do+    guard $  (lvarSort v == LSortNode)+          && notOccursIn unsolvedChains+          && notOccursIn (get sFormulas)+    maybe hideAction hideRule (M.lookup v $ get sNodes se)+  where+    selectPart :: (System :-> S.Set a) -> (a -> Bool) -> [a]+    selectPart l p = filter p $ S.toList $ get l se++    notOccursIn :: HasFrees a => (System -> a) -> Bool+    notOccursIn proj = not $ getAny $ foldFrees (Any . (v ==)) $ proj se++    -- hide KU-actions deducing pairs, inverses, and simple terms+    hideAction = do+        guard $  not (null kuActions)+              && all eligibleTerm kuActions+              && all (\(i, j) -> not (i == j)) lNews+              && notOccursIn (standardActionAtoms)+              && notOccursIn (get sLastAtom)+              && notOccursIn (get sEdges)++        return $ modify sLessAtoms ( (`S.union` S.fromList lNews)+                                   . (`S.difference` S.fromList lIns)+                                   . (`S.difference` S.fromList lOuts)+                                   )+               $ modify sGoals (\m -> foldl' removeAction m kuActions)+               $ se+      where+        kuActions            = [ x | x@(i,_,_) <- kuActionAtoms se, i == v ]+        eligibleTerm (_,_,m) =+            isPair m || isInverse m || sortOfLNTerm m == LSortPub++        removeAction m (i, fa, _) = M.delete (ActionG i fa) m++        lIns  = selectPart sLessAtoms ((v ==) . snd)+        lOuts = selectPart sLessAtoms ((v ==) . fst)+        lNews = [ (i, j) | (i, _) <- lIns, (_, j) <- lOuts ]++    -- hide a rule, if it is not "too complicated"+    hideRule ru = do+        guard $  eligibleRule+              && ( length eIns  == length (get rPrems ru) )+              && ( length eOuts == length (get rConcs ru) )+              && ( all (not . selfEdge) eNews             )+              && notOccursIn (get sLastAtom)+              && notOccursIn (get sLessAtoms)+              && notOccursIn (unsolvedActionAtoms)++        return $ modify sEdges ( (`S.union` S.fromList eNews)+                               . (`S.difference` S.fromList eIns)+                               . (`S.difference` S.fromList eOuts)+                               )+               $ modify sNodes (M.delete v)+               $ se+      where+        eIns  = selectPart sEdges ((v ==) . nodePremNode . eTgt)+        eOuts = selectPart sEdges ((v ==) . nodeConcNode . eSrc)+        eNews = [ Edge cIn pOut | Edge cIn _ <- eIns, Edge _ pOut <- eOuts ]++        selfEdge (Edge cIn pOut) = nodeConcNode cIn == nodePremNode pOut++        eligibleRule =+             any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule]+          || ( null (get rActs ru) &&+               all (\l -> length (get l ru) <= 1) [rPrems, rConcs]+             )++{-+-- | Try to hide a 'NodeId'. This only works if it has only action and either+-- edge or less constraints associated.+tryHideNodeId :: NodeId -> System -> System+-}+
+ src/Theory/Constraint/System/Guarded.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeSynonymInstances       #-}+-- |+-- Copyright   : (c) 2011 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+-- Guarded formulas.+module Theory.Constraint.System.Guarded (++  -- * Guarded formulas+    Guarded(..)+  , LGuarded+  , LNGuarded++  -- ** Smart constructors+  , gfalse+  , gtrue+  , gdisj+  , gconj+  , gex+  , gall+  , gnot+  , ginduct++  , formulaToGuarded+  , formulaToGuarded_++  -- ** Transformation+  , simplifyGuarded++  , mapGuardedAtoms++  -- ** Queries+  , isConjunction+  , isDisjunction+  , isAllGuarded+  , isExGuarded+  , isSafetyFormula++  , guardFactTags++  -- ** Conversions to non-bound representations+  , bvarToLVar+  , openGuarded++  -- ** Substitutions+  , substBound+  , substBoundAtom+  , substFree+  , substFreeAtom++  -- ** Pretty-printing+  , prettyGuarded++  ) where++import           Control.Applicative+import           Control.Arrow+import           Control.DeepSeq+import           Control.Monad.Error+import           Control.Monad.Fresh              (MonadFresh, scopeFreshness)+import qualified Control.Monad.Trans.PreciseFresh as Precise (Fresh, evalFresh, evalFreshT)++import           Debug.Trace++import           Data.Binary+import           Data.DeriveTH+import           Data.Either                      (partitionEithers)+import           Data.Foldable                    (Foldable(..), foldMap)+import           Data.List+import qualified Data.DList as D+import           Data.Monoid                      (Monoid(..))+import           Data.Traversable                 hiding (mapM, sequence)++import           Logic.Connectives++import           Text.PrettyPrint.Highlight++import           Theory.Model+++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++data Guarded s c v = GAto  (Atom (VTerm c (BVar v)))+                   | GDisj (Disj (Guarded s c v))+                   | GConj (Conj (Guarded s c v))+                   | GGuarded Quantifier [s] [Atom (VTerm c (BVar v))] (Guarded s c v)+                    -- ^ Denotes @ALL xs. as => gf@ or @Ex xs. as & gf&+                    -- depending on the 'Quantifier'.+                    -- We assume that all bound variables xs occur in+                    -- f@i atoms in as.+                   deriving (Eq, Ord, Show)++isConjunction :: Guarded s c v -> Bool+isConjunction (GConj _)  = True+isConjunction _          = False++isDisjunction :: Guarded s c v -> Bool+isDisjunction (GDisj _)  = True+isDisjunction _          = False++isExGuarded :: Guarded s c v -> Bool+isExGuarded (GGuarded Ex _ _ _) = True+isExGuarded _                   = False++isAllGuarded :: Guarded s c v -> Bool+isAllGuarded (GGuarded All _ _ _) = True+isAllGuarded _                    = False++-- | Check whether the guarded formula is closed and does not contain an+-- existential quantifier. This under-approximates the question whether the+-- formula is a safety formula. A safety formula @phi@ has the property that a+-- trace violating it can never be extended to a trace satisfying it.+isSafetyFormula :: HasFrees (Guarded s c v) => Guarded s c v -> Bool+isSafetyFormula gf0 =+    null (frees [gf0]) && noExistential gf0+  where+    noExistential (GAto _ )             = True+    noExistential (GGuarded Ex _ _ _)   = False+    noExistential (GGuarded All _ _ gf) = noExistential gf+    noExistential (GDisj disj)          = all noExistential $ getDisj disj+    noExistential (GConj conj)          = all noExistential $ getConj conj++-- | All 'FactTag's that are used in guards.+guardFactTags :: Guarded s c v -> [FactTag]+guardFactTags =+    D.toList .+    foldGuarded mempty (mconcat . getDisj) (mconcat . getConj) getTags+  where+    getTags _qua _ss atos inner =+        mconcat [ D.singleton tag | Action _ (Fact tag _) <- atos ] <> inner++------------------------------------------------------------------------------+-- Folding+------------------------------------------------------------------------------+++-- | Fold a guarded formula.+foldGuarded :: (Atom (VTerm c (BVar v)) -> b)+            -> (Disj b -> b)+            -> (Conj b -> b)+            -> (Quantifier -> [s] -> [Atom (VTerm c (BVar v))] -> b -> b)+            -> Guarded s c v+            -> b+foldGuarded fAto fDisj fConj fGuarded =+  go+ where+  go (GAto a)                = fAto a+  go (GDisj disj)            = fDisj $ fmap go disj+  go (GConj conj)            = fConj $ fmap go conj+  go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf)++-- | Fold a guarded formula with scope info.+-- The Integer argument denotes the number of+-- quantifiers that have been encountered so far.+foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b)+                 -> (Disj b -> b)+                 -> (Conj b -> b)+                 -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b)+                 -> Guarded s c v+                 -> b+foldGuardedScope fAto fDisj fConj fGuarded =+  go 0+ where+  go !i (GAto a)            = fAto i a+  go !i (GDisj disj)        = fDisj $ fmap (go i) disj+  go !i (GConj conj)        = fConj $ fmap (go i) conj+  go !i (GGuarded qua ss as gf) =+    fGuarded qua ss i' as (go i' gf)+   where+    i' = i + fromIntegral (length ss)+++-- | Map a guarded formula with scope info.+-- The Integer argument denotes the number of+-- quantifiers that have been encountered so far.+mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v))+                -> Atom (VTerm d (BVar w)))+                -> Guarded s c v+                -> Guarded s d w+mapGuardedAtoms f =+    foldGuardedScope (\i a -> GAto $ f i a) GDisj GConj+                     (\qua ss i as gf -> GGuarded qua ss (map (f i) as) gf)++------------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------------++{-+instance Functor (Guarded s c) where+    fmap f = foldGuarded (GAto . fmap (fmapTerm (fmap (fmap f)))) GDisj GConj+                         (\qua ss as gf -> GGuarded qua ss (map (fmap (fmapTerm (fmap (fmap f)))) as) gf)+-}++instance Foldable (Guarded s c) where+    foldMap f = foldGuarded (foldMap (foldMap (foldMap (foldMap f))))+                            (mconcat . getDisj)+                            (mconcat . getConj)+                            (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b)++traverseGuarded :: (Applicative f, Ord c, Ord v, Ord a)+                => (a -> f v) -> Guarded s c a -> f (Guarded s c v)+traverseGuarded f = foldGuarded (liftA GAto . traverse (traverseTerm (traverse (traverse f))))+                                (liftA GDisj . sequenceA)+                                (liftA GConj . sequenceA)+                                (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverseTerm (traverse (traverse f)))) as <*> gf)++instance Ord c => HasFrees (Guarded (String, LSort) c LVar) where+    foldFrees f = foldMap  (foldFrees f)+    mapFrees  f = traverseGuarded (mapFrees f)+++-- FIXME: remove name hints for variables for saturation?+type LGuarded c = Guarded (String, LSort) c LVar++------------------------------------------------------------------------------+-- Substitutions of bound for free and vice versa+------------------------------------------------------------------------------++-- | @substBoundAtom s a@ substitutes each occurence of a bound variables @i@+-- in @dom(s)@ with the corresponding free variable @x=s(i)@ in the atom @a@.+substBoundAtom :: Ord c => [(Integer,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))+substBoundAtom s = fmap (fmapTerm (fmap subst))+ where subst bv@(Bound i') = case lookup i' s of+                               Just x -> Free x+                               Nothing -> bv+       subst fv            = fv++-- | @substBound s gf@ substitutes each occurence of a bound+-- variable @i@ in @dom(s)@ with the corresponding free variable+-- @s(i)=x@ in all atoms in @gf@.+substBound :: Ord c => [(Integer,LVar)] -> LGuarded c -> LGuarded c+substBound s = mapGuardedAtoms (\j a -> substBoundAtom [(i+j,v) | (i,v) <- s] a)+++-- | @substFreeAtom s a@ substitutes each occurence of a free variables @v@+-- in @dom(s)@ with the bound variables @i=s(v)@ in the atom @a@.+substFreeAtom :: Ord c+              => [(LVar,Integer)]+              -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))+substFreeAtom s = fmap (fmapTerm (fmap subst))+ where subst fv@(Free x) = case lookup x s of+                               Just i -> Bound i+                               Nothing -> fv+       subst bv          = bv++-- | @substFreeAtom s gf@ substitutes each occurence of a free variables+-- @v in dom(s)@ with the correpsonding bound variables @i=s(v)@+-- in all atoms in  @gf@.+substFree :: Ord c => [(LVar,Integer)] -> LGuarded c -> LGuarded c+substFree s = mapGuardedAtoms (\j a -> substFreeAtom [(v,i+j) | (v,i) <- s] a)++-- | Assuming that there are no more bound variables left in an atom of a+-- formula, convert it to an atom with free variables only.+bvarToLVar :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar)+bvarToLVar =+    fmap (fmapTerm (fmap (foldBVar boundError id)))+  where+    boundError v = error $ "bvarToLVar: left-over bound variable '"+                           ++ show v ++ "'"++-- | Provided an 'Atom' does not contain a bound variable, it is converted to+-- the type of atoms without bound varaibles.+unbindAtom :: (Ord c, Ord v) => Atom (VTerm c (BVar v)) -> Maybe (Atom (VTerm c v))+unbindAtom = traverse (traverseTerm (traverse (foldBVar (const Nothing) Just)))+++------------------------------------------------------------------------------+-- Opening and Closing+------------------------------------------------------------------------------++-- | @openGuarded gf@ returns @Just (qua,vs,ats,gf')@ if @gf@ is a guarded+-- clause and @Nothing@ otherwise. In the first case, @quao@ is the quantifier,+-- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is the+-- succedent. In both antecedent and succedent, the bound variables are+-- replaced by @vs@.+openGuarded :: (Ord c, MonadFresh m)+            => LGuarded c -> m (Maybe (Quantifier, [LVar], [Atom (VTerm c LVar)], LGuarded c))+openGuarded (GGuarded qua vs as gf) = do+    xs <- mapM (\(n,s) -> freshLVar n s) vs+    return $ Just (qua, xs, openas xs, opengf xs)+  where+    openas xs = map (bvarToLVar . substBoundAtom (subst xs)) as+    opengf xs = substBound (subst xs) gf+    subst xs  = zip [0..] (reverse xs)+openGuarded _ = return Nothing++-- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@.+closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)]+             -> LGuarded c -> LGuarded c+closeGuarded qua vs as gf =+   (case qua of Ex -> gex; All -> gall) vs' as' gf'+ where+   as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as+   gf' = substFree s gf+   s   = zip (reverse vs) [0..]+   vs' = map (lvarName &&& lvarSort) vs+++------------------------------------------------------------------------------+-- Conversion and negation+------------------------------------------------------------------------------++type LNGuarded = Guarded (String,LSort) Name LVar++instance Apply LNGuarded where+  apply subst = mapGuardedAtoms (const $ apply subst)+++-- | @gtf b@ returns the guarded formula f with @b <-> f@.+gtf :: Bool -> Guarded s c v+gtf False = GDisj (Disj [])+gtf True  = GConj (Conj [])++-- | @gfalse@ returns the guarded formula f with @False <-> f@.+gfalse :: Guarded s c v+gfalse = gtf False++-- | @gtrue@ returns the guarded formula f with @True <-> f@.+gtrue :: Guarded s c v+gtrue = gtf True++-- | @gnotAtom a@ returns the guarded formula f with @not a <-> f@.+gnotAtom :: Atom (VTerm c (BVar v)) -> Guarded s c v+gnotAtom a  = GGuarded All [] [a] gfalse++-- | @gconj gfs@ smart constructor for the conjunction of gfs.+gconj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v+gconj gfs0 = case concatMap flatten gfs0 of+    [gf]                      -> gf+    gfs | any (gfalse ==) gfs -> gfalse+        -- FIXME: See 'sortednub' below.+        | otherwise           -> GConj $ Conj $ nub gfs+  where+    flatten (GConj conj) = concatMap flatten $ getConj conj+    flatten gf           = [gf]++-- | @gdisj gfs@ smart constructor for the disjunction of gfs.+gdisj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v+gdisj gfs0 = case concatMap flatten gfs0 of+    [gf]                     -> gf+    gfs | any (gtrue ==) gfs -> gtrue+        -- FIXME: Consider using 'sortednub' here. This yields stronger+        -- normalizaton for formulas. However, it also means that we loose+        -- invariance under renaming free variables, as the order changes,+        -- when they are renamed.+        | otherwise          -> GDisj $ Disj $ nub gfs+  where+    flatten (GDisj disj) = concatMap flatten $ getDisj disj+    flatten gf           = [gf]++-- @ A smart constructor for @GGuarded Ex@ that removes empty quantifications+-- and conjunctions with 'gfalse'.+gex :: (Ord s, Ord c, Ord v)+    => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v+gex [] as gf                = gconj (map GAto as ++ [gf])+gex _  _  gf | gf == gfalse = gfalse+gex ss as gf                = GGuarded Ex ss as gf++-- @ A smart constructor for @GGuarded All@ that drops implications to 'gtrue'+-- and removes empty premises.+gall :: (Eq s, Eq c, Eq v)+     => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v+gall _  []   gf               = gf+gall _  _    gf | gf == gtrue = gtrue+gall ss atos gf               = GGuarded All ss atos gf+++-- Conversion of formulas to guarded formulas+---------------------------------------------++-- | Local newtype to avoid orphan instance.+newtype ErrorDoc d = ErrorDoc { unErrorDoc :: d }+    deriving( Monoid, NFData, Document, HighlightDocument )++instance Document d => Error (ErrorDoc d) where+    noMsg  = emptyDoc+    strMsg = text+++-- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is+-- equivalent to @fm@ under the assumption that this is possible.+-- If not, then 'error' is called.+formulaToGuarded_ :: LNFormula  -> LNGuarded+formulaToGuarded_ = either (error . render) id . formulaToGuarded++-- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is+-- equivalent to @fm@ if possible.+formulaToGuarded :: HighlightDocument d => LNFormula  -> Either d LNGuarded+formulaToGuarded fmOrig =+      either (Left . ppError . unErrorDoc) Right+    $ Precise.evalFreshT (convert False fmOrig) (avoidPrecise fmOrig)+  where+    ppFormula :: HighlightDocument a => LNFormula -> a+    ppFormula = nest 2 . doubleQuotes . prettyLNFormula++    ppError d = d $-$ text "in the formula" $-$ ppFormula fmOrig++    convert True  (Ato a) = pure $ gnotAtom a+    convert False (Ato a) = pure $ GAto a++    convert polarity (Not f) = convert (not polarity) f++    convert True  (Conn And f g) = gdisj <$> mapM (convert True)  [f, g]+    convert False (Conn And f g) = gconj <$> mapM (convert False) [f, g]++    convert True  (Conn Or f g)  = gconj <$> mapM (convert True)  [f, g]+    convert False (Conn Or f g)  = gdisj <$> mapM (convert False) [f, g]++    convert True  (Conn Imp f g         ) =+        gconj <$> sequence [convert False f, convert True  g]+    convert False (Conn Imp f g         ) =+        gdisj <$> sequence [convert True  f, convert False g]++    convert polarity    (TF b) = pure $ gtf (polarity /= b)++    convert polarity f0@(Qua qua0 _ _) =+        -- The quantifier switch stems from our implicit negation of the formula.+        case (qua0, polarity) of+          (All, True ) -> convAll Ex+          (All, False) -> convAll All+          (Ex,  True ) -> convEx  All+          (Ex,  False) -> convEx  Ex+      where+        noUnguardedVars []        = return ()+        noUnguardedVars unguarded = throwError $ vcat+          [ fsep $   text "unguarded variable(s)"+                   : (punctuate comma $+                      map (quotes . text . show) unguarded)+                  ++ map text ["in", "the", "subformula"]+          , ppFormula f0+          ]++        conjActions (Conn And f1 f2)     = conjActions f1 ++ conjActions f2+        conjActions (Ato a@(Action _ _)) = [Left $ bvarToLVar a]+        conjActions f                    = [Right f]++        convEx qua = do+            (xs,_,f) <- openFormulaPrefix f0+            case partitionEithers $ conjActions f of+              (as, fs) -> do+                -- all existentially quantified variables must be guarded+                noUnguardedVars (xs \\ frees as)+                -- convert all other formulas+                gf <- (if polarity then gdisj else gconj)+                        <$> mapM (convert polarity) fs+                return $ closeGuarded qua xs as gf+          where++        convAll qua = do+            (xs,_,f) <- openFormulaPrefix f0+            case f of+              Conn Imp ante suc -> case partitionEithers $ conjActions ante of+                (as, fs) -> do+                  -- all universally quantified variables must be guarded+                  noUnguardedVars (xs \\ frees as)+                  -- negate formulas in antecedent and combine with body+                  gf <- (if polarity then gconj else gdisj)+                          <$> sequence ( map (convert (not polarity)) fs +++                                         [convert polarity suc] )++                  return $ closeGuarded qua xs as gf++              _ -> throwError $+                     text "universal quantifier without toplevel implication" $-$+                     ppFormula f0++    convert polarity (Conn Iff f1 f2) =+        gconj <$> mapM (convert polarity) [Conn Imp f1 f2, Conn Imp f2 f1]+++------------------------------------------------------------------------------+-- Induction over the trace+------------------------------------------------------------------------------++-- | Negate a guarded formula.+gnot :: (Ord s, Ord c, Ord v)+              => Guarded s c v -> Guarded s c v+gnot =+    go+  where+    go (GGuarded All ss as gf) = gex  ss as $ go gf+    go (GGuarded Ex ss as gf)  = gall ss as $ go gf+    go (GAto ato)              = gnotAtom ato+    go (GDisj disj)            = gconj $ map go (getDisj disj)+    go (GConj conj)            = gdisj $ map go (getConj conj)+++-- | Checks if a doubly guarded formula is satisfied by the empty trace;+-- returns @'Left' errMsg@ if the formula is not doubly guarded.+satisfiedByEmptyTrace :: Guarded s c v -> Either String Bool+satisfiedByEmptyTrace =+  foldGuarded+    (\_ato -> throwError "atom outside the scope of a quantifier")+    (liftM or  . sequence . getDisj)+    (liftM and . sequence . getConj)+    (\qua _ss _as _gf -> return $ qua == All)+    -- the empty trace always satisfies guarded all-quantification+    -- and always dissatisfies guarded ex-quantification++-- | Tries to convert a doubly guarded formula to an induction hypothesis.+-- Returns @'Left' errMsg@ if the formula is not last-free or not doubly+-- guarded.+toInductionHypothesis :: Ord c => LGuarded c -> Either String (LGuarded c)+toInductionHypothesis =+    go+  where+    go (GGuarded qua ss as gf)+      | any isLastAtom as = throwError "formula not last-free"+      | otherwise         = do+          gf' <- go gf+          return $ case qua of+            All -> gex  ss as (gconj $ (gnotAtom <$> lastAtos) ++ [gf'])+            Ex  -> gall ss as (gdisj $ (GAto <$> lastAtos) ++ [gf'])+      where+        lastAtos :: [Atom (VTerm c (BVar LVar))]+        lastAtos = do+            (j, (_, LSortNode)) <- zip [0..] $ reverse ss+            return $ Last (varTerm (Bound j))++    go (GAto (Less i j)) = return $ gdisj [GAto (EqE i j), GAto (Less j i)]+    go (GAto (Last _))   = throwError "formula not last-free"+    go (GAto ato)        = return $ gnotAtom ato+    go (GDisj disj)      = gconj <$> traverse go (getDisj disj)+    go (GConj conj)      = gdisj <$> traverse go (getConj conj)++-- | Try to prove the formula by applying induction over the trace.+-- Returns @'Left' errMsg@ if this is not possible. Returns a tuple of+-- formulas: one formalzing the proof obligation of the base-case and one+-- formalizing the proof obligation of the step-case.+ginduct :: Ord c => LGuarded c -> Either String (LGuarded c, LGuarded c)+ginduct gf = do+    unless (null $ frees gf)   (throwError "formula not closed")+    unless (containsAction gf) (throwError "formula contains no action atom")+    baseCase <- satisfiedByEmptyTrace gf+    gfIH     <- toInductionHypothesis gf+    return (gtf baseCase, gconj [gf, gfIH])+  where+    containsAction = foldGuarded (const True) (or . getDisj) (or . getConj)+                                 (\_ _ as body -> not (null as) || body)++------------------------------------------------------------------------------+-- Formula Simplification+------------------------------------------------------------------------------++-- | Simplify a 'Guarded' formula by replacing atoms with their truth value,+-- if it can be determined.+simplifyGuarded :: (LNAtom -> Maybe Bool)+                -- ^ Partial assignment for truth value of atoms.+                -> LNGuarded+                -- ^ Original formula+                -> Maybe LNGuarded+                -- ^ Simplified formula, provided some simplification was+                -- performed.+simplifyGuarded valuation fm0+    | fm1 /= fm0 = trace (render ppMsg) (Just fm1)+    | otherwise  = Nothing+  where+    ppFm  = nest 2 . doubleQuotes . prettyGuarded+    ppMsg = nest 2 $ text "simplified formula:" $-$+                     nest 2 (vcat [ ppFm fm0, text "to", ppFm fm1])++    fm1 = simp fm0++    simp fm@(GAto ato)         = maybe fm gtf (valuation =<< unbindAtom ato)+    simp (GDisj fms)           = gdisj $ map simp $ getDisj fms+    simp (GConj fms)           = gconj $ map simp $ getConj fms+    simp (GGuarded All [] atos gf)+      | any ((Just False ==) . snd) annAtos = gtrue+      | otherwise                           =+          -- keep all atoms that we cannot evaluate yet.+          -- NOTE: Here we are missing the opportunity to change the valuation+          -- for evaluating the body 'gf'. We could add all atoms that we have+          -- as a premise.+          gall [] (fst <$> filter ((Nothing ==) . snd) annAtos) (simp gf)+      where+        -- cache the possibly expensive evaluation of the valuation+        annAtos = (\x -> (x, valuation =<< unbindAtom x)) <$> atos++    -- Note that existentials without quantifiers are already eliminated by+    -- 'gex'. Moreover, we dealay simplification inside guarded all+    -- quantification and guarded existential quantifiers. Their body will be+    -- simplified once the quantifiers are gone.+    simp fm@(GGuarded _ _ _ _) = fm+++------------------------------------------------------------------------------+-- Pretty Printing+------------------------------------------------------------------------------++-- | Pretty print a formula.+prettyGuarded :: HighlightDocument d+              => LNGuarded      -- ^ Guarded Formula.+              -> d              -- ^ Pretty printed formula.+prettyGuarded fm =+    Precise.evalFresh (pp fm) (avoidPrecise fm)+  where+    pp :: HighlightDocument d => LNGuarded -> Precise.Fresh d+    pp (GAto a) = return $ prettyNAtom $ bvarToLVar a++    pp (GDisj (Disj [])) = return $ operator_  "⊥"  -- "F"++    pp (GDisj (Disj xs)) = do+        ps <- mapM (\x -> opParens <$> pp x) xs+        return $ sep $ punctuate (operator_ " ∨") ps+        -- return $ sep $ punctuate (operator_ " |") ps++    pp (GConj (Conj [])) = return $ operator_ "⊤"  -- "T"++    pp (GConj (Conj xs)) = do+        ps <- mapM (\x -> opParens <$> pp x) xs+        return $ sep $ punctuate (operator_ " ∧") ps --- " &") ps++    pp gf0@(GGuarded _ _ _ _) =+      -- variable names invented here can be reused otherwise+      scopeFreshness $ do+          Just (qua, vs, atoms, gf) <- openGuarded gf0+          let antecedent = (GAto . fmap (fmapTerm (fmap Free))) <$> atoms+              connective = operator_ (case qua of All -> "⇒"; Ex -> "∧")+                            -- operator_ (case qua of All -> "==>"; Ex -> "&")+              quantifier = operator_ (ppQuant qua) <-> ppVars vs <> operator_ "."+          dante <- nest 1 <$> pp (GConj (Conj antecedent))+          case (qua, vs, gf) of+            (Ex,  _,  GConj (Conj [])) ->+                return $ sep $ [ quantifier, dante ]+            (All, [], GDisj (Disj [])) | gf == gfalse ->+                return $ operator_ "¬" <> dante+            _  -> do+                dsucc <- nest 1 <$> pp gf+                return $ sep [ quantifier, sep [dante, connective, dsucc] ]+      where+        ppVars      = fsep . map (text . show)+        ppQuant All = "∀"  -- "All "+        ppQuant Ex  = "∃"  -- "Ex "+++-- Derived instances+--------------------++$( derive makeBinary ''Guarded)+$( derive makeNFData ''Guarded)
+ src/Theory/Model.hs view
@@ -0,0 +1,25 @@+-- |+-- Copyright   : (c) 2011-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Security protocol model.+module Theory.Model (+    module Term.Unification+  , module Theory.Model.Atom+  , module Theory.Model.Fact+  , module Theory.Model.Formula+  , module Theory.Model.Rule+  , module Theory.Model.Signature+  )+  where++import           Term.LTerm+import           Term.Unification+import           Theory.Model.Atom+import           Theory.Model.Fact+import           Theory.Model.Formula+import           Theory.Model.Rule+import           Theory.Model.Signature
+ src/Theory/Model/Atom.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DeriveDataTypeable   #-}+-- {-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+-- {-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+-- {-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+-- {-# OPTIONS_GHC -fno-warn-orphans #-}+-- {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+  -- spurious warnings for view patterns+-- |+-- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Formulas that represent security properties.+module Theory.Model.Atom(++  -- * Atoms+    Atom(..)+  , NAtom+  , LNAtom++  , isActionAtom+  , isLastAtom+  , isLessAtom+  , isEqAtom++  -- * LFormula+  , BLAtom++  -- * Pretty-Printing+  , prettyNAtom+  )+where++import           Control.Basics+import           Control.DeepSeq++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable      (Foldable, foldMap)+import           Data.Generics+import           Data.Monoid        (mappend)+import           Data.Traversable++import           Term.LTerm+import           Term.Unification+import           Theory.Model.Fact+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Atoms+------------------------------------------------------------------------------++-- | @Atom@'s are the atoms of trace formulas parametrized over arbitrary+-- terms.+data Atom t = Action   t (Fact t)+            | EqE  t t+            | Less t t+            | Last t+            deriving( Eq, Ord, Show, Data, Typeable )++-- | @LAtom@ are the atoms we actually use in graph formulas input by the user.+type NAtom v = Atom (VTerm Name v)++-- | @LAtom@ are the atoms we actually use in graph formulas input by the user.+type LNAtom = Atom LNTerm++-- | Atoms built over 'BLTerm's.+type BLAtom = Atom BLTerm+++-- Instances+------------++instance Functor Atom where+    fmap f (Action   i fa) = Action    (f i) (fmap f fa)+    fmap f (EqE l r)       = EqE       (f l) (f r)+    fmap f (Less v u)      = Less      (f v) (f u)+    fmap f (Last i)        = Last      (f i)++instance Foldable Atom where+    foldMap f (Action i fa)   =+        f i `mappend` (foldMap f fa)+    foldMap f (EqE l r)       = f l `mappend` f r+    foldMap f (Less i j)      = f i `mappend` f j+    foldMap f (Last i)        = f i++instance Traversable Atom where+    traverse f (Action i fa)   =+        Action <$> f i <*> traverse f fa+    traverse f (EqE l r)       = EqE <$> f l <*> f r+    traverse f (Less v u)      = Less <$> f v <*> f u+    traverse f (Last i)        = Last <$> f i++instance HasFrees t => HasFrees (Atom t) where+    foldFrees f = foldMap (foldFrees f)+    mapFrees  f = traverse (mapFrees f)++instance Apply LNAtom where+    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)+    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)+    apply subst (Less i j)        = Less (apply subst i) (apply subst j)+    apply subst (Last i)          = Last (apply subst i)++instance Apply BLAtom where+    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)+    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)+    apply subst (Less i j)        = Less (apply subst i) (apply subst j)+    apply subst (Last i)          = Last (apply subst i)+++-- Queries+----------++-- | True iff the atom is an action atom.+isActionAtom :: Atom t -> Bool+isActionAtom ato = case ato of Action _ _ -> True; _ -> False++-- | True iff the atom is a last atom.+isLastAtom :: Atom t -> Bool+isLastAtom ato = case ato of Last _ -> True; _ -> False++-- | True iff the atom is a temporal ordering atom.+isLessAtom :: Atom t -> Bool+isLessAtom ato = case ato of Less _ _ -> True; _ -> False++-- | True iff the atom is an equality atom.+isEqAtom :: Atom t -> Bool+isEqAtom ato = case ato of EqE _ _ -> True; _ -> False+++------------------------------------------------------------------------------+-- Pretty-Printing+------------------------------------------------------------------------------++prettyNAtom :: (Show v, HighlightDocument d) => NAtom v -> d+prettyNAtom (Action v fa) =+    prettyFact prettyNTerm fa <-> opAction <-> text (show v)+prettyNAtom (EqE l r) =+    sep [prettyNTerm l <-> opEqual, prettyNTerm r]+    -- sep [prettyNTerm l <-> text "≈", prettyNTerm r]+prettyNAtom (Less u v) = text (show u) <-> opLess <-> text (show v)+prettyNAtom (Last i)   = operator_ "last" <> parens (text (show i))+++-- derived instances+--------------------++$( derive makeNFData ''Atom)+$( derive makeBinary ''Atom)
+ src/Theory/Model/Fact.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Facts used to formulate and reason about protocol execution.+module Theory.Model.Fact (++  -- * Fact+    Fact(..)+  , Multiplicity(..)+  , FactTag(..)++  , matchFact++  -- ** Queries+  , isLinearFact+  , isPersistentFact+  , isProtoFact++  , factTagName+  , showFactTag+  , showFactTagArity+  , factTagArity+  , factTagMultiplicity+  , factArity+  , factMultiplicity++  , DirTag(..)+  , kuFact+  , kdFact+  , kFactView+  , dedFactView++  , isKFact+  , isKUFact+  , isKDFact++  -- ** Construction+  , freshFact+  , outFact+  , inFact+  , kLogFact+  , dedLogFact+  , protoFact++  -- * NFact+  , NFact++  -- * LFact+  , LFact+  , LNFact+  , unifyLNFactEqs+  , unifiableLNFacts++  -- * Pretty-Printing++  , prettyFact+  , prettyNFact+  , prettyLNFact++  ) where++import           Control.Basics+import           Control.DeepSeq++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable          (Foldable(..))+import           Data.Generics+import           Data.Maybe             (isJust)+import           Data.Monoid+import           Data.Traversable       (Traversable(..))++import           Term.Unification++import           Text.PrettyPrint.Class+++------------------------------------------------------------------------------+-- Fact+------------------------------------------------------------------------------++data Multiplicity = Persistent | Linear+                  deriving( Eq, Ord, Show, Typeable, Data )++-- | Fact tags/symbols+data FactTag = ProtoFact Multiplicity String Int+               -- ^ A protocol fact together with its arity and multiplicity.+             | FreshFact  -- ^ Freshly generated value.+             | OutFact    -- ^ Sent by the protocol+             | InFact     -- ^ Officially known by the intruder/network.+             | KUFact     -- ^ Up-knowledge fact in messsage deduction.+             | KDFact     -- ^ Down-knowledge fact in message deduction.+             | DedFact    -- ^ Log-fact denoting that the intruder deduced+                          -- a message using a construction rule.+    deriving( Eq, Ord, Show, Typeable, Data )++-- | Facts.+data Fact t = Fact+    { factTag   :: FactTag+    , factTerms :: [t]+    }+    deriving( Eq, Ord, Show, Typeable, Data )+++-- Instances+------------++instance Functor Fact where+    fmap f (Fact tag ts) = Fact tag (fmap f ts)++instance Foldable Fact where+    foldMap f (Fact _ ts) = foldMap f ts++instance Traversable Fact where+    sequenceA (Fact tag ts) = Fact tag <$> sequenceA ts+    traverse f (Fact tag ts) = Fact tag <$> traverse f ts++instance Sized t => Sized (Fact t) where+  size (Fact _ args) = size args++instance HasFrees t => HasFrees (Fact t) where+    foldFrees  f = foldMap  (foldFrees f)+    mapFrees   f = traverse (mapFrees f)++instance Apply t => Apply (Fact t) where+    apply subst = fmap (apply subst)+++-- KU and KD facts+------------------++-- | A direction tag+data DirTag = UpK | DnK+            deriving( Eq, Ord, Show )++kdFact, kuFact :: t -> Fact t+kdFact = Fact KDFact . return+kuFact = Fact KUFact . return++-- | View a message-deduction fact.+kFactView :: LNFact -> Maybe (DirTag, LNTerm)+kFactView fa = case fa of+    Fact KUFact [m] -> Just (UpK, m)+    Fact KUFact _   -> errMalformed "kFactView" fa+    Fact KDFact [m] -> Just (DnK, m)+    Fact KDFact _   -> errMalformed "kFactView" fa+    _               -> Nothing++-- | View a deduction logging fact.+dedFactView :: LNFact -> Maybe LNTerm+dedFactView fa = case fa of+    Fact DedFact [m] -> Just m+    Fact DedFact _   -> errMalformed "dedFactView" fa+    _                -> Nothing++-- | True if the fact is a message-deduction fact.+isKFact :: LNFact -> Bool+isKFact = isJust . kFactView++-- | True if the fact is a KU-fact.+isKUFact :: LNFact -> Bool+isKUFact (Fact KUFact _) = True+isKUFact _               = False++-- | True if the fact is a KD-fact.+isKDFact :: LNFact -> Bool+isKDFact (Fact KDFact _) = True+isKDFact _               = False++-- | Mark a fact as malformed.+errMalformed :: String -> LNFact -> a+errMalformed caller fa =+    error $ caller ++ show ": malformed fact: " ++ show fa++-- Constructing facts+---------------------++-- | A fact denoting a message sent by the protocol to the intruder.+outFact :: t -> Fact t+outFact = Fact OutFact . return++-- | A fresh fact denotes a fresh unguessable name.+freshFact :: t -> Fact t+freshFact = Fact FreshFact . return++-- | A fact denoting that the intruder sent a message to the protocol.+inFact :: t -> Fact t+inFact = Fact InFact . return++-- | A fact logging that the intruder knows a message.+kLogFact :: t -> Fact t+kLogFact = protoFact Linear "K" . return++-- | A fact logging that the intruder deduced a message using a construction+-- rule. We use this to formulate invariants over normal dependency graphs.+dedLogFact :: t -> Fact t+dedLogFact = Fact DedFact . return++-- | A protocol fact denotes a fact generated by a protocol rule.+protoFact :: Multiplicity -> String -> [t] -> Fact t+protoFact multi name ts = Fact (ProtoFact multi name (length ts)) ts+++-- Queries on facts+-------------------++-- | True iff the fact is a non-special protocol fact.+isProtoFact :: Fact t -> Bool+isProtoFact (Fact (ProtoFact _ _ _) _) = True+isProtoFact _                          = False++-- | True if the fact is a linear fact.+isLinearFact :: Fact t -> Bool+isLinearFact = (Linear ==) . factMultiplicity++-- | True if the fact is a persistent fact.+isPersistentFact :: Fact t -> Bool+isPersistentFact = (Persistent ==) . factMultiplicity++-- | The multiplicity of a 'FactTag'.+factTagMultiplicity :: FactTag -> Multiplicity+factTagMultiplicity tag = case tag of+    ProtoFact multi _ _ -> multi+    KUFact              -> Persistent+    KDFact              -> Persistent+    _                   -> Linear++-- | The arity of a 'FactTag'.+factTagArity :: FactTag -> Int+factTagArity tag = case  tag of+    ProtoFact _ _ k -> k+    KUFact          -> 1+    KDFact          -> 1+    DedFact         -> 1+    FreshFact       -> 1+    InFact          -> 1+    OutFact         -> 1++-- | The arity of a 'Fact'.+factArity :: Fact t -> Int+factArity (Fact tag ts)+  | length ts == k = k+  | otherwise      = error $ "factArity: tag of arity " ++ show k +++                             " applied to " ++ show (length ts) ++ " terms"+  where+    k = factTagArity tag++-- | The multiplicity of a 'Fact'.+factMultiplicity :: Fact t -> Multiplicity+factMultiplicity = factTagMultiplicity . factTag+++------------------------------------------------------------------------------+-- NFact+------------------------------------------------------------------------------++-- | Facts with literals containing names and arbitrary variables.+type NFact v = Fact (NTerm v)+++------------------------------------------------------------------------------+-- LFact+------------------------------------------------------------------------------++-- | Facts with literals arbitrary constants and logical variables.+type LFact c = Fact (LTerm c)++-- | Facts used for proving; i.e. variables fixed to logical variables+-- and constant fixed to names.+type LNFact = Fact LNTerm++-- | Unify a list of @LFact@ equalities.+unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh]+unifyLNFactEqs eqs+  | all (evalEqual . fmap factTag) eqs =+      unifyLNTerm (map (fmap (fAppList . factTerms)) eqs)+  | otherwise = return []++-- | 'True' iff the two facts are unifiable.+unifiableLNFacts :: LNFact -> LNFact -> WithMaude Bool+unifiableLNFacts fa1 fa2 = (not . null) <$> unifyLNFactEqs [Equal fa1 fa2]++-- | @matchLFact t p@ is a complete set of AC matchers for the term fact @t@+-- and the pattern fact @p@.+matchFact :: Fact t -- ^ Term+            -> Fact t -- ^ Pattern+            -> Match t+matchFact t p =+    matchOnlyIf (factTag t == factTag p &&+                 length (factTerms t) == length (factTerms p))+    <> mconcat (zipWith matchWith (factTerms t) (factTerms p))++------------------------------------------------------------------------------+-- Pretty Printing+------------------------------------------------------------------------------++-- | The name of a fact tag, e.g., @factTagName KUFact = "KU"@.+factTagName :: FactTag -> String+factTagName tag = case tag of+    KUFact            -> "KU"+    KDFact            -> "KD"+    DedFact           -> "Ded"+    InFact            -> "In"+    OutFact           -> "Out"+    FreshFact         -> "Fr"+    (ProtoFact _ n _) -> n++-- | Show a fact tag as a 'String'. This is the 'factTagName' prefixed with+-- the multiplicity.+showFactTag :: FactTag -> String+showFactTag tag =+    (++ factTagName tag) $ case factTagMultiplicity tag of+                             Linear     -> ""+                             Persistent -> "!"++-- | Show a fact tag together with its aritiy.+showFactTagArity :: FactTag -> String+showFactTagArity tag = showFactTag tag ++ "/" ++ show (factTagArity tag)++-- | Pretty print a fact.+prettyFact :: Document d => (t -> d) -> Fact t -> d+prettyFact ppTerm (Fact tag ts)+  | factTagArity tag /= length ts = ppFact ("MALFORMED-" ++ show tag) ts+  | otherwise                     = ppFact (showFactTag tag) ts+  where+    ppFact n = nestShort' (n ++ "(") ")" . fsep . punctuate comma . map ppTerm++-- | Pretty print a 'NFact'.+prettyNFact :: Document d => LNFact -> d+prettyNFact = prettyFact prettyNTerm++-- | Pretty print a 'LFact'.+prettyLNFact :: Document d => LNFact -> d+prettyLNFact fa = prettyFact prettyNTerm fa++-- derived instances+--------------------++$( derive makeBinary ''Multiplicity)+$( derive makeBinary ''FactTag)+$( derive makeBinary ''Fact)++$( derive makeNFData ''Multiplicity)+$( derive makeNFData ''FactTag)+$( derive makeNFData ''Fact)
+ src/Theory/Model/Formula.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Types and operations for handling sorted first-order logic+module Theory.Model.Formula (++   -- * Formulas+    Connective(..)+  , Quantifier(..)+  , Formula(..)+  , LNFormula+  , LFormula++  , quantify+  , openFormula+  , openFormulaPrefix+--  , unquantify++  -- ** More convenient constructors+  , lfalse+  , ltrue+  , (.&&.)+  , (.||.)+  , (.==>.)+  , (.<=>.)+  , exists+  , forall++  -- ** General Transformations+  , mapAtoms+  , foldFormula++  -- ** Pretty-Printing+  , prettyLNFormula++  ) where++import           Prelude                          hiding (negate)++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable                    (Foldable, foldMap)+import           Data.Generics+import           Data.Monoid                      hiding (All)+import           Data.Traversable++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.Fresh+import qualified Control.Monad.Trans.PreciseFresh as Precise++import           Theory.Model.Atom++import           Text.PrettyPrint.Highlight+import           Theory.Text.Pretty++import           Term.LTerm+import           Term.Substitution++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++-- | Logical connectives.+data Connective = And | Or | Imp | Iff+                deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable )++-- | Quantifiers.+data Quantifier = All | Ex+                deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable )+++-- | First-order formulas in locally nameless representation with hints for the+-- names/sorts of quantified variables.+data Formula s c v = Ato (Atom (VTerm c (BVar v)))+                   | TF !Bool+                   | Not (Formula s c v)+                   | Conn !Connective (Formula s c v) (Formula s c v)+                   | Qua !Quantifier s (Formula s c v)++-- Folding+----------++-- | Fold a formula.+{-# INLINE foldFormula #-}+foldFormula :: (Atom (VTerm c (BVar v)) -> b) -> (Bool -> b)+            -> (b -> b) -> (Connective -> b -> b -> b)+            -> (Quantifier -> s -> b -> b)+            -> Formula s c v+            -> b+foldFormula fAto fTF fNot fConn fQua =+    go+  where+    go (Ato a)       = fAto a+    go (TF b)        = fTF b+    go (Not p)       = fNot (go p)+    go (Conn c p q)  = fConn c (go p) (go q)+    go (Qua qua x p) = fQua qua x (go p)++-- | Fold a formula.+{-# INLINE foldFormulaScope #-}+foldFormulaScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b)+                 -> (b -> b) -> (Connective -> b -> b -> b)+                 -> (Quantifier -> s -> b -> b)+                 -> Formula s c v+                 -> b+foldFormulaScope fAto fTF fNot fConn fQua =+    go 0+  where+    go !i (Ato a)       = fAto i a+    go _  (TF b)        = fTF b+    go !i (Not p)       = fNot (go i p)+    go !i (Conn c p q)  = fConn c (go i p) (go i q)+    go !i (Qua qua x p) = fQua qua x (go (succ i) p)+++-- Instances+------------++{-+instance Functor (Formula s c) where+    fmap f = foldFormula (Ato . fmap (fmap (fmap (fmap f)))) TF Not Conn Qua+-}++instance Foldable (Formula s c) where+    foldMap f = foldFormula (foldMap (foldMap (foldMap (foldMap f)))) mempty id+                            (const mappend) (const $ const id)++traverseFormula :: (Ord v, Ord c, Ord v', Applicative f)+                => (v -> f v') -> Formula s c v -> f (Formula s c v')+traverseFormula f = foldFormula (liftA Ato . traverse (traverseTerm (traverse (traverse f))))+                                (pure . TF) (liftA Not)+                                (liftA2 . Conn) ((liftA .) . Qua)+{-+instance Traversable (Formula a s) where+    traverse f = foldFormula (liftA Ato . traverseAtom (traverseTerm  (traverseLit (traverseBVar f))))+                             (pure . TF) (liftA Not)+                             (liftA2 . Conn) ((liftA .) . Qua)+-}++-- Abbreviations+----------------++infixl 3 .&&.+infixl 2 .||.+infixr 1 .==>.+infix  1 .<=>.++-- | Logically true.+ltrue :: Formula a s v+ltrue = TF True++-- | Logically false.+lfalse :: Formula a s v+lfalse = TF False++(.&&.), (.||.), (.==>.), (.<=>.) :: Formula a s v -> Formula a s v -> Formula a s v+(.&&.)  = Conn And+(.||.)  = Conn Or+(.==>.) = Conn Imp+(.<=>.) = Conn Iff++------------------------------------------------------------------------------+-- Dealing with bound variables+------------------------------------------------------------------------------++-- | @LFormula@ are FOL formulas with sorts abused to denote both a hint for+-- the name of the bound variable, as well as the variable's actual sort.+type LFormula c = Formula (String, LSort) c LVar++type LNFormula = Formula (String, LSort) Name LVar++-- | Change the representation of atoms.+mapAtoms :: (Integer -> Atom (VTerm c (BVar v))+         -> Atom (VTerm c1 (BVar v1)))+         -> Formula s c v -> Formula s c1 v1+mapAtoms f = foldFormulaScope (\i a -> Ato $ f i a) TF Not Conn Qua++-- | @openFormula f@ returns @Just (v,Q,f')@ if @f = Q v. f'@ modulo+-- alpha renaming and @Nothing otherwise@. @v@ is always chosen to be fresh.+openFormula :: (MonadFresh m, Ord c)+            => LFormula c -> Maybe (Quantifier, m (LVar, LFormula c))+openFormula (Qua qua (n,s) fm) =+    Just ( qua+         , do x <- freshLVar n s+              return $ (x, mapAtoms (\i a -> fmap (mapLits (subst x i)) a) fm)+         )+  where+    subst x i (Var (Bound i')) | i == i' = Var $ Free x+    subst _ _ l                          = l++openFormula _ = Nothing++mapLits :: (Ord a, Ord b) => (a -> b) -> Term a -> Term b+mapLits f t = case viewTerm t of+    Lit l     -> lit . f $ l+    FApp o as -> fApp o (map (mapLits f) as)++-- | @openFormulaPrefix f@ returns @Just (vs,Q,f')@ if @f = Q v_1 .. v_k. f'@+-- modulo alpha renaming and @Nothing otherwise@. @vs@ is always chosen to be+-- fresh.+openFormulaPrefix :: (MonadFresh m, Ord c)+                  => LFormula c -> m ([LVar], Quantifier, LFormula c)+openFormulaPrefix f0 = case openFormula f0 of+    Nothing        -> error $ "openFormulaPrefix: no outermost quantifier"+    Just (q, open) -> do+      (x, f) <- open+      go q [x] f+  where+    go q xs f = case openFormula f of+        Just (q', open') | q' == q -> do (x', f') <- open'+                                         go q (x' : xs) f'+        -- no further quantifier of the same kind => return result+        _ -> return (reverse xs, q, f)+++-- Instances+------------++deriving instance Eq       LNFormula+deriving instance Show     LNFormula+deriving instance Ord      LNFormula++instance HasFrees LNFormula where+    foldFrees  f = foldMap  (foldFrees  f)+    mapFrees   f = traverseFormula (mapFrees   f)++instance Apply LNFormula where+    apply subst = mapAtoms (const $ apply subst)++------------------------------------------------------------------------------+-- Formulas modulo E and modulo AC+------------------------------------------------------------------------------++-- | Introduce a bound variable for a free variable.+quantify :: (Ord c, Ord v, Eq v) => v -> Formula s c v -> Formula s c v+quantify x =+    mapAtoms (\i a -> fmap (mapLits (fmap (>>= subst i))) a)+  where+    subst i v | v == x    = Bound i+              | otherwise = Free v++-- | Create a universal quantification with a sort hint for the bound variable.+forall :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v+forall hint x = Qua All hint . quantify x++-- | Create a existential quantification with a sort hint for the bound variable.+exists :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v+exists hint x = Qua Ex hint . quantify x++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty print a formula.+prettyLFormula :: (HighlightDocument d, MonadFresh m, Ord c)+              => (Atom (VTerm c LVar) -> d)  -- ^ Function for pretty printing atoms+              -> LFormula c                      -- ^ Formula to pretty print.+              -> m d                             -- ^ Pretty printed formula.+prettyLFormula ppAtom =+    pp+  where+    extractFree (Free v)  = v+    extractFree (Bound i) = error $ "prettyFormula: illegal bound variable '" ++ show i ++ "'"++    pp (Ato a)    = return $ ppAtom (fmap (mapLits (fmap extractFree)) a)+    pp (TF True)  = return $ operator_ "⊤"    -- "T"+    pp (TF False) = return $ operator_ "⊥"    -- "F"++    pp (Not p)    = do+      p' <- pp p+      return $ operator_ "¬" <> opParens p' -- text "¬" <> parens (pp a)+      -- return $ operator_ "not" <> opParens p' -- text "¬" <> parens (pp a)++    pp (Conn op p q) = do+        p' <- pp p+        q' <- pp q+        return $ sep [opParens p' <-> ppOp op, opParens q']+      where+        ppOp And = opLAnd+        ppOp Or  = opLOr+        ppOp Imp = opImp+        ppOp Iff = opIff++    pp fm@(Qua _ _ _) =+        scopeFreshness $ do+            (vs,qua,fm') <- openFormulaPrefix fm+            d' <- pp fm'+            return $ sep+                     [ ppQuant qua <> ppVars vs <> operator_ "."+                     , nest 1 d']+      where+        ppVars       = fsep . map (text . show)++        ppQuant All = opForall+        ppQuant Ex  = opExists+++-- | Pretty print a logical formula+prettyLNFormula :: HighlightDocument d => LNFormula -> d+prettyLNFormula fm =+    Precise.evalFresh (prettyLFormula prettyNAtom fm) (avoidPrecise fm)+++-- Derived instances+--------------------++$( derive makeBinary ''Connective)+$( derive makeBinary ''Quantifier)+$( derive makeBinary ''Formula)++$( derive makeNFData ''Connective)+$( derive makeNFData ''Quantifier)+$( derive makeNFData ''Formula)
+ src/Theory/Model/Rule.hs view
@@ -0,0 +1,639 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeSynonymInstances       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Rewriting rules representing protocol execution and intruder deduction. Once+-- modulo the full Diffie-Hellman equational theory and once modulo AC.+module Theory.Model.Rule (+  -- * General Rules+    Rule(..)+  , PremIdx(..)+  , ConcIdx(..)++  -- ** Accessors+  , rInfo+  , rPrems+  , rConcs+  , rActs+  , rPrem+  , rConc+  , lookupPrem+  , lookupConc+  , enumPrems+  , enumConcs++  -- ** Genereal protocol and intruder rules+  , RuleInfo(..)+  , ruleInfo++  -- * Protocol Rule Information+  , ProtoRuleName(..)+  , ProtoRuleACInfo(..)+  , pracName+  , pracVariants+  , pracLoopBreakers+  , ProtoRuleACInstInfo(..)+  , praciName+  , praciLoopBreakers+  , RuleACConstrs++  -- * Intruder Rule Information+  , IntrRuleACInfo(..)++  -- * Concrete Rules+  , ProtoRuleE+  , ProtoRuleAC+  , IntrRuleAC+  , RuleAC+  , RuleACInst++  -- ** Queries+  , HasRuleName(..)+  , isIntruderRule+  , isDestrRule+  , isConstrRule+  , isFreshRule+  , isIRecvRule+  , isISendRule+  , isCoerceRule+  , nfRule+  , isTrivialProtoVariantAC++  -- ** Conversion+  , ruleACToIntrRuleAC+  , ruleACIntrToRuleAC++  -- ** Construction+  , someRuleACInst++  -- ** Unification+  , unifyRuleACInstEqs+  , unifiableRuleACInsts++  -- * Pretty-Printing+  , reservedRuleNames+  , showRuleCaseName+  , prettyProtoRuleName+  , prettyRuleName+  , prettyProtoRuleE+  , prettyProtoRuleAC+  , prettyIntrRuleAC+  , prettyIntrRuleACInfo+  , prettyRuleAC+  , prettyLoopBreakers+  , prettyRuleACInst++  )  where++import           Prelude              hiding (id, (.))++import           Data.Binary+import qualified Data.ByteString.Char8 as BC+import           Data.DeriveTH+import           Data.Foldable        (foldMap)+import           Data.Generics+import           Data.List+import           Data.Monoid+import           Safe++import           Control.Basics+import           Control.Category+import           Control.DeepSeq+import           Control.Monad.Bind+import           Control.Monad.Reader++import           Extension.Data.Label hiding (get)+import qualified Extension.Data.Label as L+import           Logic.Connectives++import           Term.LTerm+import           Term.Rewriting.Norm  (nf')+import           Term.Unification+import           Theory.Model.Fact+import           Theory.Text.Pretty++------------------------------------------------------------------------------+-- General Rule+------------------------------------------------------------------------------++-- | Rewriting rules with arbitrary additional information and facts with names+-- and logical variables.+data Rule i = Rule {+         _rInfo  :: i+       , _rPrems :: [LNFact]+       , _rConcs :: [LNFact]+       , _rActs  :: [LNFact]+       }+       deriving( Eq, Ord, Show, Data, Typeable )++$(mkLabels [''Rule])++-- | An index of a premise. The first premise has index '0'.+newtype PremIdx = PremIdx { getPremIdx :: Int }+  deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )++-- | An index of a conclusion. The first conclusion has index '0'.+newtype ConcIdx = ConcIdx { getConcIdx :: Int }+  deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )++-- | @lookupPrem i ru@ returns the @i@-th premise of rule @ru@, if possible.+lookupPrem :: PremIdx -> Rule i -> Maybe LNFact+lookupPrem i = (`atMay` getPremIdx i) . L.get rPrems++-- | @lookupConc i ru@ returns the @i@-th conclusion of rule @ru@, if possible.+lookupConc :: ConcIdx -> Rule i -> Maybe LNFact+lookupConc i = (`atMay` getConcIdx i) . L.get rConcs++-- | @rPrem i@ is a lens for the @i@-th premise of a rule.+rPrem :: PremIdx -> (Rule i :-> LNFact)+rPrem i = nthL (getPremIdx i) . rPrems++-- | @rConc i@ is a lens for the @i@-th conclusion of a rule.+rConc :: ConcIdx -> (Rule i :-> LNFact)+rConc i = nthL (getConcIdx i) . rConcs++-- | Enumerate all premises of a rule.+enumPrems :: Rule i -> [(PremIdx, LNFact)]+enumPrems = zip [(PremIdx 0)..] . L.get rPrems++-- | Enumerate all conclusions of a rule.+enumConcs :: Rule i -> [(ConcIdx, LNFact)]+enumConcs = zip [(ConcIdx 0)..] . L.get rConcs++-- Instances+------------++instance Functor Rule where+    fmap f (Rule i ps cs as) = Rule (f i) ps cs as++instance HasFrees i => HasFrees (Rule i) where+    foldFrees f (Rule i ps cs as) =+        (foldFrees f i  `mappend`) $+        (foldFrees f ps `mappend`) $+        (foldFrees f cs `mappend`) $+        (foldFrees f as)++    mapFrees f (Rule i ps cs as) =+        Rule <$> mapFrees f i+             <*> mapFrees f ps <*> mapFrees f cs <*> mapFrees f as++instance Apply i => Apply (Rule i) where+    apply subst (Rule i ps cs as) =+        Rule (apply subst i) (apply subst ps) (apply subst cs) (apply subst as)++instance Sized (Rule i) where+  size (Rule _ ps cs as) = size ps + size cs + size as++------------------------------------------------------------------------------+-- Rule information split into intruder rule and protocol rules+------------------------------------------------------------------------------++-- | Rule information for protocol and intruder rules.+data RuleInfo p i =+         ProtoInfo p+       | IntrInfo i+       deriving( Eq, Ord, Show )++-- | @ruleInfo proto intr@ maps the protocol information with @proto@ and the+-- intruder information with @intr@.+ruleInfo :: (p -> c) -> (i -> c) -> RuleInfo p i -> c+ruleInfo proto _    (ProtoInfo x) = proto x+ruleInfo _     intr (IntrInfo  x) = intr x+++-- Instances+------------++instance (HasFrees p, HasFrees i) => HasFrees (RuleInfo p i) where+    foldFrees  f = ruleInfo (foldFrees f) (foldFrees f)++    mapFrees   f = ruleInfo (fmap ProtoInfo . mapFrees   f)+                            (fmap IntrInfo . mapFrees   f)++instance (Apply p, Apply i) => Apply (RuleInfo p i) where+    apply subst = ruleInfo (ProtoInfo . apply subst) (IntrInfo . apply subst)+++------------------------------------------------------------------------------+-- Protocol Rule Information+------------------------------------------------------------------------------++-- | A name of a protocol rule is either one of the special reserved rules or+-- some standard rule.+data ProtoRuleName =+         FreshRule+       | StandRule String -- ^ Some standard protocol rule+       deriving( Eq, Ord, Show, Data, Typeable )+++-- | Information for protocol rules modulo AC. The variants list the possible+-- instantiations of the free variables of the rule. The typing is interpreted+-- modulo AC; i.e., its variants were also built.+data ProtoRuleACInfo = ProtoRuleACInfo+       { _pracName         :: ProtoRuleName+       , _pracVariants     :: Disj (LNSubstVFresh)+       , _pracLoopBreakers :: [PremIdx]+       }+       deriving( Eq, Ord, Show )++-- | Information for instances of protocol rules modulo AC.+data ProtoRuleACInstInfo = ProtoRuleACInstInfo+       { _praciName         :: ProtoRuleName+       , _praciLoopBreakers :: [PremIdx]+       }+       deriving( Eq, Ord, Show )+++$(mkLabels [''ProtoRuleACInfo, ''ProtoRuleACInstInfo])+++-- Instances+------------++instance Apply ProtoRuleName where+    apply _ = id++instance HasFrees ProtoRuleName where+    foldFrees  _ = const mempty+    mapFrees   _ = pure++instance Apply PremIdx where+    apply _ = id++instance HasFrees PremIdx where+    foldFrees  _ = const mempty+    mapFrees   _ = pure++instance Apply ConcIdx where+    apply _ = id++instance HasFrees ConcIdx where+    foldFrees  _ = const mempty+    mapFrees   _ = pure++instance HasFrees ProtoRuleACInfo where+    foldFrees f (ProtoRuleACInfo na vari breakers) =+        foldFrees f na `mappend` foldFrees f vari+                       `mappend` foldFrees f breakers++    mapFrees f (ProtoRuleACInfo na vari breakers) =+        ProtoRuleACInfo na <$> mapFrees f vari <*> mapFrees f breakers++instance Apply ProtoRuleACInstInfo where+    apply _ = id++instance HasFrees ProtoRuleACInstInfo where+    foldFrees f (ProtoRuleACInstInfo na breakers) =+        foldFrees f na `mappend` foldFrees f breakers++    mapFrees f (ProtoRuleACInstInfo na breakers) =+        ProtoRuleACInstInfo na <$> mapFrees f breakers+++------------------------------------------------------------------------------+-- Intruder Rule Information+------------------------------------------------------------------------------++-- | An intruder rule modulo AC is described by its name.+data IntrRuleACInfo =+    ConstrRule BC.ByteString+  | DestrRule BC.ByteString+  | CoerceRule+  | IRecvRule+  | ISendRule+  | PubConstrRule+  | FreshConstrRule+  deriving( Ord, Eq, Show, Data, Typeable )++-- | An intruder rule modulo AC.+type IntrRuleAC = Rule IntrRuleACInfo++-- | Converts between these two types of rules, if possible.+ruleACToIntrRuleAC :: RuleAC -> Maybe IntrRuleAC+ruleACToIntrRuleAC (Rule (IntrInfo i) ps cs as) = Just (Rule i ps cs as)+ruleACToIntrRuleAC _                            = Nothing++-- | Converts between these two types of rules.+ruleACIntrToRuleAC :: IntrRuleAC -> RuleAC+ruleACIntrToRuleAC (Rule ri ps cs as) = Rule (IntrInfo ri) ps cs as++-- Instances+------------++instance Apply IntrRuleACInfo where+    apply _ = id++instance HasFrees IntrRuleACInfo where+    foldFrees _ = const mempty+    mapFrees _  = pure+++------------------------------------------------------------------------------+-- Concrete rules+------------------------------------------------------------------------------++-- | A rule modulo E is always a protocol rule. Intruder rules are specified+-- abstractly by their operations generating them and are only available once+-- their variants are built.+type ProtoRuleE  = Rule ProtoRuleName++-- | A protocol rule modulo AC.+type ProtoRuleAC = Rule ProtoRuleACInfo++-- | A rule modulo AC is either a protocol rule or an intruder rule+type RuleAC      = Rule (RuleInfo ProtoRuleACInfo IntrRuleACInfo)++-- | A rule instance module AC is either a protocol rule or an intruder rule.+-- The info identifies the corresponding rule modulo AC that the instance was+-- derived from.+type RuleACInst  = Rule (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo)++-- Accessing the rule name+--------------------------++-- | Types that have an associated name.+class HasRuleName t where+  ruleName :: t -> RuleInfo ProtoRuleName IntrRuleACInfo++instance HasRuleName ProtoRuleE where+  ruleName = ProtoInfo . L.get rInfo++instance HasRuleName RuleAC where+  ruleName = ruleInfo (ProtoInfo . L.get pracName) IntrInfo . L.get rInfo++instance HasRuleName ProtoRuleAC where+  ruleName = ProtoInfo . L.get (pracName . rInfo)++instance HasRuleName IntrRuleAC where+  ruleName = IntrInfo . L.get rInfo++instance HasRuleName RuleACInst where+  ruleName = ruleInfo (ProtoInfo . L.get praciName) IntrInfo . L.get rInfo+++-- Queries+----------++-- | True iff the rule is a destruction rule.+isDestrRule :: HasRuleName r => r -> Bool+isDestrRule ru = case ruleName ru of+  IntrInfo (DestrRule _) -> True+  _                      -> False++-- | True iff the rule is a construction rule.+isConstrRule :: HasRuleName r => r -> Bool+isConstrRule ru = case ruleName ru of+  IntrInfo (ConstrRule _)  -> True+  IntrInfo FreshConstrRule -> True+  IntrInfo PubConstrRule   -> True+  IntrInfo CoerceRule      -> True+  _                        -> False++-- | True iff the rule is the special fresh rule.+isFreshRule :: HasRuleName r => r -> Bool+isFreshRule = (ProtoInfo FreshRule ==) . ruleName++-- | True iff the rule is the special learn rule.+isIRecvRule :: HasRuleName r => r -> Bool+isIRecvRule = (IntrInfo IRecvRule ==) . ruleName++-- | True iff the rule is the special knows rule.+isISendRule :: HasRuleName r => r -> Bool+isISendRule = (IntrInfo ISendRule ==) . ruleName++-- | True iff the rule is the special coerce rule.+isCoerceRule :: HasRuleName r => r -> Bool+isCoerceRule = (IntrInfo CoerceRule ==) . ruleName++-- | True if the messages in premises and conclusions are in normal form+nfRule :: Rule i -> WithMaude Bool+nfRule (Rule _ ps cs as) = reader $ \hnd ->+    all (nfFactList hnd) [ps, cs, as]+  where+    nfFactList hnd xs =+        getAll $ foldMap (foldMap (All . (\t -> nf' t `runReader` hnd))) xs++-- | True iff the rule is an intruder rule+isIntruderRule :: HasRuleName r => r -> Bool+isIntruderRule ru =+    case ruleName ru of IntrInfo _ -> True; ProtoInfo _ -> False++-- | True if the protocol rule has only the trivial variant.+isTrivialProtoVariantAC :: ProtoRuleAC -> ProtoRuleE -> Bool+isTrivialProtoVariantAC (Rule info ps as cs) (Rule _ ps' as' cs') =+    L.get pracVariants info == Disj [emptySubstVFresh]+    && ps == ps' && as == as' && cs == cs'+++-- Construction+---------------++type RuleACConstrs = Disj LNSubstVFresh++-- | Compute /some/ rule instance of a rule modulo AC. If the rule is a+-- protocol rule, then the given typing and variants also need to be handled.+someRuleACInst :: MonadFresh m+               => RuleAC+               -> m (RuleACInst, Maybe RuleACConstrs)+someRuleACInst =+    fmap extractInsts . rename+  where+    extractInsts (Rule (ProtoInfo i) ps cs as) =+      ( Rule (ProtoInfo i') ps cs as+      , Just (L.get pracVariants i)+      )+      where+        i' = ProtoRuleACInstInfo (L.get pracName i) (L.get pracLoopBreakers i)+    extractInsts (Rule (IntrInfo i) ps cs as) =+      ( Rule (IntrInfo i) ps cs as, Nothing )+++-- Unification+--------------++-- | Unify a list of @RuleACInst@ equalities.+unifyRuleACInstEqs :: [Equal RuleACInst] -> WithMaude [LNSubstVFresh]+unifyRuleACInstEqs eqs+  | all unifiable eqs = unifyLNFactEqs $ concatMap ruleEqs eqs+  | otherwise         = return []+  where+    unifiable (Equal ru1 ru2) =+         L.get rInfo ru1            == L.get rInfo ru2+      && length (L.get rPrems ru1) == length (L.get rPrems ru2)+      && length (L.get rConcs ru1) == length (L.get rConcs ru2)++    ruleEqs (Equal ru1 ru2) =+        zipWith Equal (L.get rPrems ru1) (L.get rPrems ru2) +++        zipWith Equal (L.get rConcs ru1) (L.get rConcs ru2)++-- | Are these two rule instances unifiable.+unifiableRuleACInsts :: RuleACInst -> RuleACInst -> WithMaude Bool+unifiableRuleACInsts ru1 ru2 =+    (not . null) <$> unifyRuleACInstEqs [Equal ru1 ru2]+++------------------------------------------------------------------------------+-- Fact analysis+------------------------------------------------------------------------------++-- | Globally unique facts.+--+-- A rule instance removes a fact fa if fa is in the rule's premise but not+-- in the rule's conclusion.+--+-- A fact symbol fa is globally fresh with respect to a dependency graph if+-- there are no two rule instances that remove the same fact built from fa.+--+-- We are looking for sufficient criterion to prove that a fact symbol is+-- globally fresh.+--+-- The Fr symbol is globally fresh by construction.+--+-- We have to track every creation of a globally fresh fact to a Fr fact.+--+-- (And show that the equality of of the created fact implies the equality of+-- the corresponding fresh facts. Ignore this for now by assuming that no+-- duplication happens.)+--+-- (fa(x1), fr(y1)), (fa(x2), fr(y2)) : x2 = x1 ==> y1 == y2+--+-- And ensure that every duplication is non-unifiable.+--+-- A Fr fact is described+--+-- We track which symbols are not globally fresh.+--+-- All persistent facts are not globally fresh.+--+-- Adding a rule ru.+--   All fact symbols that occur twice in the conclusion+--+-- For simplicity: globally fresh fact symbols occur at most once in premise+--   and conclusion of a rule.+--+-- A fact is removed by a rule if it occurs in the rules premise+--   1. but doesn't occur in the rule's conclusion+--   2. or does occur but non-unifiable.+--+-- We want a sufficient criterion to prove that a fact is globally unique.+--+--++------------------------------------------------------------------------------+-- Pretty-Printing+------------------------------------------------------------------------------++-- | Prefix the name if it is equal to a reserved name.+--+-- NOTE: We maintain the invariant that a theory does not contain standard+-- rules with a reserved name. This is a last ressort. The pretty-printed+-- theory can then not be parsed anymore.+prefixIfReserved :: String -> String+prefixIfReserved n+  | n `elem` reservedRuleNames = "_" ++ n+  | "_" `isPrefixOf` n         = "_" ++ n+  | otherwise                  = n++-- | List of all reserved rule names.+reservedRuleNames :: [String]+reservedRuleNames = ["Fresh", "irecv", "isend", "coerce", "fresh", "pub"]++prettyProtoRuleName :: Document d => ProtoRuleName -> d+prettyProtoRuleName rn = text $ case rn of+    FreshRule   -> "Fresh"+    StandRule n -> prefixIfReserved n++prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d+prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName++-- | Pretty print the rule name such that it can be used as a case name+showRuleCaseName :: HasRuleName (Rule i) => Rule i -> String+showRuleCaseName =+    render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName++prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d+prettyIntrRuleACInfo rn = text $ case rn of+    IRecvRule       -> "irecv"+    ISendRule       -> "isend"+    CoerceRule      -> "coerce"+    FreshConstrRule -> "fresh"+    PubConstrRule   -> "pub"+    ConstrRule name -> prefixIfReserved ('c' : BC.unpack name)+    DestrRule name  -> prefixIfReserved ('d' : BC.unpack name)++prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i))+                => d           -- ^ Prefix.+                -> (i -> d)    -- ^ Rule info pretty printing.+                -> Rule i -> d+prettyNamedRule prefix ppInfo ru =+    prefix <-> prettyRuleName ru <> colon $-$+    nest 2 (sep [ nest 1 $ ppFactsList rPrems+                , if null (L.get rActs ru)+                    then operator_ "-->"+                    else fsep [operator_ "--[", ppFacts rActs, operator_ "]->"]+                , nest 1 $ ppFactsList rConcs]) $-$+    nest 2 (ppInfo $ L.get rInfo ru)+  where+    ppList pp        = fsep . punctuate comma . map pp+    ppFacts proj     = ppList prettyLNFact $ L.get proj ru+    ppFactsList proj = fsep [operator_ "[", ppFacts proj, operator_ "]"]++prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d+prettyProtoRuleACInfo i =+    (ppVariants $ L.get pracVariants i) $-$+    prettyLoopBreakers i+  where+    ppVariants (Disj [subst]) | subst == emptySubstVFresh = emptyDoc+    ppVariants substs = kwVariantsModulo "AC" $-$ prettyDisjLNSubstsVFresh substs++prettyLoopBreakers :: HighlightDocument d => ProtoRuleACInfo -> d+prettyLoopBreakers i = case breakers of+    []  -> emptyDoc+    [_] -> lineComment_ $ "loop breaker: "  ++ show breakers+    _   -> lineComment_ $ "loop breakers: " ++ show breakers+  where+    breakers = getPremIdx <$> L.get pracLoopBreakers i++prettyProtoRuleE :: HighlightDocument d => ProtoRuleE -> d+prettyProtoRuleE = prettyNamedRule (kwRuleModulo "E") (const emptyDoc)++prettyRuleAC :: HighlightDocument d => RuleAC -> d+prettyRuleAC =+    prettyNamedRule (kwRuleModulo "AC")+        (ruleInfo prettyProtoRuleACInfo (const emptyDoc))++prettyIntrRuleAC :: HighlightDocument d => IntrRuleAC -> d+prettyIntrRuleAC = prettyNamedRule (kwRuleModulo "AC") (const emptyDoc)++prettyProtoRuleAC :: HighlightDocument d => ProtoRuleAC -> d+prettyProtoRuleAC = prettyNamedRule (kwRuleModulo "AC") prettyProtoRuleACInfo++prettyRuleACInst :: HighlightDocument d => RuleACInst -> d+prettyRuleACInst = prettyNamedRule (kwInstanceModulo "AC") (const emptyDoc)++-- derived instances+--------------------++$( derive makeBinary ''Rule)+$( derive makeBinary ''ProtoRuleName)+$( derive makeBinary ''ProtoRuleACInfo)+$( derive makeBinary ''ProtoRuleACInstInfo)+$( derive makeBinary ''RuleInfo)+$( derive makeBinary ''IntrRuleACInfo)++$( derive makeNFData ''Rule)+$( derive makeNFData ''ProtoRuleName)+$( derive makeNFData ''ProtoRuleACInfo)+$( derive makeNFData ''ProtoRuleACInstInfo)+$( derive makeNFData ''RuleInfo)+$( derive makeNFData ''IntrRuleACInfo)
+ src/Theory/Model/Signature.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Signatures for the terms and multiset rewriting rules used to model and+-- reason about a security protocol.+-- modulo the full Diffie-Hellman equational theory and once modulo AC.+module Theory.Model.Signature (++  -- * Signature type+    Signature(..)++  -- ** Pure signatures+  , SignaturePure+  , emptySignaturePure+  , sigpMaudeSig++  -- ** Using Maude to handle operations relative to a 'Signature'+  , SignatureWithMaude+  , toSignatureWithMaude+  , toSignaturePure+  , sigmMaudeHandle++  -- ** Pretty-printing+  , prettySignaturePure+  , prettySignatureWithMaude++  ) where++import           Data.Binary+import qualified Data.Label           as L++import           Control.Applicative+import           Control.DeepSeq++import           System.IO.Unsafe     (unsafePerformIO)++import           Term.Maude.Process   (MaudeHandle, mhFilePath, mhMaudeSig, startMaude)+import           Term.Maude.Signature (MaudeSig, minimalMaudeSig, prettyMaudeSig)+import           Theory.Text.Pretty+++-- | A theory signature.+data Signature a = Signature+       { -- The signature of the message algebra+         _sigMaudeInfo  :: a+       }++$(L.mkLabels [''Signature])+++------------------------------------------------------------------------------+-- Pure Signatures+------------------------------------------------------------------------------++-- | A 'Signature' without an associated Maude process.+type SignaturePure = Signature MaudeSig++-- | Access the maude signature.+sigpMaudeSig:: SignaturePure L.:-> MaudeSig+sigpMaudeSig = sigMaudeInfo++-- | The empty pure signature.+emptySignaturePure :: SignaturePure+emptySignaturePure = Signature minimalMaudeSig++-- Instances+------------++deriving instance Eq       SignaturePure+deriving instance Ord      SignaturePure+deriving instance Show     SignaturePure++instance Binary SignaturePure where+    put sig =  put (L.get sigMaudeInfo sig)+    get     = Signature <$> get++instance NFData SignaturePure where+  rnf (Signature y) = rnf y++------------------------------------------------------------------------------+-- Signatures with an attached Maude process+------------------------------------------------------------------------------++-- | A 'Signature' with an associated, running Maude process.+type SignatureWithMaude = Signature MaudeHandle++-- | Access the maude handle in a signature.+sigmMaudeHandle :: SignatureWithMaude L.:-> MaudeHandle+sigmMaudeHandle = sigMaudeInfo++-- | Ensure that maude is running and configured with the current signature.+toSignatureWithMaude :: FilePath            -- ^ Path to Maude executable.+                     -> SignaturePure+                     -> IO (SignatureWithMaude)+toSignatureWithMaude maudePath sig = do+    hnd <- startMaude maudePath (L.get sigMaudeInfo sig)+    return $ sig { _sigMaudeInfo = hnd }+++-- | The pure signature of a 'SignatureWithMaude'.+toSignaturePure :: SignatureWithMaude -> SignaturePure+toSignaturePure sig = sig { _sigMaudeInfo = mhMaudeSig $ L.get sigMaudeInfo sig }++{- TODO: There should be a finalizer in place such that as soon as the+   MaudeHandle is garbage collected, the appropriate command is sent to Maude++  The code below is a crutch and leads to unnecessary complication.+++-- | Stop the maude process. This operation is unsafe, as there still might be+-- thunks that rely on the MaudeHandle to refer to a running Maude process.+unsafeStopMaude :: SignatureWithMaude -> IO (SignaturePure)+unsafeStopMaude = error "unsafeStopMaude: implement"++-- | Run an IO action with maude running and configured with a specific+-- signature. As there must not be any part of the return value that depends+-- on unevaluated calls to the Maude process provided to the inner IO action.+unsafeWithMaude :: FilePath      -- ^ Path to Maude executable+                -> SignaturePure -- ^ Signature to use+                -> (SignatureWithMaude -> IO a) -> IO a+unsafeWithMaude maudePath sig  =+    bracket (startMaude maudePath sig) unsafeStopMaude++-}++-- Instances+------------++instance Eq SignatureWithMaude where+  x == y = toSignaturePure x == toSignaturePure y++instance Ord SignatureWithMaude where+  compare x y = compare (toSignaturePure x) (toSignaturePure y)++instance Show SignatureWithMaude where+  show = show . toSignaturePure++instance Binary SignatureWithMaude where+    put sig@(Signature maude) = do+        put (mhFilePath maude)+        put (toSignaturePure sig)+    -- FIXME: reload the right signature+    get = unsafePerformIO <$> (toSignatureWithMaude <$> get <*> get)++instance NFData SignatureWithMaude where+  rnf (Signature _maude) = ()++------------------------------------------------------------------------------+-- Pretty-printing+------------------------------------------------------------------------------++-- | Pretty-print a signature with maude.+prettySignaturePure :: HighlightDocument d => SignaturePure -> d+prettySignaturePure sig =+    prettyMaudeSig $ L.get sigpMaudeSig sig++-- | Pretty-print a pure signature.+prettySignatureWithMaude :: HighlightDocument d => SignatureWithMaude -> d+prettySignatureWithMaude sig =+    prettyMaudeSig $ mhMaudeSig $ L.get sigmMaudeHandle sig+
+ src/Theory/Proof.hs view
@@ -0,0 +1,654 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Types to represent proofs.+module Theory.Proof (+  -- * Utilities+    LTree(..)+  , mergeMapsWith++  -- * Types+  , ProofStep(..)+  , Proof++  -- ** Paths inside proofs+  , ProofPath+  , atPath+  , insertPaths++  -- ** Folding/modifying proofs+  , mapProofInfo+  , foldProof+  , annotateProof+  , ProofStatus(..)+  , proofStepStatus++  -- ** Unfinished proofs+  , sorry+  , unproven++  -- ** Incremental proof construction+  , IncrementalProof+  , Prover+  , runProver+  , mapProverProof++  , orelse+  , tryProver+  , sorryProver+  , oneStepProver+  , focus+  , checkAndExtendProver+  , replaceSorryProver+  , contradictionProver++  -- ** Explicit representation of a fully automatic prover+  , SolutionExtractor(..)+  , AutoProver(..)+  , runAutoProver++  -- ** Pretty Printing+  , prettyProof+  , prettyProofWith++  , showProofStatus++  -- ** Parallel Strategy for exploring a proof+  , parLTreeDFS++  -- ** Small-step interface to the constraint solver+  , module Theory.Constraint.Solver++) where++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable                    (Foldable, foldMap)+import           Data.List+import qualified Data.Map                         as M+import           Data.Maybe+import           Data.Monoid+import           Data.Traversable++import           Debug.Trace++import           Control.Basics+import           Control.DeepSeq+import qualified Control.Monad.State              as S+import           Control.Parallel.Strategies++import           Theory.Constraint.Solver+import           Theory.Model+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Utility: Trees with uniquely labelled edges.+------------------------------------------------------------------------------++-- | Trees with uniquely labelled edges.+data LTree l a = LNode+     { root     :: a+     , children :: M.Map l (LTree l a)+     }+     deriving( Eq, Ord, Show )++instance Functor (LTree l) where+    fmap f (LNode r cs) = LNode (f r) (M.map (fmap f) cs)++instance Foldable (LTree l) where+    foldMap f (LNode x cs) = f x `mappend` foldMap (foldMap f) cs++instance Traversable (LTree l) where+    traverse f (LNode x cs) = LNode <$> f x <*> traverse (traverse f) cs++-- | A parallel evaluation strategy well-suited for DFS traversal: As soon as+-- a node is forced it sparks off the computation of the number of case-maps+-- of all its children. This way most of the data is already evaulated, when+-- the actual DFS traversal visits it.+--+-- NOT used for now. It sometimes required too much memory.+parLTreeDFS :: Strategy (LTree l a)+parLTreeDFS (LNode x0 cs0) = do+    cs0' <- (`parTraversable` cs0) $ \(LNode x cs) -> LNode x <$> rseq cs+    return $ LNode x0 (M.map (runEval . parLTreeDFS) cs0')++------------------------------------------------------------------------------+-- Utility: Merging maps+------------------------------------------------------------------------------++-- | /O(n+m)/. A generalized union operator for maps with differing types.+mergeMapsWith :: Ord k+              => (a -> c) -> (b -> c) -> (a -> b -> c)+              -> M.Map k a -> M.Map k b -> M.Map k c+mergeMapsWith leftOnly rightOnly combine l r =+    M.map extract $ M.unionWith combine' l' r'+  where+    l' = M.map (Left . Left)  l+    r' = M.map (Left . Right) r++    combine' (Left (Left a)) (Left (Right b)) = Right $ combine a b+    combine' _ _ = error "mergeMapsWith: impossible"++    extract (Left (Left  a)) = leftOnly  a+    extract (Left (Right b)) = rightOnly b+    extract (Right c)        = c+++------------------------------------------------------------------------------+-- Proof Steps+------------------------------------------------------------------------------++-- | A proof steps is a proof method together with additional context-dependent+-- information.+data ProofStep a = ProofStep+     { psMethod :: ProofMethod+     , psInfo   :: a+     }+     deriving( Eq, Ord, Show )++instance Functor ProofStep where+    fmap f (ProofStep m i) = ProofStep m (f i)++instance Foldable ProofStep where+    foldMap f = f . psInfo++instance Traversable ProofStep where+    traverse f (ProofStep m i) = ProofStep m <$> f i++instance HasFrees a => HasFrees (ProofStep a) where+    foldFrees f (ProofStep m i) = foldFrees f m `mappend` foldFrees f i+    mapFrees f (ProofStep m i)  = ProofStep <$> mapFrees f m <*> mapFrees f i++------------------------------------------------------------------------------+-- Proof Trees+------------------------------------------------------------------------------++-- | A path to a subproof.+type ProofPath = [CaseName]++-- | A proof is a tree of proof steps whose edges are labelled with case names.+type Proof a = LTree CaseName (ProofStep a)++-- Unfinished proofs+--------------------++-- | A proof using the 'sorry' proof method.+sorry :: Maybe String -> a -> Proof a+sorry reason ann = LNode (ProofStep (Sorry reason) ann) M.empty++-- | A proof denoting an unproven part of the proof.+unproven :: a -> Proof a+unproven = sorry Nothing+++-- Paths in proofs+------------------++-- | @prf `atPath` path@ returns the subproof at the @path@ in @prf@.+atPath :: Proof a -> ProofPath -> Maybe (Proof a)+atPath = foldM (flip M.lookup . children)++-- | @modifyAtPath f path prf@ applies @f@ to the subproof at @path@,+-- if there is one.+modifyAtPath :: (Proof a -> Maybe (Proof a)) -> ProofPath+             -> Proof a -> Maybe (Proof a)+modifyAtPath f =+    go+  where+    go []     prf = f prf+    go (l:ls) prf = do+        let cs = children prf+        prf' <- go ls =<< M.lookup l cs+        return (prf { children = M.insert l prf' cs })++-- | @insertPaths prf@ inserts the path to every proof node.+insertPaths :: Proof a -> Proof (a, ProofPath)+insertPaths =+    insertPath []+  where+    insertPath path (LNode ps cs) =+        LNode (fmap (,reverse path) ps)+              (M.mapWithKey (\n prf -> insertPath (n:path) prf) cs)+++-- Utilities for dealing with proofs+------------------------------------+++-- | Apply a function to the information of every proof step.+mapProofInfo :: (a -> b) -> Proof a -> Proof b+mapProofInfo = fmap . fmap++-- | @boundProofDepth bound prf@ bounds the depth of the proof @prf@ using+-- 'Sorry' steps to replace the cut sub-proofs.+boundProofDepth :: Int -> Proof a -> Proof a+boundProofDepth bound =+    go bound+  where+    go n (LNode ps@(ProofStep _ info) cs)+      | 0 < n     = LNode ps                     $ M.map (go (pred n)) cs+      | otherwise = sorry (Just $ "bound " ++ show bound ++ " hit") info++-- | Fold a proof.+foldProof :: Monoid m => (ProofStep a -> m) -> Proof a -> m+foldProof f =+    go+  where+    go (LNode step cs) = f step `mappend` foldMap go (M.elems cs)++-- | Annotate a proof in a bottom-up fashion.+annotateProof :: (ProofStep a -> [b] -> b) -> Proof a -> Proof b+annotateProof f =+    go+  where+    go (LNode step@(ProofStep method _) cs) =+        LNode (ProofStep method info') cs'+      where+        cs' = M.map go cs+        info' = f step (map (psInfo . root . snd) (M.toList cs'))++-- Proof cutting+----------------++-- | The status of a 'Proof'.+data ProofStatus =+         UndeterminedProof  -- ^ All steps are unannotated+       | CompleteProof      -- ^ The proof is complete: no annotated sorry,+                            --  no annotated solved step+       | IncompleteProof    -- ^ There is a annotated sorry,+                            --   but no annotatd solved step.+       | TraceFound         -- ^ There is an annotated solved step++instance Monoid ProofStatus where+    mempty = CompleteProof++    mappend TraceFound _                        = TraceFound+    mappend _ TraceFound                        = TraceFound+    mappend IncompleteProof _                   = IncompleteProof+    mappend _ IncompleteProof                   = IncompleteProof+    mappend _ CompleteProof                     = CompleteProof+    mappend CompleteProof _                     = CompleteProof+    mappend UndeterminedProof UndeterminedProof = UndeterminedProof++-- | The status of a 'ProofStep'.+proofStepStatus :: ProofStep (Maybe a) -> ProofStatus+proofStepStatus (ProofStep _         Nothing ) = UndeterminedProof+proofStepStatus (ProofStep Solved    (Just _)) = TraceFound+proofStepStatus (ProofStep (Sorry _) (Just _)) = IncompleteProof+proofStepStatus (ProofStep _         (Just _)) = CompleteProof+++{- TODO: Test and probably improve++-- | @proveSystem rules se@ tries to construct a proof that @se@ is valid.+-- This proof may contain 'Sorry' steps, if the prover is stuck. It can also be+-- of infinite depth, if the proof strategy loops.+proveSystemIterDeep :: ProofContext -> System -> Proof System+proveSystemIterDeep rules se0 =+    fromJust $ asum $ map (prove se0 . round) $ iterate (*1.5) (3::Double)+  where+    prove :: System -> Int -> Maybe (Proof System)+    prove se bound+      | bound < 0 = Nothing+      | otherwise =+          case next of+            [] -> pure $ sorry "prover stuck => possible attack found" se+            xs -> asum $ map mkProof xs+      where+        next = do m <- possibleProofMethods se+                  (m,) <$> maybe mzero return (execProofMethod rules m se)+        mkProof (method, cases) =+            LNode (ProofStep method se) <$> traverse (`prove` (bound - 1)) cases+-}++-- | @checkProof rules se prf@ replays the proof @prf@ against the start+-- sequent @se@. A failure to apply a proof method is denoted by a resulting+-- proof step without an annotated sequent. An unhandled case is denoted using+-- the 'Sorry' proof method.+checkProof :: ProofContext+           -> (Int -> System -> Proof (Maybe System)) -- prover for new cases in depth+           -> Int         -- ^ Original depth+           -> System+           -> Proof a+           -> Proof (Maybe a, Maybe System)+checkProof ctxt prover d sys prf@(LNode (ProofStep method info) cs) =+    case (method, execProofMethod ctxt method sys) of+        (Sorry reason, _         ) -> sorryNode reason cs+        (_           , Just cases) -> node method $ checkChildren cases+        (_           , Nothing   ) ->+            sorryNode (Just "invalid proof step encountered")+                      (M.singleton "" prf)+  where+    node m                 = LNode (ProofStep m (Just info, Just sys))+    sorryNode reason cases = node (Sorry reason) (M.map noSystemPrf cases)+    noSystemPrf            = mapProofInfo (\i -> (Just i, Nothing))++    checkChildren cases = mergeMapsWith+        unhandledCase noSystemPrf (checkProof ctxt prover (d + 1)) cases cs+      where+        unhandledCase = mapProofInfo ((,) Nothing) . prover d++-- | Annotate a proof with the constraint systems of all intermediate steps+-- under the assumption that all proof steps are valid. If some proof steps+-- might be invalid, then you must use 'checkProof', which handles them+-- gracefully.+annotateWithSystems :: ProofContext -> System -> Proof () -> Proof System+annotateWithSystems ctxt =+    go+  where+    -- Here we are careful to construct the result such that an inspection of+    -- the proof does not force the recomputed constraint systems.+    go sysOrig (LNode (ProofStep method _) csOrig) =+      LNode (ProofStep method sysOrig) $ M.fromList $ do+          (name, prf) <- M.toList csOrig+          let sysAnn = extract ("case '" ++ name ++ "' non-existent") $+                       M.lookup name csAnn+          return (name, go sysAnn prf)+      where+        extract msg = fromMaybe (error $ "annotateWithSystems: " ++ msg)+        csAnn       = extract "proof method execution failed" $+                      execProofMethod ctxt method sysOrig+++------------------------------------------------------------------------------+-- Provers: the interface to the outside world.+------------------------------------------------------------------------------++-- | Incremental proofs are used to represent intermediate results of proof+-- checking/construction.+type IncrementalProof = Proof (Maybe System)++-- | Provers whose sequencing is handled via the 'Monoid' instance.+--+-- > p1 `mappend` p2+--+-- Is a prover that first runs p1 and then p2 on the resulting proof.+newtype Prover =  Prover+          { runProver+              :: ProofContext              -- proof rules to use+              -> Int                       -- proof depth+              -> System                    -- original sequent to start with+              -> IncrementalProof          -- original proof+              -> Maybe IncrementalProof    -- resulting proof+          }++instance Monoid Prover where+    mempty          = Prover $ \_  _ _ -> Just+    p1 `mappend` p2 = Prover $ \ctxt d se ->+        runProver p1 ctxt d se >=> runProver p2 ctxt d se++-- | Map the proof generated by the prover.+mapProverProof :: (IncrementalProof -> IncrementalProof) -> Prover -> Prover+mapProverProof f p = Prover $ \ ctxt d se prf -> f <$> runProver p ctxt d se prf++-- | Prover that always fails.+failProver :: Prover+failProver = Prover (\ _ _ _ _ -> Nothing)++-- | Resorts to the second prover, if the first one is not successful.+orelse :: Prover -> Prover -> Prover+orelse p1 p2 = Prover $ \ctxt d se prf ->+    runProver p1 ctxt d se prf `mplus` runProver p2 ctxt d se prf++-- | Try to apply a prover. If it fails, just return the original proof.+tryProver :: Prover -> Prover+tryProver =  (`orelse` mempty)++-- | Try to execute one proof step using the given proof method.+oneStepProver :: ProofMethod -> Prover+oneStepProver method = Prover $ \ctxt _ se _ -> do+    cases <- execProofMethod ctxt method se+    return $ LNode (ProofStep method (Just se)) (M.map (unproven . Just) cases)++-- | Replace the current proof with a sorry step and the given reason.+sorryProver :: Maybe String -> Prover+sorryProver reason = Prover $ \_ _ se _ -> return $ sorry reason (Just se)++-- | Apply a prover only to a sub-proof, fails if the subproof doesn't exist.+focus :: ProofPath -> Prover -> Prover+focus []   prover = prover+focus path prover =+    Prover $ \ctxt d _ prf ->+        modifyAtPath (prover' ctxt (d + length path)) path prf+  where+    prover' ctxt d prf = do+        se <- psInfo (root prf)+        runProver prover ctxt d se prf++-- | Check the proof and handle new cases using the given prover.+checkAndExtendProver :: Prover -> Prover+checkAndExtendProver prover0 = Prover $ \ctxt d se prf ->+    return $ mapProofInfo snd $ checkProof ctxt (prover ctxt) d se prf+  where+    unhandledCase   = sorry (Just "unhandled case") Nothing+    prover ctxt d se =+        fromMaybe unhandledCase $ runProver prover0 ctxt d se unhandledCase++-- | Replace all annotated sorry steps using the given prover.+replaceSorryProver :: Prover -> Prover+replaceSorryProver prover0 = Prover prover+  where+    prover ctxt d _ = return . replace+      where+        replace prf@(LNode (ProofStep (Sorry _) (Just se)) _) =+            fromMaybe prf $ runProver prover0 ctxt d se prf+        replace (LNode ps cases) =+            LNode ps $ M.map replace cases+++-- | Use the first prover that works.+firstProver :: [Prover] -> Prover+firstProver = foldr orelse failProver++-- | Prover that does one contradiction step.+contradictionProver :: Prover+contradictionProver = Prover $ \ctxt d sys prf ->+    runProver+        (firstProver $ map oneStepProver $+            (Contradiction . Just <$> contradictions ctxt sys))+        ctxt d sys prf++------------------------------------------------------------------------------+-- Automatic Prover's+------------------------------------------------------------------------------++data SolutionExtractor = CutDFS | CutBFS | CutNothing+    deriving( Eq, Ord, Show, Read )++data AutoProver = AutoProver+    { apHeuristic :: Heuristic+    , apBound     :: Maybe Int+    , apCut       :: SolutionExtractor+    }++runAutoProver :: AutoProver -> Prover+runAutoProver (AutoProver heuristic bound cut) =+    mapProverProof cutSolved $ maybe id boundProver bound autoProver+  where+    cutSolved = case cut of+      CutDFS     -> cutOnSolvedDFS+      CutBFS     -> cutOnSolvedBFS+      CutNothing -> id++    -- | The standard automatic prover that ignores the existing proof and+    -- tries to find one by itself.+    autoProver :: Prover+    autoProver = Prover $ \ctxt depth sys _ ->+        return $ fmap (fmap Just)+               $ annotateWithSystems ctxt sys+               $ proveSystemDFS heuristic ctxt depth sys++    -- | Bound the depth of proofs generated by the given prover.+    boundProver :: Int -> Prover -> Prover+    boundProver b p = Prover $ \ctxt d se prf ->+        boundProofDepth b <$> runProver p ctxt d se prf+++-- | The result of one pass of iterative deepening.+data IterDeepRes = NoSolution | MaybeNoSolution | Solution ProofPath++instance Monoid IterDeepRes where+    mempty = NoSolution++    x@(Solution _)   `mappend` _                = x+    _                `mappend` y@(Solution _)   = y+    MaybeNoSolution  `mappend` _                = MaybeNoSolution+    _                `mappend` MaybeNoSolution  = MaybeNoSolution+    NoSolution       `mappend` NoSolution       = NoSolution++-- | @cutOnSolvedDFS prf@ removes all other cases if an attack is found. The+-- attack search is performed using a parallel DFS traversal with iterative+-- deepening.+--+-- FIXME: Note that this function may use a lot of space, as it holds onto the+-- whole proof tree.+cutOnSolvedDFS :: Proof (Maybe a) -> Proof (Maybe a)+cutOnSolvedDFS prf0 =+    go (4 :: Integer) $ insertPaths prf0+  where+    go dMax prf = case findSolved 0 prf of+        NoSolution      -> prf0+        MaybeNoSolution -> go (2 * dMax) prf+        Solution path   -> extractSolved path prf0+      where+        findSolved d node+          | d >= dMax = MaybeNoSolution+          | otherwise = case node of+              -- do not search in nodes that are not annotated+              LNode (ProofStep _      (Nothing, _   )) _  -> NoSolution+              LNode (ProofStep Solved (Just _ , path)) _  -> Solution path+              LNode (ProofStep _      (Just _ , _   )) cs ->+                  foldMap (findSolved (succ d))+                      (cs `using` parTraversable nfProofMethod)++        nfProofMethod node = do+            void $ rseq (psMethod $ root node)+            void $ rseq (psInfo   $ root node)+            void $ rseq (children node)+            return node++    extractSolved []         p               = p+    extractSolved (label:ps) (LNode pstep m) = case M.lookup label m of+        Just subprf ->+          LNode pstep (M.fromList [(label, extractSolved ps subprf)])+        Nothing     ->+          error "Theory.Constraint.cutOnSolvedDFS: impossible, extractSolved failed, invalid path"++-- | Search for attacks in a BFS manner.+cutOnSolvedBFS :: Proof (Maybe a) -> Proof (Maybe a)+cutOnSolvedBFS =+    go (1::Int)+  where+    go l prf =+      -- FIXME: See if that poor man's logging could be done better.+      trace ("searching for attacks at depth: " ++ show l) $+        case S.runState (checkLevel l prf) CompleteProof of+          (_, UndeterminedProof) -> error "cutOnSolvedBFS: impossible"+          (_, CompleteProof)     -> prf+          (_, IncompleteProof)   -> go (l+1) prf+          (prf', TraceFound)     ->+              trace ("attack found at depth: " ++ show l) prf'++    checkLevel 0 (LNode  step@(ProofStep Solved (Just _)) _) =+        S.put TraceFound >> return (LNode step M.empty)+    checkLevel 0 prf@(LNode (ProofStep _ x) cs)+      | M.null cs = return prf+      | otherwise = do+          st <- S.get+          msg <- case st of+              TraceFound -> return $ "ignored (attack exists)"+              _           -> S.put IncompleteProof >> return "bound reached"+          return $ LNode (ProofStep (Sorry (Just msg)) x) M.empty+    checkLevel l prf@(LNode step cs)+      | isNothing (psInfo step) = return prf+      | otherwise               = LNode step <$> traverse (checkLevel (l-1)) cs+++-- | @proveSystemDFS rules se@ explores all solutions of the initial+-- constraint system using a depth-first-search strategy to resolve the+-- non-determinism wrt. what goal to solve next.  This proof can be of+-- infinite depth, if the proof strategy loops.+--+-- Use 'annotateWithSystems' to annotate the proof tree with the constraint+-- systems.+proveSystemDFS :: Heuristic -> ProofContext -> Int -> System -> Proof ()+proveSystemDFS heuristic ctxt d0 sys0 =+    prove d0 sys0+  where+    prove !depth sys =+        case rankProofMethods (useHeuristic heuristic depth) ctxt sys of+          []                         -> node Solved M.empty+          (method, (cases, _expl)):_ -> node method cases+      where+        node method cases =+          LNode (ProofStep method ()) (M.map (prove (succ depth)) cases)+++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------+++prettyProof :: HighlightDocument d => Proof a -> d+prettyProof = prettyProofWith (prettyProofMethod . psMethod) (const id)++prettyProofWith :: HighlightDocument d+                => (ProofStep a -> d)      -- ^ Make proof step pretty+                -> (ProofStep a -> d -> d) -- ^ Make whole case pretty+                -> Proof a                 -- ^ The proof to prettify+                -> d+prettyProofWith prettyStep prettyCase =+    ppPrf+  where+    ppPrf (LNode ps cs) = ppCases ps (M.toList cs)++    ppCases ps@(ProofStep Solved _) [] = prettyStep ps+    ppCases ps []                      = prettyCase ps (kwBy <> text " ")+                                           <> prettyStep ps+    ppCases ps [("", prf)]             = prettyStep ps $-$ ppPrf prf+    ppCases ps cases                   =+        prettyStep ps $-$+        (vcat $ intersperse (prettyCase ps kwNext) $ map ppCase cases) $-$+        prettyCase ps kwQED++    ppCase (name, prf) = nest 2 $+      (prettyCase (root prf) $ kwCase <-> text name) $-$+      ppPrf prf++-- | Convert a proof status to a redable string.+showProofStatus :: SystemTraceQuantifier -> ProofStatus -> String+showProofStatus ExistsNoTrace   TraceFound        = "falsified - found trace"+showProofStatus ExistsNoTrace   CompleteProof     = "verified"+showProofStatus ExistsSomeTrace CompleteProof     = "falsified - no trace found"+showProofStatus ExistsSomeTrace TraceFound        = "verified"+showProofStatus _               IncompleteProof   = "analysis incomplete"+showProofStatus _               UndeterminedProof = "analysis undetermined"+++-- Derived instances+--------------------++$( derive makeBinary ''ProofStep)+$( derive makeBinary ''ProofStatus)+$( derive makeBinary ''SolutionExtractor)+$( derive makeBinary ''AutoProver)++$( derive makeNFData ''ProofStep)+$( derive makeNFData ''ProofStatus)+$( derive makeNFData ''SolutionExtractor)+$( derive makeNFData ''AutoProver)++instance (Ord l, NFData l, NFData a) => NFData (LTree l a) where+  rnf (LNode r m) = rnf r `seq` rnf  m++instance (Ord l, Binary l, Binary a) => Binary (LTree l a) where+  put (LNode r m) = put r >> put m+  get = LNode <$> get <*> get
+ src/Theory/Text/Parser.hs view
@@ -0,0 +1,634 @@+-- |+-- Copyright   : (c) 2010-2012 Simon Meier, Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Parsing protocol theories. See the MANUAL for a high-level description of+-- the syntax.+module Theory.Text.Parser (+    parseOpenTheory+  , parseOpenTheoryString+  , parseLemma+  , parseIntruderRulesDH+  ) where++import           Prelude                    hiding (id, (.))++import qualified Data.ByteString.Char8      as BC+import           Data.Char                  (isUpper, toUpper)+import           Data.Foldable              (asum)+import           Data.Label+import qualified Data.Map                   as M+import           Data.Monoid                hiding (Last)+import qualified Data.Set                   as S++import           Control.Applicative        hiding (empty, many, optional)+import           Control.Category+import           Control.Monad++import           Text.Parsec                hiding ((<|>))+import           Text.PrettyPrint.Class     (render)++import           Term.Substitution+import           Term.SubtermRule+import           Theory+import           Theory.Text.Parser.Token+++++++------------------------------------------------------------------------------+-- Lexing and parsing theory files and proof methods+------------------------------------------------------------------------------++-- | Parse a security protocol theory file.+parseOpenTheory :: [String] -- ^ Defined flags+                -> FilePath -> IO OpenTheory+parseOpenTheory flags = parseFile (theory flags)++-- | Parse DH intruder rules.+parseIntruderRulesDH :: FilePath -> IO [IntrRuleAC]+parseIntruderRulesDH = parseFile (setState dhMaudeSig >> many intrRule)++-- | Parse a security protocol theory from a string.+parseOpenTheoryString :: [String]  -- ^ Defined flags.+                      -> String -> Either ParseError OpenTheory+parseOpenTheoryString flags = parseFromString (theory flags)++-- | Parse a lemma for an open theory from a string.+parseLemma :: String -> Either ParseError (Lemma ProofSkeleton)+parseLemma = parseFromString lemma++------------------------------------------------------------------------------+-- Parsing Terms+------------------------------------------------------------------------------++-- | Parse an lit with logical variables.+llit :: Parser LNTerm+llit = asum [freshTerm <$> freshName, pubTerm <$> pubName, varTerm <$> msgvar]++-- | Lookup the arity of a non-ac symbol. Fails with a sensible error message+-- if the operator is not known.+lookupNonACArity :: String -> Parser Int+lookupNonACArity op = do+    maudeSig <- getState+    case lookup (BC.pack op) (S.toList $ allFunctionSymbols maudeSig) of+        Nothing -> fail $ "unknown operator `" ++ op ++ "'"+        Just k  -> return k++-- | Parse an n-ary operator application for arbitrary n.+naryOpApp :: Ord l => Parser (Term l) -> Parser (Term l)+naryOpApp plit = do+    op <- identifier+    k  <- lookupNonACArity op+    ts <- parens $ if k == 1+                     then return <$> tupleterm plit+                     else commaSep (multterm plit)+    let k' = length ts+    when (k /= k') $+        fail $ "operator `" ++ op ++"' has arity " ++ show k +++               ", but here it is used with arity " ++ show k'+    return $ fAppNonAC (BC.pack op, k') ts++-- | Parse a binary operator written as @op{arg1}arg2@.+binaryAlgApp :: Ord l => Parser (Term l) -> Parser (Term l)+binaryAlgApp plit = do+    op <- identifier+    k <- lookupNonACArity op+    arg1 <- braced (tupleterm plit)+    arg2 <- term plit+    when (k /= 2) $ fail $+      "only operators of arity 2 can be written using the `op{t1}t2' notation"+    return $ fAppNonAC (BC.pack op, 2) [arg1, arg2]++-- | Parse a term.+term :: Ord l => Parser (Term l) -> Parser (Term l)+term plit = asum+    [ pairing       <?> "pairs"+    , parens (multterm plit)+    , symbol "1" *> pure fAppOne+    , application <?> "function application"+    , nullaryApp+    , plit+    ]+    <?> "term"+  where+    application = asum $ map (try . ($ plit)) [naryOpApp, binaryAlgApp]+    pairing = angled (tupleterm plit)+    nullaryApp = do+      maudeSig <- getState+      -- FIXME: This try should not be necessary.+      asum [ try (symbol (BC.unpack sym)) *> pure (fApp (NonAC (sym,0)) [])+           | (sym,0) <- S.toList $ allFunctionSymbols maudeSig ]++-- | A left-associative sequence of exponentations.+expterm :: Ord l => Parser (Term l) -> Parser (Term l)+expterm plit = chainl1 (term plit) ((\a b -> fAppExp (a,b)) <$ opExp)++-- | A left-associative sequence of multiplications.+multterm :: Ord l => Parser (Term l) -> Parser (Term l)+multterm plit = do+    dh <- enableDH <$> getState+    if dh -- if DH is not enabled, do not accept 'multterm's and 'expterm's+        then chainl1 (expterm plit) ((\a b -> fAppMult [a,b]) <$ opMult)+        else term plit++-- | A right-associative sequence of tuples.+tupleterm :: Ord l => Parser (Term l) -> Parser (Term l)+tupleterm plit = chainr1 (multterm plit) ((\a b -> fAppPair (a,b)) <$ comma)++-- | Parse a fact.+fact :: Ord l => Parser (Term l) -> Parser (Fact (Term l))+fact plit = try (+    do multi <- option Linear (opBang *> pure Persistent)+       i     <- identifier+       case i of+         []                -> fail "empty identifier"+         (c:_) | isUpper c -> return ()+               | otherwise -> fail "facts must start with upper-case letters"+       ts    <- parens (commaSep (multterm plit))+       mkProtoFact multi i ts+    <?> "fact" )+  where+    singleTerm _ constr [t] = return $ constr t+    singleTerm f _      ts  = fail $ "fact '" ++ f ++ "' used with arity " +++                                     show (length ts) ++ " instead of arity one"++    mkProtoFact multi f = case map toUpper f of+      "OUT" -> singleTerm f outFact+      "IN"  -> singleTerm f inFact+      "KU"  -> singleTerm f kuFact+      "KD"  -> return . Fact KDFact+      "DED" -> return . Fact DedFact+      "FR"  -> singleTerm f freshFact+      _     -> return . protoFact multi f+++------------------------------------------------------------------------------+-- Parsing Rules+------------------------------------------------------------------------------++-- | Parse a "(modulo ..)" information.+modulo :: String -> Parser ()+modulo thy = parens $ symbol_ "modulo" *> symbol_ thy++moduloE, moduloAC :: Parser ()+moduloE  = modulo "E"+moduloAC = modulo "AC"++{-+-- | Parse a typing assertion modulo E.+typeAssertions :: Parser TypingE+typeAssertions = fmap TypingE $+    do try (symbols ["type", "assertions"])+       optional moduloE+       colon+       many1 ((,) <$> (try (msgvar <* colon))+                  <*> ( commaSep1 (try $ multterm llit) <|>+                        (opMinus *> pure [])+                      )+             )+    <|> pure []+-}++-- | Parse a protocol rule. For the special rules 'Reveal_fresh', 'Fresh',+-- 'Knows', and 'Learn' no rule is returned as the default theory already+-- contains them.+protoRule :: Parser (ProtoRuleE)+protoRule = do+    name  <- try (symbol "rule" *> optional moduloE *> identifier <* colon)+    when (name `elem` reservedRuleNames) $+        fail $ "cannot use reserved rule name '" ++ name ++ "'"+    subst <- option emptySubst letBlock+    (ps,as,cs) <- genericRule+    return $ apply subst $ Rule (StandRule name) ps cs as++-- | Parse a let block with bottom-up application semantics.+letBlock :: Parser LNSubst+letBlock = do+    toSubst <$> (symbol "let" *> many1 definition <* symbol "in")+  where+    toSubst = foldr1 compose . map (substFromList . return)+    definition = (,) <$> (sortedLVar [LSortMsg] <* equalSign) <*> multterm llit++-- | Parse an intruder rule.+intrRule :: Parser IntrRuleAC+intrRule = do+    info <- try (symbol "rule" *> moduloAC *> intrInfo <* colon)+    (ps,as,cs) <- genericRule+    return $ Rule info ps cs as+  where+    intrInfo = do+        name <- identifier+        case name of+          'c':cname -> return $ ConstrRule (BC.pack cname)+          'd':dname -> return $ DestrRule (BC.pack dname)+          _         -> fail $ "invalid intruder rule name '" ++ name ++ "'"++genericRule :: Parser ([LNFact], [LNFact], [LNFact])+genericRule =+    (,,) <$> list (fact llit)+         <*> ((pure [] <* symbol "-->") <|>+              (symbol "--[" *> commaSep (fact llit) <* symbol "]->"))+         <*> list (fact llit)++{-+-- | Add facts to a rule.+addFacts :: String        -- ^ Command to be used: add_concs, add_prems+         -> Parser (String, [LNFact])+addFacts cmd =+    (,) <$> (symbol cmd *> identifier <* colon) <*> commaSep1 fact+-}++------------------------------------------------------------------------------+-- Parsing transfer notation+------------------------------------------------------------------------------++{-+-- | Parse an lit with strings for both constants as well as variables.+tlit :: Parser TTerm+tlit = asum+    [ constTerm <$> singleQuoted identifier+    , varTerm  <$> identifier+    ]++-- | Parse a single transfer.+transfer :: Parser Transfer+transfer = do+  tf <- (\l -> Transfer l Nothing Nothing) <$> identifier <* kw DOT+  (do right <- kw RIGHTARROW *> identifier <* colon+      desc <- transferDesc+      return $ tf { tfRecv = Just (desc right) }+   <|>+   do right <- kw LEFTARROW *> identifier <* colon+      descr <- transferDesc+      (do left <- try $ identifier <* kw LEFTARROW <* colon+          descl <- transferDesc+          return $ tf { tfSend = Just (descr right)+                      , tfRecv = Just (descl left) }+       <|>+       do return $ tf { tfSend = Just (descr right) }+       )+   <|>+   do left <- identifier+      (do kw RIGHTARROW+          (do right <- identifier <* colon+              desc <- transferDesc+              return $ tf { tfSend = Just (desc left)+                          , tfRecv = Just (desc right) }+           <|>+           do descl <- colon *> transferDesc+              (do right <- kw RIGHTARROW *> identifier <* colon+                  descr <- transferDesc+                  return $ tf { tfSend = Just (descl left)+                              , tfRecv = Just (descr right) }+               <|>+               do return $ tf { tfSend = Just (descl left) }+               )+           )+       <|>+       do kw LEFTARROW+          (do desc <- colon *> transferDesc+              return $ tf { tfRecv = Just (desc left) }+           <|>+           do right <- identifier <* colon+              desc <- transferDesc+              return $ tf { tfSend = Just (desc right)+                          , tfRecv = Just (desc left) }+           )+       )+    )+  where+    transferDesc = do+        ts        <- tupleterm tlit+        moreConcs <- (symbol "note" *> many1 (try $ fact tlit))+                     <|> pure []+        types     <- typeAssertions+        return $ \a -> TransferDesc a ts moreConcs types+++-- | Parse a protocol in transfer notation+transferProto :: Parser [ProtoRuleE]+transferProto = do+    name <- symbol "anb-proto" *> identifier+    braced (convTransferProto name <$> abbrevs <*> many1 transfer)+  where+    abbrevs = (symbol "let" *> many1 abbrev) <|> pure []+    abbrev = (,) <$> try (identifier <* kw EQUAL) <*> multterm tlit++-}++------------------------------------------------------------------------------+-- Parsing Standard and Guarded Formulas+------------------------------------------------------------------------------++-- | Parse an atom with possibly bound logical variables.+blatom :: Parser BLAtom+blatom = (fmap (fmapTerm (fmap Free))) <$> asum+  [ Last        <$> try (symbol "last" *> parens nodevarTerm)        <?> "last atom"+  , flip Action <$> try (fact llit <* opAt)        <*> nodevarTerm   <?> "action atom"+  , Less        <$> try (nodevarTerm <* opLess)    <*> nodevarTerm   <?> "less atom"+  , EqE         <$> try (multterm llit <* opEqual) <*> multterm llit <?> "term equality"+  , EqE         <$>     (nodevarTerm  <* opEqual)  <*> nodevarTerm   <?> "node equality"+  ]+  where+    nodevarTerm = (lit . Var) <$> nodevar++-- | Parse an atom of a formula.+fatom :: Parser LNFormula+fatom = asum+  [ pure lfalse <* opLFalse+  , pure ltrue  <* opLTrue+  , Ato <$> try blatom+  , quantification+  , parens iff+  ]+  where+    quantification = do+        q <- (pure forall <* opForall) <|> (pure exists <* opExists)+        vs <- many1 lvar <* dot+        f  <- iff+        return $ foldr (hinted q) f vs++    hinted :: ((String, LSort) -> LVar -> a) -> LVar -> a+    hinted f v@(LVar n s _) = f (n,s) v++++-- | Parse a negation.+negation :: Parser LNFormula+negation = opLNot *> (Not <$> fatom) <|> fatom++-- | Parse a left-associative sequence of conjunctions.+conjuncts :: Parser LNFormula+conjuncts = chainl1 negation ((.&&.) <$ opLAnd)++-- | Parse a left-associative sequence of disjunctions.+disjuncts :: Parser LNFormula+disjuncts = chainl1 conjuncts ((.||.) <$ opLOr)++-- | An implication.+imp :: Parser LNFormula+imp = do+  lhs <- disjuncts+  asum [ opImplies *> ((lhs .==>.) <$> imp)+       , pure lhs ]++-- | An logical equivalence.+iff :: Parser LNFormula+iff = do+  lhs <- imp+  asum [opLEquiv *> ((lhs .<=>.) <$> imp), pure lhs ]++-- | Parse a standard formula.+standardFormula :: Parser LNFormula+standardFormula = iff++-- | Parse a guarded formula using the hack of parsing a standard formula and+-- converting it afterwards.+--+-- FIXME: Write a proper parser.+guardedFormula :: Parser LNGuarded+guardedFormula = try $ do+    res <- formulaToGuarded <$> standardFormula+    case res of+        Left d   -> fail $ render d+        Right gf -> return gf+++------------------------------------------------------------------------------+-- Parsing Axioms+------------------------------------------------------------------------------++-- | Parse an axiom.+axiom :: Parser Axiom+axiom = Axiom <$> (symbol "axiom" *> identifier <* colon)+              <*> doubleQuoted standardFormula+++------------------------------------------------------------------------------+-- Parsing Lemmas+------------------------------------------------------------------------------++-- | Parse a 'LemmaAttribute'.+lemmaAttribute :: Parser LemmaAttribute+lemmaAttribute = asum+  [ symbol "typing"        *> pure TypingLemma+  , symbol "reuse"         *> pure ReuseLemma+  , symbol "use_induction" *> pure InvariantLemma+  ]++-- | Parse a 'TraceQuantifier'.+traceQuantifier :: Parser TraceQuantifier+traceQuantifier = asum+  [ symbol "all-traces" *> pure AllTraces+  , symbol "exists-trace"  *> pure ExistsTrace+  ]++-- | Parse a lemma.+lemma :: Parser (Lemma ProofSkeleton)+lemma = skeletonLemma <$> (symbol "lemma" *> optional moduloE *> identifier)+                      <*> (option [] $ list lemmaAttribute)+                      <*> (colon *> option AllTraces traceQuantifier)+                      <*> doubleQuoted standardFormula+                      <*> (proofSkeleton <|> pure (unproven ()))+++------------------------------------------------------------------------------+-- Parsing Proofs+------------------------------------------------------------------------------++-- | Parse a node premise.+nodePrem :: Parser NodePrem+nodePrem = parens ((,) <$> nodevar+                       <*> (comma *> fmap (PremIdx . fromIntegral) natural))++-- | Parse a node conclusion.+nodeConc :: Parser NodeConc+nodeConc = parens ((,) <$> nodevar+                       <*> (comma *> fmap (ConcIdx .fromIntegral) natural))++-- | Parse a goal.+goal :: Parser Goal+goal = asum+    [ premiseGoal+    , actionGoal+    , chainGoal+    , disjSplitGoal+    , eqSplitGoal+    ]+  where+    actionGoal = do+        fa <- try (fact llit <* opAt)+        i  <- nodevar+        return $ ActionG i fa++    premiseGoal = do+        (fa, v) <- try ((,) <$> fact llit <*> opRequires)+        i  <- nodevar+        return $ PremiseG (i, v) fa++    chainGoal = ChainG <$> (try (nodeConc <* opChain)) <*> nodePrem++    disjSplitGoal = (DisjG . Disj) <$> sepBy1 guardedFormula (symbol "∥")++    eqSplitGoal = try $ do+        symbol_ "split"+        parens $ (SplitG . SplitId . fromIntegral) <$> natural+++-- | Parse a proof method.+proofMethod :: Parser ProofMethod+proofMethod = asum+  [ symbol "sorry"         *> pure (Sorry Nothing)+  , symbol "simplify"      *> pure Simplify+  , symbol "solve"         *> (SolveGoal <$> parens goal)+  , symbol "contradiction" *> pure (Contradiction Nothing)+  , symbol "induction"     *> pure Induction+  ]++-- | Parse a proof skeleton.+proofSkeleton :: Parser ProofSkeleton+proofSkeleton =+    solvedProof <|> finalProof <|> interProof+  where+    solvedProof =+        symbol "SOLVED" *> pure (LNode (ProofStep Solved ()) M.empty)++    finalProof = do+        method <- symbol "by" *> proofMethod+        return (LNode (ProofStep method ()) M.empty)++    interProof = do+        method <- proofMethod+        cases  <- (sepBy oneCase (symbol "next") <* symbol "qed") <|>+                  ((return . (,) "") <$> proofSkeleton          )+        return (LNode (ProofStep method ()) (M.fromList cases))++    oneCase = (,) <$> (symbol "case" *> identifier) <*> proofSkeleton++------------------------------------------------------------------------------+-- Parsing Signatures+------------------------------------------------------------------------------++-- | Builtin signatures.+builtins :: Parser ()+builtins =+    symbol "builtins" *> colon *> commaSep1 builtinTheory *> pure ()+  where+    extendSig msig = modifyState (`mappend` msig)+    builtinTheory = asum+      [ try (symbol "diffie-hellman")+          *> extendSig dhMaudeSig+      , try (symbol "symmetric-encryption")+          *> extendSig symEncMaudeSig+      , try (symbol "asymmetric-encryption")+          *> extendSig asymEncMaudeSig+      , try (symbol "signing")+          *> extendSig signatureMaudeSig+      , symbol "hashing"+          *> extendSig hashMaudeSig+      ]++functions :: Parser ()+functions =+    symbol "functions" *> colon *> commaSep1 functionSymbol *> pure ()+  where+    functionSymbol = do+        f   <- BC.pack <$> identifier <* opSlash+        k   <- fromIntegral <$> natural+        sig <- getState+        case lookup f (S.toList $ allFunctionSymbols sig) of+          Just k' | k' /= k ->+            fail $ "conflicting arities " +++                   show k' ++ " and " ++ show k +++                   " for `" ++ BC.unpack f+          _ -> setState (addFunctionSymbol (f,k) sig)++equations :: Parser ()+equations =+    symbol "equations" *> colon *> commaSep1 equation *> pure ()+  where+    equation = do+        rrule <- RRule <$> term llit <*> (equalSign *> term llit)+        case rRuleToStRule rrule of+          Just str ->+              modifyState (addStRule str)+          Nothing  ->+              fail $ "Not a subterm rule: " ++ show rrule++------------------------------------------------------------------------------+-- Parsing Theories+------------------------------------------------------------------------------+++-- | Parse a theory.+theory :: [String]   -- ^ Defined flags.+       -> Parser OpenTheory+theory flags0 = do+    symbol_ "theory"+    thyId <- identifier+    symbol_ "begin"+        *> addItems (S.fromList flags0) (set thyName thyId defaultOpenTheory)+        <* symbol "end"+  where+    addItems :: S.Set String -> OpenTheory -> Parser OpenTheory+    addItems flags thy = asum+      [ do builtins+           msig <- getState+           addItems flags $ set (sigpMaudeSig . thySignature) msig thy+      , do functions+           msig <- getState+           addItems flags $ set (sigpMaudeSig . thySignature) msig thy+      , do equations+           msig <- getState+           addItems flags $ set (sigpMaudeSig . thySignature) msig thy+--      , do thy' <- foldM liftedAddProtoRule thy =<< transferProto+--           addItems flags thy'+      , do thy' <- liftedAddAxiom thy =<< axiom+           addItems flags thy'+      , do thy' <- liftedAddLemma thy =<< lemma+           addItems flags thy'+      , do ru <- protoRule+           thy' <- liftedAddProtoRule thy ru+           addItems flags thy'+      , do r <- intrRule+           addItems flags (addIntrRuleACs [r] thy)+      , do c <- formalComment+           addItems flags (addFormalComment c thy)+      , do ifdef flags thy+      , do define flags thy+      , do return thy+      ]++    define :: S.Set String -> OpenTheory -> Parser OpenTheory+    define flags thy = do+       flag <- try (symbol "#define") *> identifier+       addItems (S.insert flag flags) thy++    ifdef :: S.Set String -> OpenTheory -> Parser OpenTheory+    ifdef flags thy = do+       flag <- symbol_ "#ifdef" *> identifier+       thy' <- addItems flags thy+       symbol_ "#endif"+       if flag `S.member` flags+         then addItems flags thy'+         else addItems flags thy++    liftedAddProtoRule thy ru = case addProtoRule ru thy of+        Just thy' -> return thy'+        Nothing   -> fail $ "duplicate rule: " ++ render (prettyRuleName ru)++    liftedAddLemma thy lem = case addLemma lem thy of+        Just thy' -> return thy'+        Nothing   -> fail $ "duplicate lemma: " ++ get lName lem++    liftedAddAxiom thy ax = case addAxiom ax thy of+        Just thy' -> return thy'+        Nothing   -> fail $ "duplicate axiom: " ++ get axName ax++
+ src/Theory/Text/Parser/Token.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE TupleSections #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier, Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Tokenizing infrastructure+module Theory.Text.Parser.Token (+  -- * Symbols+    symbol+  , symbol_+  , dot+  , comma+  , colon++  , natural+  , naturalSubscript++  -- ** Formal comments+  , formalComment++  -- * Identifiers and Variables+  , identifier+  , indexedIdentifier++  , freshName+  , pubName++  , sortedLVar+  , lvar+  , msgvar+  , nodevar++  -- * Operators+  , opExp+  , opMult++  , opEqual+  , opLess+  , opAt+  , opForall+  , opExists+  , opImplies+  , opLEquiv+  , opLAnd+  , opLOr+  , opLNot+  , opLFalse+  , opLTrue++  , opRequires+  , opChain++  -- ** Pseudo operators+  , equalSign+  , opSharp+  , opBang+  , opSlash+  , opMinus+  , opLeftarrow+  , opRightarrow+  , opLongleftarrow+  , opLongrightarrow++  -- * Parentheses/quoting+  , braced+  , parens+  , angled+  , brackets+  , singleQuoted+  , doubleQuoted++  -- * List parsing+  , commaSep+  , commaSep1+  , list++    -- * Basic Parsing+  , Parser+  , parseFile+  , parseFromString+  ) where++import           Prelude             hiding (id, (.))++import           Data.Foldable       (asum)+import           Data.List (foldl')++import           Control.Applicative hiding (empty, many, optional)+import           Control.Category+import           Control.Monad++import           Text.Parsec         hiding ((<|>))+import qualified Text.Parsec.Token   as T++import           Theory+++++++------------------------------------------------------------------------------+-- Parser+------------------------------------------------------------------------------++-- | A parser for a stream of tokens.+type Parser a = Parsec String MaudeSig a++-- Use Parsec's support for defining token parsers.+spthy :: T.TokenParser MaudeSig+spthy =+    T.makeTokenParser spthyStyle+  where+    spthyStyle = T.LanguageDef+      { T.commentStart   = "/*"+      , T.commentEnd     = "*/"+      , T.commentLine    = "//"+      , T.nestedComments = True+      , T.identStart     = alphaNum+      , T.identLetter    = alphaNum <|> oneOf "_"+      , T.reservedNames  = ["in","let","rule"]+      , T.opStart        = oneOf ":!$%&*+./<=>?@\\^|-"+      , T.opLetter       = oneOf ":!$%&*+./<=>?@\\^|-"+      , T.reservedOpNames= []+      , T.caseSensitive  = True+      }++-- | Parse a file.+parseFile :: Parser a -> FilePath -> IO a+parseFile parser f = do+  s <- readFile f+  case runParser (T.whiteSpace spthy *> parser) minimalMaudeSig f s of+    Right p -> return p+    Left err -> error $ show err++-- | Run a given parser on a given string.+parseFromString :: Parser a -> String -> Either ParseError a+parseFromString parser =+    runParser (T.whiteSpace spthy *> parser) minimalMaudeSig dummySource+  where+    dummySource = "<interactive>"+++-- Token parsers+----------------++-- | Parse a symbol.+symbol :: String -> Parser String+symbol sym = try (T.symbol spthy sym) <?> ("\"" ++ sym ++ "\"")++-- | Parse a symbol without returning the parsed string.+symbol_ :: String -> Parser ()+symbol_ = void . symbol++-- | Between braces.+braced :: Parser a -> Parser a+braced = T.braces spthy++-- | Between brackets.+brackets :: Parser a -> Parser a+brackets = T.brackets spthy++-- | Between parentheses.+parens :: Parser a -> Parser a+parens = T.parens spthy++-- | Between angular brackets.+angled :: Parser a -> Parser a+angled = T.angles spthy++-- | Between single quotes.+singleQuoted :: Parser a -> Parser a+singleQuoted = between (symbol "'") (symbol "'")++-- | Between double quotes.+doubleQuoted :: Parser a -> Parser a+doubleQuoted = between (symbol "\"") (symbol "\"")++-- | A dot @.@.+dot :: Parser ()+dot = void $ T.dot spthy++-- | A comma @,@.+comma :: Parser ()+comma = void $ T.comma spthy++-- | A colon @:@.+colon :: Parser ()+colon = void $ T.colon spthy++-- | Parse an natural.+natural :: Parser Integer+natural = T.natural spthy++-- | Parse a Unicode-subscripted natural number.+naturalSubscript :: Parser Integer+naturalSubscript = T.lexeme spthy $ do+    digits <- many1 (oneOf "₀₁₂₃₄₅₆₇₈₉")+    let n = foldl' (\x d -> 10*x + subscriptDigitToInteger d) 0 digits+    seq n (return n)+  where+    subscriptDigitToInteger d = toInteger $ fromEnum d - fromEnum '₀'++-- | A comma separated list of elements.+commaSep :: Parser a -> Parser [a]+commaSep = T.commaSep spthy++-- | A comma separated non-empty list of elements.+commaSep1 :: Parser a -> Parser [a]+commaSep1 = T.commaSep1 spthy++-- | Parse a list of items '[' item ',' ... ',' item ']'+list :: Parser a -> Parser [a]+list = brackets . commaSep++-- | A formal comment; i.e., (header, body)+formalComment :: Parser (String, String)+formalComment = T.lexeme spthy $ do+    header <- try (many1 letter <* string "{*")+    body   <- many bodyChar <* string "*}"+    return (header, body)+  where+    bodyChar = try $ do+      c <- anyChar+      case c of+        '\\' -> char '\\' <|> char '*'+        '*'  -> mzero+        _    -> return c++-- Identifiers and Variables+----------------------------++-- | Parse an identifier as a string+identifier :: Parser String+identifier = T.identifier spthy++-- | Parse an identifier possibly indexed with a number.+indexedIdentifier :: Parser (String, Integer)+indexedIdentifier = do+    (,) <$> identifier+        <*> option 0 (try (dot *> (fromIntegral <$> natural)))++-- | Parse a logical variable with the given sorts allowed.+sortedLVar :: [LSort] -> Parser LVar+sortedLVar ss =+    asum $ map (try . mkSuffixParser) ss ++ map mkPrefixParser ss+  where+    mkSuffixParser s = do+        (n, i) <- indexedIdentifier <* colon+        symbol_ (sortSuffix s)+        return (LVar n s i)++    mkPrefixParser s = do+        case s of+          LSortMsg   -> pure ()+          LSortPub   -> void $ char '$'+          LSortFresh -> void $ char '~'+          LSortNode  -> void $ char '#'+          LSortMSet  -> void $ char '%'+        (n, i) <- indexedIdentifier+        return (LVar n s i)++-- | An arbitrary logical variable.+lvar :: Parser LVar+lvar = sortedLVar [minBound..]++-- | Parse a non-node variable.+msgvar :: Parser LVar+msgvar = sortedLVar [LSortFresh, LSortPub, LSortMsg, LSortMSet]++-- | Parse a graph node variable.+nodevar :: Parser NodeId+nodevar = asum+  [ sortedLVar [LSortNode]+  , (\(n, i) -> LVar n LSortNode i) <$> indexedIdentifier ]+  <?> "timepoint variable"++-- | Parse a literal fresh name, e.g., @~'n'@.+freshName :: Parser String+freshName = try (symbol "~" *> singleQuoted identifier)++-- | Parse a literal public name, e.g., @'n'@.+pubName :: Parser String+pubName = singleQuoted identifier+++-- Term Operators+------------++-- | The exponentiation operator @^@.+opExp :: Parser ()+opExp = symbol_ "^"++-- | The multiplication operator @*@.+opMult :: Parser ()+opMult = symbol_ "*"++-- | The timepoint comparison operator @<@.+opLess :: Parser ()+opLess = symbol_ "<"++-- | The action-at-timepoint operator \@.+opAt :: Parser ()+opAt = symbol_ "@"++-- | The equality operator @=@.+opEqual :: Parser ()+opEqual = symbol_ "="++-- | The logical-forall operator @All@ or @∀@.+opForall :: Parser ()+opForall = symbol_ "All" <|> symbol_ "∀"++-- | The logical-exists operator @Ex@ or @∃@.+opExists :: Parser ()+opExists = symbol_ "Ex" <|> symbol_ "∃"++-- | The logical-implies operator @==>@.+opImplies :: Parser ()+opImplies = symbol_ "==>" <|> symbol_ "⇒"++-- | The logical-equivalence operator @<=>@.+opLEquiv :: Parser  ()+opLEquiv = symbol_ "<=>" <|> symbol_ "⇔"++-- | The logical-and operator @&@ or @∧@.+opLAnd :: Parser ()+opLAnd = symbol_ "&" <|> symbol_ "∧"++-- | The logical-or operator @|@ or @∨@.+opLOr :: Parser ()+opLOr = symbol_ "|" <|> symbol_ "∨"++-- | The logical not operator @not@ or @¬@.+opLNot :: Parser  ()+opLNot = symbol_ "¬" <|> symbol_ "not"++-- | A logical false, @F@ or @⊥@.+opLFalse :: Parser  ()+opLFalse = symbol_ "⊥" <|> T.reserved spthy "F"++-- | A logical false, @T@ or @⊥@.+opLTrue :: Parser  ()+opLTrue = symbol_ "⊤" <|> T.reserved spthy "T"++-- Operators for constraints+----------------------------++-- | The requires-a-premise operator, @▶ subscript-idx@.+opRequires :: Parser PremIdx+opRequires = (PremIdx . fromIntegral) <$> (symbol "▶" *> naturalSubscript)++-- | The chain operator @~~>@.+opChain :: Parser ()+opChain = symbol_ "~~>"+++-- Pseudo operators (to be replaced by usage of proper tokens)+--------------------------------------------------------------++-- | The equal sign @=@.+equalSign :: Parser ()+equalSign = symbol_ "="++-- | The slash operator @/@.+opSlash :: Parser ()+opSlash = symbol_ "/"++-- | The bang operator @!@.+opBang :: Parser ()+opBang = symbol_ "!"++-- | The sharp operator @#@.+opSharp :: Parser ()+opSharp = symbol_ "#"++-- | The minus operator @-@.+opMinus :: Parser ()+opMinus = symbol_ "-"++-- | The leftarrow operator @<--@.+opLeftarrow :: Parser ()+opLeftarrow = symbol_ "<-"++-- | The rightarrow operator @-->@.+opRightarrow :: Parser ()+opRightarrow = symbol_ "->"++-- | The longleftarrow operator @<--@.+opLongleftarrow :: Parser ()+opLongleftarrow = symbol_ "<--"++-- | The longrightarrow operator @-->@.+opLongrightarrow :: Parser ()+opLongrightarrow = symbol_ "-->"
+ src/Theory/Text/Pretty.hs view
@@ -0,0 +1,146 @@+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- General support for pretty printing theories.+module Theory.Text.Pretty (+  -- * General highlighters+    module Text.PrettyPrint.Highlight++  -- * Additional combinators+  , vsep+  , fsepList++  -- * Comments+  , lineComment+  , multiComment++  , lineComment_+  , multiComment_++  -- * Keywords+  , kwTheoryHeader+  , kwEnd+  , kwModulo+  , kwBy+  , kwCase+  , kwNext+  , kwQED+  , kwLemma+  , kwAxiom++  -- ** Composed forms+  , kwRuleModulo+  , kwInstanceModulo+  , kwVariantsModulo+  , kwTypesModulo++  -- * Operators+  , opProvides+  , opRequires+  , opAction+  , opPath+  , opLess+  , opEqual+  , opDedBefore+  , opEdge++  , opExists+  , opForall+  , opLAnd+  , opLOr+  , opImp+  , opIff+  , opDot++  ) where++import Text.PrettyPrint.Highlight+++------------------------------------------------------------------------------+-- Additional combinators+------------------------------------------------------------------------------++-- | Vertically separate a list of documents by empty lines.+vsep :: Document d => [d] -> d+vsep = foldr ($--$) emptyDoc++-- | Pretty print a list of values as a comma-separated list wrapped in+-- paragraph mode.+fsepList :: Document d => (a -> d) -> [a] -> d+fsepList pp = fsep . punctuate comma . map pp+++------------------------------------------------------------------------------+-- Comments+------------------------------------------------------------------------------++lineComment :: HighlightDocument d => d -> d+lineComment d = comment $ text "//" <-> d++lineComment_ :: HighlightDocument d => String -> d+lineComment_ = lineComment . text++multiComment :: HighlightDocument d => d -> d+multiComment d = comment $ fsep [text "/*", d, text "*/"]++multiComment_ :: HighlightDocument d => [String] -> d+multiComment_ ls = comment $ fsep [text "/*", vcat $ map text ls, text "*/"]++------------------------------------------------------------------------------+-- Keywords+------------------------------------------------------------------------------++kwTheoryHeader :: HighlightDocument d => d -> d+kwTheoryHeader name = keyword_ "theory" <-> name <-> keyword_ "begin"++kwEnd, kwBy, kwCase, kwNext, kwQED, kwAxiom, kwLemma :: HighlightDocument d => d+kwEnd   = keyword_ "end"+kwBy    = keyword_ "by"+kwCase  = keyword_ "case"+kwNext  = keyword_ "next"+kwQED   = keyword_ "qed"+kwAxiom = keyword_ "axiom"+kwLemma = keyword_ "lemma"++kwModulo :: HighlightDocument d+         => String  -- ^ What+         -> String  -- ^ modulo theory+         -> d+kwModulo what thy = keyword_ what <-> parens (keyword_ "modulo" <-> text thy)++kwRuleModulo, kwInstanceModulo, kwTypesModulo, kwVariantsModulo+  :: HighlightDocument d => String -> d+kwRuleModulo     = kwModulo "rule"+kwInstanceModulo = kwModulo "instance"+kwTypesModulo    = kwModulo "type assertions"+kwVariantsModulo = kwModulo "variants"+++------------------------------------------------------------------------------+-- Operators+------------------------------------------------------------------------------++opProvides, opRequires, opAction, opPath, opLess, opEqual, opDedBefore, opEdge,+  opExists, opForall, opLAnd, opLOr, opImp, opIff, opDot+    :: HighlightDocument d => d+opProvides  = operator_ ":>"+opRequires  = operator_ "<:"+opAction    = operator_ "@"+opPath      = operator_ ">+>"+opLess      = operator_ "<"+opEqual     = operator_ "="+opDedBefore = operator_ "--|"+opEdge      = operator_ ">->"+opExists    = operator_ "∃ " -- "Ex "+opForall    = operator_ "∀ " -- "All "+opLAnd      = operator_ "∧" -- "&"+opLOr       = operator_ "∨" -- "|"+opImp       = operator_ "⇒" -- "==>"+opIff       = operator_ "⇔" -- "<=>"+opDot       = operator_ "."+
+ src/Theory/Tools/AbstractInterpretation.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Copyright   : (c) 2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+--+-- Abstract intepretation for partial evaluation of multiset rewriting+-- systems.+module Theory.Tools.AbstractInterpretation (+  -- * Combinator to define abstract interpretations+    interpretAbstractly++  -- ** Actual interpretations+  , EvaluationStyle(..)+  , partialEvaluation++  ) where++import           Debug.Trace++import           Control.Basics+import           Control.Monad.Bind+import           Control.Monad.Reader++import           Data.Label+import           Data.List+import qualified Data.Set             as S+import           Data.Traversable     (traverse)++import           Term.Substitution+import           Theory.Model+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Abstract enough versions of builtin rules for computing+------------------------------------------------------------------------------+++-- | Higher-order combinator to construct abstract interpreters.+interpretAbstractly+    :: (Eq s, HasFrees i, Apply i)+    => ([Equal LNFact] -> [LNSubstVFresh])+    -- ^ Unification  of equalities over facts. We assume that facts with+    -- different tags are never unified.+    -> s                  -- ^ Initial abstract state.+    -> (LNFact -> s -> s) -- ^ Add a fact to the abstract state+    -> (s -> [LNFact])    -- ^ Facts of a state.+    -> [Rule i]+    -- ^ Multiset rewriting rules to apply abstractly.+    -> [(s, [Rule i])]+    -- ^ Sequence of abstract states and refined versions of all given+    -- multiset rewriting rules.+interpretAbstractly unifyFactEqs initState addFact stateFacts rus =+    go st0+  where+    st0 = addFact (freshFact (varTerm (LVar "z" LSortFresh 0))) $+          addFact (inFact (varTerm (LVar "z" LSortMsg   0))) $+          initState++    -- Repeatedly refine all rules and add all their conclusions until the+    -- state doesn't change anymore.+    go st =+        (st, rus') : if st == st' then [] else go st'+      where+        rus' = concatMap refineRule rus+        st'  = foldl' (flip addFact) st $ concatMap (get rConcs) rus'++        -- Refine a rule in the context of an abstract state: for all premise+        -- to state facts combinations, try to solve the corresponding+        -- E-unification problem. If successful, return the rule with the+        -- unifier applied.+        refineRule ru = (`evalFreshT` avoid ru) $ do+            eqs <- forM (get rPrems ru) $ \prem -> msum $ do+                fa <- stateFacts st+                guard (factTag prem == factTag fa)+                -- we compute a list of 'FreshT []' actions for the outer msum+                return (Equal prem <$> rename fa)+            subst <- msum $ freshToFree <$> unifyFactEqs eqs+            return $ apply subst ru++-- | How to report on performing a partial evaluation.+data EvaluationStyle = Silent | Summary | Tracing++-- | Concrete partial evaluator activated with flag: --partial-evaluation+partialEvaluation :: EvaluationStyle+                  -> [ProtoRuleE] -> WithMaude (S.Set LNFact, [ProtoRuleE])+partialEvaluation evalStyle ruEs = reader $ \hnd ->+    consumeEvaluation $ interpretAbstractly+        ((`runReader` hnd) . unifyLNFactEqs)  -- FIXME: Use E-unification here+        S.empty+        (S.insert . absFact)+        S.toList+        ruEs+  where+    consumeEvaluation [] = error "partialEvaluation: impossible"+    consumeEvaluation ((st0, rus0) : rest0) =+        go (0 :: Int) st0 rus0 rest0+      where+        go _ st rus [] =+          ( st+          , nubBy eqModuloFreshnessNoAC $                 -- remove duplicates+            map ((`evalFresh` nothingUsed) . rename) rus+          )+        go i st _   ((st', rus') : rest) =+            withTrace (go (i + 1) st' rus' rest)+          where+            incDesc = " partial evaluation: step " ++ show i ++ " added " +++                      show (S.size st' - S.size st) ++ " facts"+            withTrace = case evalStyle of+              Silent  -> id+              Summary -> trace incDesc+              Tracing -> trace $ incDesc ++ "\n\n" +++                ( render $ nest 2 $ numbered' $ map prettyLNFact $+                  S.toList $ st' `S.difference` st ) ++ "\n"+++    -- NOTE: We should use an abstract state that identifies all variables at+    -- the same position provided they have the same sort.+    absFact :: LNFact -> LNFact+    absFact fa = case fa of+        Fact OutFact _ -> outFact (varTerm (LVar "z" LSortMsg 0))+        Fact tag ts    -> Fact tag $ evalAbstraction $ traverse absTerm ts+      where+        evalAbstraction = (`evalBind` noBindings) . (`evalFreshT` nothingUsed)++        absTerm t = case viewTerm t of+          Lit (Con _)                   -> pure t+          FApp (sym@(NonAC (_f,_k))) ts+                                        -> fApp sym <$> traverse absTerm ts+          _                             -> importBinding mkVar t (varName t)+          where+            mkVar name idx        = varTerm (LVar name (sortOfLNTerm t) idx)+            varName (viewTerm -> Lit (Var v)) = lvarName v+            varName _                         = "z"++{- FIXME: Implement++-- | Perform a simple propagation of sorts at the fact level.+propagateSorts :: [ProtoRuleE]+               -> WithMaude (M.Map FactTag [LSort], [ProtoRuleE])+propagateSorts ruEs = reader $ \hnd ->++-}
+ src/Theory/Tools/EquationStore.hs view
@@ -0,0 +1,570 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE ViewPatterns               #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt, Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+-- Support for reasoning with and about disjunctions of substitutions.+module Theory.Tools.EquationStore (+  -- * Equations+    SplitId(..)++  , EqStore(..)+  , emptyEqStore+  , eqsSubst+  , eqsConj++  -- ** Equalitiy constraint conjunctions+  , falseEqConstrConj++  -- ** Queries+  , eqsIsFalse+++  -- ** Adding equalities+  , addEqs+  , addRuleVariants+  , addDisj++  -- ** Case splitting+  , performSplit++  , splits+  , splitSize+  , splitExists++  -- * Simplification+  , simp+  , simpDisjunction++  -- ** Pretty printing+  , prettyEqStore+) where++import           Logic.Connectives+import           Term.Unification+import           Theory.Text.Pretty++import           Control.Monad.Fresh+import           Control.Monad.Reader+import           Extension.Prelude+import           Utils.Misc++import           Debug.Trace.Ignore++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.State   hiding (get, modify, put)+import qualified Control.Monad.State   as MS++import           Data.Binary+import           Data.DeriveTH+import qualified Data.Foldable         as F+import           Data.List+import           Data.Maybe+import qualified Data.Set              as S+import           Extension.Data.Label  hiding (for, get)+import qualified Extension.Data.Label  as L+import           Extension.Data.Monoid++------------------------------------------------------------------------------+-- Equation Store                                                --+------------------------------------------------------------------------------++-- | Index of disjunction in equation store+newtype SplitId = SplitId { unSplitId :: Integer }+  deriving( Eq, Ord, Show, Enum, Binary, NFData, HasFrees )++-- FIXME: Make comment parse.+--+-- The semantics of an equation store+-- > EqStore sigma_free+-- >         [ [sigma_i1,..,sigma_ik_i] | i <- [1..l] ]+-- where sigma_free = {t1/x1, .., tk/xk} is+-- >    (x1 = t1 /\ .. /\ xk = tk)+-- > /\_{i in [1..l]}+-- >    ([|sigma_i1|] \/ .. \/ [|sigma_ik_1|] \/ [|mtinfo_i|]+-- where @[|{t_1/x_1,..,t_l/x_l}|] = EX vars(t1,..,tl). x_1 = t1 /\ .. /\ x_l = t_l@.+-- Note that the 'LVar's in the range of a substitution are interpreted as+-- fresh variables, i.e., different by construction from the x_i which are+-- free variables.+--+-- The variables in the domain of the substitutions sigma_ij and all+-- variables in sigma_free are free (usually globally existentially quantified).+-- We use Conj [] as a normal form to denote True and Conj [Disj []]+-- as a normal form to denote False.+-- We say a variable @x@ is constrained by a disjunction if there is a substition+-- @s@ in the disjunction with @x `elem` dom s@.+data EqStore = EqStore {+      _eqsSubst       :: LNSubst+    , _eqsConj        :: Conj (SplitId, S.Set LNSubstVFresh)+    , _eqsNextSplitId :: SplitId+    }+  deriving( Eq, Ord )++$(mkLabels [''EqStore])++-- | @emptyEqStore@ is the empty equation store.+emptyEqStore :: EqStore+emptyEqStore = EqStore emptySubst (Conj []) (SplitId 0)++-- | @True@ iff the 'EqStore' is contradictory.+eqsIsFalse :: EqStore -> Bool+eqsIsFalse = any ((S.empty == ) . snd) . getConj . L.get eqsConj++-- | The false conjunction. It is always identified with split number -1.+falseEqConstrConj :: Conj (SplitId, S.Set (LNSubstVFresh))+falseEqConstrConj = Conj [ (SplitId (-1), S.empty) ]+++-- Instances+------------++instance Apply SplitId where+    apply _ = id++instance HasFrees EqStore where+    foldFrees f (EqStore subst substs nextSplitId) =+        foldFrees f subst <> foldFrees f substs <> foldFrees f nextSplitId+    mapFrees f (EqStore subst substs nextSplitId) =+        EqStore <$> mapFrees f subst+                <*> mapFrees f substs+                <*> mapFrees f nextSplitId++++-- Equation Store+----------------------------------------------------------------------++-- | We use the empty set (disjunction) to denote false.+falseDisj :: S.Set LNSubstVFresh+falseDisj = S.empty+++-- Dealing with equations+----------------------------------------------------------------------++-- | Returns the list of all @SplitId@s valid for the given equation store+-- sorted by the size of the disjunctions.+splits :: EqStore -> [SplitId]+splits eqs = map fst $ nub $ sortOn snd+    [ (idx, S.size conj) | (idx, conj) <- getConj $ L.get eqsConj eqs ]++-- | Returns 'True' if the 'SplitId' is valid.+splitExists :: EqStore -> SplitId -> Bool+splitExists eqs = isJust . splitSize eqs++-- | Returns the number of cases for a given 'SplitId'.+splitSize :: EqStore -> SplitId -> Maybe Int+splitSize eqs sid =+    (S.size . snd) <$> (find ((sid ==) . fst) $ getConj $ L.get eqsConj $ eqs)++-- | Add a disjunction to the equation store at the beginning+addDisj :: EqStore -> (S.Set LNSubstVFresh) -> (EqStore, SplitId)+addDisj eqStore disj =+    (   modify eqsConj ((Conj [(sid, disj)]) `mappend`)+      $ modify eqsNextSplitId succ+      $ eqStore+    , sid+    )+  where+    sid = L.get eqsNextSplitId eqStore++-- | @performSplit eqs i@ performs a case-split on the first disjunction+-- with the given 'SplitId'.+performSplit :: EqStore -> SplitId -> Maybe [EqStore]+performSplit eqStore idx =+    case break ((idx ==) . fst) (getConj $ L.get eqsConj eqStore) of+        (_, [])                   -> Nothing+        (before, (_, disj):after) -> Just $+            mkNewEqStore before after <$> S.toList disj+  where+    mkNewEqStore before after subst =+        fst $ addDisj (set eqsConj (Conj (before ++ after)) eqStore)+                      (S.singleton subst)++-- | Add a list of term equalities to the equation store. Returns the split+-- identifier of the disjunction in resulting equation store.+addEqs :: MonadFresh m+       => MaudeHandle -> [Equal LNTerm] -> EqStore -> m (EqStore, Maybe SplitId)+addEqs hnd eqs0 eqStore =+    case unifyLNTermFactored eqs `runReader` hnd of+        (_, []) ->+            return (set eqsConj falseEqConstrConj eqStore, Nothing)+        (subst, [substFresh]) | substFresh == emptySubstVFresh ->+            return (applyEqStore hnd subst eqStore, Nothing)+        (subst, substs) -> do+            let (eqStore', sid) = addDisj (applyEqStore hnd subst eqStore)+                                          (S.fromList substs)+            return (eqStore', Just sid)+            {-+            case splitStrat of+                SplitLater ->+                    return [ addDisj (applyEqStore hnd subst eqStore) (S.fromList substs) ]+                SplitNow ->+                    addEqsAC (modify eqsSubst (compose subst) eqStore)+                        <$> simpDisjunction hnd (const False) (Disj substs)+            -}+  where+    eqs = apply (L.get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0+    {-+    addEqsAC eqSt (sfree, Nothing)   = [ applyEqStore hnd sfree eqSt ]+    addEqsAC eqSt (sfree, Just disj) =+      fromMaybe (error "addEqsSplit: impossible, splitAtPos failed")+                (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (S.fromList disj))) 0)+-}++-- | Apply a substitution to an equation store and bring resulting equations into+--   normal form again by using unification.+applyEqStore :: MaudeHandle -> LNSubst -> EqStore -> EqStore+applyEqStore hnd asubst eqStore+    | dom asubst `intersect` varsRange asubst /= [] || trace (show ("applyEqStore", asubst, eqStore)) False+    = error $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'"+    | otherwise+    = modify eqsConj (fmap (second (S.fromList . concatMap applyBound  . S.toList))) $+          set eqsSubst newsubst eqStore+  where+    newsubst = asubst `compose` L.get eqsSubst eqStore+    applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $+        (`runReader` hnd) $ unifyLNTerm+          [ Equal (apply newsubst (varTerm lv)) t+          | let slist = substToListVFresh s,+            -- variables in the range are fresh, so we have to rename+            -- them away from all other variables in unification problem+            -- NOTE: these variables never enter the global context+            let ran = renameAvoiding (map snd slist)+                                     (domVFresh s ++ varsRange newsubst),+            (lv,t) <- zip (map fst slist) ran+          ]++{- NOTES for @applyEqStore tau@ to a fresh substitution sigma:+[ FIXME: extend explanation to multiple unifiers ]+Let dom(sigma) = x1,..,xk, vrange(sigma) = y1, .. yl, vrange(tau) = z1,..,zn+Fresh substitution denotes formula+  exists #y1, .., #yl. x1 = t1 /\ .. /\ xk = tk+for variables #yi that do not clash with xi and zi [renameAwayFrom]+and with vars(ti) `subsetOf` [#y1, .. #yl].+We apply tau with vrange(tau) = z1,..,zn to the formula to obtain+  exists ##y1, .., ##yl. tau(x1) = t1 /\ .. /\ tau(xk) = tk+unification then yields a lemma+  forall xi zi #yi.+    tau(x1) = t1 /\ .. /\ tau(xk) = tk+    <-> exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..+So we have+  exists #y1, .., #yl.+    exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..+<=>+  exists vars(s1,..sm). x1 = .. /\ z1 = ..+      /\  (exists #y1, .., #yl. #y1 = ..)+<=> [restric]+  exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ True+-}++-- | Add the given rule variants.+addRuleVariants :: Disj LNSubstVFresh -> EqStore -> (EqStore, SplitId)+addRuleVariants (Disj substs) eqStore+    | dom freeSubst `intersect` concatMap domVFresh substs /= []+    = error $ "addRuleVariants: Nonempty intersection between domain of variants and free substitution. "+              ++"This case has not been implemented, add rule variants earlier."+    | otherwise = addDisj eqStore (S.fromList substs)+  where+    freeSubst = L.get eqsSubst eqStore+++{-+-- | Return the set of variables that is constrained by disjunction at give position.+constrainedVarsPos :: EqStore -> Int -> [LVar]+constrainedVarsPos eqStore k+    | k < length conj = frees (conj!!k)+    | otherwise       = []+  where+    conj = getConj . L.get eqsConj $ eqStore+-}++-- Simplifying disjunctions+----------------------------------------------------------------------++-- | Simplify given disjunction via EqStore simplification. Obtains fresh+--   names for variables from the underlying 'MonadFresh'.+simpDisjunction :: MonadFresh m+                => MaudeHandle+                -> (LNSubstVFresh -> Bool)+                -> Disj LNSubstVFresh+                -> m (LNSubst, Maybe [LNSubstVFresh])+simpDisjunction hnd isContr disj0 = do+    eqStore' <- simp hnd isContr eqStore+    return (L.get eqsSubst eqStore', wrap $ L.get eqsConj eqStore')+  where+    eqStore = fst $ addDisj emptyEqStore (S.fromList $ getDisj $ disj0)+    wrap (Conj [])          = Nothing+    wrap (Conj [(_, disj)]) = Just $ S.toList disj+    wrap conj               =+        error ("simplifyDisjunction: imposible, unexpected conjunction `"+               ++ show conj ++ "'")+++-- Simplification+----------------------------------------------------------------------++-- | @simp eqStore@ simplifies the equation store.+simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore+simp hnd isContr eqStore =+    execStateT (whileTrue (simp1 hnd isContr))+               (trace (show ("eqStore", eqStore)) eqStore)+++-- | @simp1@ tries to execute one simplification step+--   for the equation store. It returns @True@ if+--   the equation store was modified.+simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool+simp1 hnd isContr = do+    s <- MS.get+    if eqsIsFalse s+        then return False+        else do+          b1 <- simpMinimize isContr+          b2 <- simpRemoveRenamings+          b3 <- simpEmptyDisj+          b4 <- foreachDisj hnd simpSingleton+          b5 <- foreachDisj hnd simpAbstractSortedVar+          b6 <- foreachDisj hnd simpIdentify+          b7 <- foreachDisj hnd simpAbstractFun+          b8 <- foreachDisj hnd simpAbstractName+          (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8]))) $+              return $ (or [b1, b2, b3, b4, b5, b6, b7, b8])+++-- | Remove variable renamings in fresh substitutions.+simpRemoveRenamings :: MonadFresh m => StateT EqStore m Bool+simpRemoveRenamings = do+    conj <- gets (L.get eqsConj)+    if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False . snd) conj+      then modM eqsConj (fmap (second $ S.map removeRenamings)) >> return True+      else return False+++-- | If empty disjunction is found, the whole conjunct+--   can be simplified to False.+simpEmptyDisj :: MonadFresh m => StateT EqStore m Bool+simpEmptyDisj = do+    conj <- getM eqsConj+    if (F.any ((== falseDisj) . snd) conj && conj /= falseEqConstrConj)+      then eqsConj =: falseEqConstrConj >> return True+      else return False+++-- | If there is a singleton disjunction, it can be+--   composed with the free substitution.+simpSingleton :: MonadFresh m+              => [LNSubstVFresh]+              -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpSingleton [subst0] = do+        subst <- freshToFree subst0+        return (Just (Just subst, []))+simpSingleton _        = return Nothing+++-- | If all substitutions @si@ map a variable @v@ to terms with the same+--   outermost function symbol @f@, then they all contain the common factor+--   @{v |-> f(x1,..,xk)}@ for fresh variables xi and we can replace+--   @x |-> ..@ by @{x1 |-> ti1, x2 |-> ti2, ..}@ in all substitutions @si@.+simpAbstractFun :: MonadFresh m+                => [LNSubstVFresh]+                -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractFun []             = return Nothing+simpAbstractFun (subst:others) = case commonOperators of+    [] -> return Nothing+    -- abstract all arguments+    (v, o, argss@(args:_)):_ | all ((==length args) . length) argss -> do+        fvars <- mapM (\_ -> freshLVar "x" LSortMsg) args+        let substs' = zipWith (abstractAll v fvars) (subst:others) argss+            fsubst  = substFromList [(v, fApp o (map varTerm fvars))]+        return $ Just (Just fsubst, [S.fromList substs'])+    -- abstract first two arguments+    (v, o@(AC _), argss):_ -> do+        fv1 <- freshLVar "x" LSortMsg+        fv2 <- freshLVar "x" LSortMsg+        let substs' = zipWith (abstractTwo o v fv1 fv2) (subst:others) argss+            fsubst  = substFromList [(v, fApp o (map varTerm [fv1,fv2]))]+        return $ Just (Just fsubst, [S.fromList substs'])+    (_, _ ,_):_ ->+        error "simpAbstract: impossible, invalid arities or List operator encountered."+  where+    commonOperators = do+        (v, viewTerm -> FApp o args) <- substToListVFresh subst+        let images = map (\s -> imageOfVFresh s v) others+            argss  = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ]+        guard (length argss == length others)+        return (v, o, args:argss)++    abstractAll v freshVars s args = substFromListVFresh $+        filter ((/= v) . fst) (substToListVFresh s) ++ zip freshVars args++    abstractTwo o v fv1 fv2 s args = substFromListVFresh $+        filter ((/= v) . fst) (substToListVFresh s) ++ newMappings args+      where+        newMappings []      =+            error "simpAbstract: impossible, AC symbols must have arity >= 2."+        newMappings [a1,a2] = [(fv1, a1), (fv2, a2)]+        -- here we always abstract from left to right and do not+        -- take advantage of the AC property of o+        newMappings (a:as)  = [(fv1, a),  (fv2, fApp o as)]+++-- | If all substitutions @si@ map a variable @v@ to the same name @n@,+--   then they all contain the common factor+--   @{v |-> n}@ and we can remove @{v -> n}@ from all substitutions @si@+simpAbstractName :: MonadFresh m+                 => [LNSubstVFresh]+                 -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractName []             = return Nothing+simpAbstractName (subst:others) = case commonNames of+    []           -> return Nothing+    (v, c):_     ->+        return $ Just (Just $ substFromList [(v, c)]+                      , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))])+  where+    commonNames = do+        (v, c@(viewTerm -> Lit (Con _))) <- substToListVFresh subst+        let images = map (\s -> imageOfVFresh s v) others+        guard (length images == length [ () | Just c' <- images, c' == c])+        return (v, c)+++-- | If all substitutions @si@ map a variable @v@ to variables @xi@ of the same+--   sort @s@ then they all contain the common factor+--   @{v |-> y}@ for a fresh variable of sort @s@+--   and we can replace @{v -> xi}@ by @{y -> xi}@ in all substitutions @si@+simpAbstractSortedVar :: MonadFresh m+                      => [LNSubstVFresh]+                      -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractSortedVar []             = return Nothing+simpAbstractSortedVar (subst:others) = case commonSortedVar of+    []            -> return Nothing+    (v, s, lvs):_ -> do+        fv <- freshLVar (lvarName v) s+        return $ Just (Just $ substFromList [(v, varTerm fv)]+                      , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))])+  where+    commonSortedVar = do+        (v, (viewTerm -> Lit (Var lx))) <- substToListVFresh subst+        guard (sortCompare (lvarSort v)  (lvarSort lx) == Just GT)+        let images = map (\s -> imageOfVFresh s v) others+            -- FIXME: could be generalized to choose topsort s of all images if s < sortOf v+            --        could also be generalized to terms of a given sort+            goodImages = [ ly | Just (viewTerm -> Lit (Var ly)) <- images, lvarSort lx == lvarSort ly]+        guard (length images == length goodImages)+        return (v, lvarSort lx, (lx:goodImages))+    replaceMapping v fv lv sigma =+        substFromListVFresh $ (filter ((/=v) . fst) $ substToListVFresh sigma) ++ [(fv, varTerm lv)]++-- | If all substitutions @si@ map two variables @x@ and @y@ to identical terms @ti@,+--   then they all contain the common factor @{x |-> y}@ for a fresh variable @z@+--   and we can remove @{x |-> ti}@ from all @si@.+simpIdentify :: MonadFresh m+             => [LNSubstVFresh]+             -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpIdentify []             = return Nothing+simpIdentify (subst:others) = case equalImgPairs of+    []         -> return Nothing+    ((v,v'):_) -> do+        let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of+                                 Just GT -> (v', v)+                                 Just _  -> (v, v')+                                 Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: "+                                                    ++ show v ++" and "++ show v'+        return $ Just (Just  (substFromList [(vremove, varTerm vkeep)]),+                       [S.fromList (map (removeMappings [vkeep]) (subst:others))])+  where+    equalImgPairs = do+        (v,t)    <- substToListVFresh subst+        (v', t') <- substToListVFresh subst+        guard (t == t' && v < v' && all (agrees_on v v') others)+        return (v,v')+    agrees_on v v' s =+        imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v)+    removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s+++-- | Simplify by removing substitutions that occur twice in a disjunct.+--   We could generalize this function by using AC-equality or subsumption.+simpMinimize :: MonadFresh m => (LNSubstVFresh -> Bool) -> StateT EqStore m Bool+simpMinimize isContr = do+    conj <- MS.gets (L.get eqsConj)+    if F.any (F.any check . snd) conj+      then MS.modify (set eqsConj (fmap (second minimize) conj)) >> return True+      else return False+  where+    minimize substs+      | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh+      | otherwise                          = S.filter (not . isContr) substs++    check subst = subst == emptySubstVFresh || isContr subst+++-- | Traverse disjunctions and execute @f@ until it returns+--   @Just (mfreeSubst, disjs)@.+--   Then the @disjs@ is inserted at the current position, if @mfreeSubst@ is+--   @Just freesubst@, then it is applied to the equation store. @True@ is+--   returned if any modifications took place.+foreachDisj :: MonadFresh m+            => MaudeHandle+            -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])))+            -> StateT EqStore m Bool+foreachDisj hnd f =+    go [] =<< gets (getConj . L.get eqsConj)+  where+    go _     []               = return False+    go lefts ((idx,d):rights) = do+        b <- lift $ f (S.toList d)+        case b of+          Nothing              -> go ((idx,d):lefts) rights+          Just (msubst, disjs) -> do+              eqsConj =: Conj (reverse lefts ++ ((,) idx <$> disjs) ++ rights)+              maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst+              return True++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty print an 'EqStore'.+prettyEqStore :: HighlightDocument d => EqStore -> d+prettyEqStore eqs@(EqStore substFree (Conj disjs) _nextSplitId) = vcat $+  [if eqsIsFalse eqs then text "CONTRADICTORY" else emptyDoc] +++  map combine+    [ ("subst", vcat $ prettySubst (text . show) (text . show) substFree)+    , ("conj",  vcat $ map ppDisj disjs)+    ]+  where+    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]+    ppDisj (idx, substs) =+        text (show (unSplitId idx) ++ ".") <-> numbered' conjs+      where+        conjs  = map ppSubst $ S.toList substs++    ppEq (a,b) =+      prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b)++    ppSubst subst = sep+      [ hsep (opExists : map prettyLVar (varsRangeVFresh subst)) <> opDot+      , nest 2 $ fsep $ intersperse opLAnd $ map ppEq $ substToListVFresh subst+      ]+++-- Derived and delayed instances+--------------------------------++instance Show EqStore where+    show = render . prettyEqStore++$( derive makeBinary ''EqStore)+$( derive makeNFData ''EqStore)
+ src/Theory/Tools/InjectiveFactInstances.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Copyright   : (c) 2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Computate an under-approximation to the set of all facts with unique+-- instances, i.e., fact whose instances never occur more than once in a+-- state. We use this information to reason about protocols that exploit+-- exclusivity of linear facts.+module Theory.Tools.InjectiveFactInstances (++  -- * Computing injective fact instances.+  simpleInjectiveFactInstances+  ) where++import           Extension.Prelude   (sortednub)++import           Control.Applicative+import           Control.Monad.Fresh+import           Data.Label+import qualified Data.Set            as S+import           Safe                (headMay)++import           Theory.Model++-- | Compute a simple under-approximation to the set of facts with injective+-- instances. A fact-tag is has injective instances, if there is no state of+-- the protocol with more than one instance with the same term as a first+-- argument of the fact-tag.+--+-- We compute the under-approximation by checking that+-- (1) the fact-tag is linear,+-- (2) every introduction of such a fact-tag is protected by a Fr-fact of the+--     first term, and+-- (3) every rule has at most one copy of this fact-tag in the conlcusion and+--     the first term arguments agree.+--+-- We exclude facts that are not copied in a rule, as they are already handled+-- properly by the naive backwards reasoning.+simpleInjectiveFactInstances :: [ProtoRuleE] -> S.Set FactTag+simpleInjectiveFactInstances rules = S.fromList $ do+    tag <- candidates+    guard (all (guardedSingletonCopy tag) rules)+    return tag+  where+    candidates = sortednub $ do+        ru  <- rules+        tag <- factTag <$> get rConcs ru+        guard $    (factTagMultiplicity tag == Linear)+                && (tag `elem` (factTag <$> get rPrems ru))+        return tag++    guardedSingletonCopy tag ru =+        length copies <= 1 && all guardedCopy copies+      where+        prems              = get rPrems ru+        copies             = filter ((tag ==) . factTag) (get rConcs ru)+        firstTerm          = headMay . factTerms++        -- True if there is a first term and a premise guarding it+        guardedCopy faConc = case firstTerm faConc of+            Nothing    -> False+            Just tConc -> freshFact tConc `elem` prems || guardedInPrems tConc++        -- True if there is a premise with the same tag and first term+        guardedInPrems tConc = (`any` prems) $ \faPrem ->+            factTag faPrem == tag && maybe False (tConc ==) (firstTerm faPrem)+
+ src/Theory/Tools/IntruderRules.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns     #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+  -- spurious warnings for view patterns+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+module Theory.Tools.IntruderRules (+    subtermIntruderRules+  , dhIntruderRules+  , specialIntruderRules+  ) where++import           Control.Basics+import           Control.Monad.Reader++import           Data.List+import qualified Data.Set                        as S++import           Extension.Data.Label++import           Utils.Misc++import           Term.Maude.Signature+import           Term.Narrowing.Variants.Compute+import           Term.Rewriting.Norm+import           Term.SubtermRule+import           Term.Positions++import           Theory.Model++++-- Variants of intruder deduction rules+----------------------------------------------------------------------+++------------------------------------------------------------------------------+-- Special Intruder rules+------------------------------------------------------------------------------++{-+These are the special intruder that are always included.++rule (modulo AC) coerce:+   [ KD( f_, x ) ] --[ KU( f_, x) ]-> [ KU( f_, x ) ]++rule (modulo AC) pub:+   [ ] --[ KU( f_, $x) ]-> [ KU( f_, $x ) ]++rule (modulo AC) gen_fresh:+   [ Fr( ~x ) ] --[ KU( 'noexp', ~x ) ]-> [ KU( 'noexp', ~x ) ]++rule (modulo AC) isend:+   [ KU( f_, x) ] --[ K(x) ]-> [ In(x) ]++rule (modulo AC) irecv:+   [ Out( x) ] --> [ KD( 'exp', x) ]++-}+-- | @specialIntruderRules@ returns the special intruder rules that are+--   included independently of the message theory+specialIntruderRules :: [IntrRuleAC]+specialIntruderRules =+    [ kuRule CoerceRule      [kdFact x_var]                 (x_var)+    , kuRule PubConstrRule   []                             (x_pub_var)+    , kuRule FreshConstrRule [Fact FreshFact [x_fresh_var]] (x_fresh_var)+    , Rule ISendRule [kuFact x_var]  [Fact InFact [x_var]] [kLogFact x_var]+    , Rule IRecvRule [Fact OutFact [x_var]] [Fact KDFact [x_var]] []+    ]+  where+    kuRule name prems t = Rule name prems [kuFact t] [kuFact t]++    x_var       = varTerm (LVar "x"  LSortMsg   0)+    x_pub_var   = varTerm (LVar "x"  LSortPub   0)+    x_fresh_var = varTerm (LVar "x"  LSortFresh 0)+++------------------------------------------------------------------------------+-- Subterm Intruder theory+------------------------------------------------------------------------------++-- | @destuctionRules st@ returns the destruction rules for the given+-- subterm rule @st@+destructionRules :: StRule -> [IntrRuleAC]+destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) =+    go [] lhs pos+  where+    rhs = lhs `atPos` pos+    go _      _                       []     = []+    -- term already in premises+    go _      (viewTerm -> FApp _ _)  (_:[]) = []+    go uprems (viewTerm -> FApp _ as) (i:p)  =+        irule ++ go uprems' t' p+      where+        uprems' = uprems++[ t | (j, t) <- zip [0..] as, i /= j ]+        t'      = as!!i+        irule = if (t' /= rhs && rhs `notElem` uprems')+                then [ Rule (DestrRule f)+                            ((kdFact  t'):(map kuFact uprems'))+                            [kdFact rhs] [] ]+                else []+    go _      (viewTerm -> Lit _)     (_:_)  =+        error "IntruderRules.destructionRules: impossible, position invalid"++destructionRules _ = []++-- | Simple removal of subsumed rules for auto-generated subterm intruder rules.+minimizeIntruderRules :: [IntrRuleAC] -> [IntrRuleAC]+minimizeIntruderRules rules =+    go [] rules+  where+    go checked [] = reverse checked+    go checked (r@(Rule _ prems concs _):unchecked) = go checked' unchecked+      where+        checked' = if any (\(Rule _ prems' concs' _)+                               -> concs' == concs && prems' `subsetOf` prems)+                          (checked++unchecked)+                   then checked+                   else r:checked++-- | @subtermIntruderRules maudeSig@ returns the set of intruder rules for+--   the subterm (not Xor, DH, and MSet) part of the given signature.+subtermIntruderRules :: MaudeSig -> [IntrRuleAC]+subtermIntruderRules maudeSig =+     minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig)+     ++ constructionRules (functionSymbols maudeSig)++-- | @constructionRules fSig@ returns the construction rules for the given+-- function signature @fSig@+constructionRules :: FunSig -> [IntrRuleAC]+constructionRules fSig =+    [ createRule s k | (s,k) <- S.toList fSig ]+  where+    createRule s k = Rule (ConstrRule s) (map kuFact vars) [concfact] [concfact]+      where vars     = take k [ varTerm (LVar "x"  LSortMsg i) | i<- [0..] ]+            m        = fApp (NonAC (s,k)) vars+            concfact = kuFact m+++------------------------------------------------------------------------------+-- Diffie-Hellman Intruder Rules+------------------------------------------------------------------------------++-- | @dhIntruderRules@ computes the intruder rules for DH+dhIntruderRules :: WithMaude [IntrRuleAC]+dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $+    [ expRule ConstrRule kuFact return+    , invRule ConstrRule kuFact return+    ] +++    concatMap (variantsIntruder hnd)+      [ expRule DestrRule kdFact (const [])+      , invRule DestrRule kdFact (const [])+      ]+  where+    x_var_0 = varTerm (LVar "x" LSortMsg 0)+    x_var_1 = varTerm (LVar "x" LSortMsg 1)++    expRule mkInfo kudFact mkAction =+        Rule (mkInfo expSymString) [bfact, efact] [concfact] (mkAction concfact)+      where+        bfact = kudFact x_var_0+        efact = kuFact  x_var_1+        conc = fAppExp (x_var_0, x_var_1)+        concfact = kudFact conc++    invRule mkInfo kudFact mkAction =+        Rule (mkInfo invSymString) [bfact] [concfact] (mkAction concfact)+      where+        bfact    = kudFact x_var_0+        conc = fAppInv x_var_0+        concfact = kudFact conc+++-- | @variantsIntruder mh irule@ computes the deconstruction-variants+-- of a given intruder rule @irule@+variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC]+variantsIntruder hnd ru = do+    let ruleTerms = concatMap factTerms+                              (get rPrems ru++get rConcs ru++get rActs ru)+    fsigma <- computeVariants (fAppList ruleTerms) `runReader` hnd+    let sigma     = freshToFree fsigma `evalFreshAvoiding` ruleTerms+        ruvariant = normRule' (apply sigma ru) `runReader` hnd+    guard (frees (get rConcs ruvariant) /= [] &&+           -- ground terms are already deducible by applying construction rules+           ruvariant /= ru &&+           -- this is a construction rule+           (get rConcs ruvariant) \\ (get rPrems ruvariant) /= []+           -- The conclusion is included in the premises+           )++    case concatMap factTerms $ get rConcs ruvariant of+        [viewTerm -> FApp (AC Mult) _] ->+            fail "Rules with product conclusion are redundant"+        _                                 -> return ruvariant++-- | @normRule irule@ computes the normal form of @irule@+normRule' :: IntrRuleAC -> WithMaude IntrRuleAC+normRule' (Rule i ps cs as) = reader $ \hnd ->+    let normFactTerms = map (fmap (\t -> norm' t `runReader` hnd)) in+    Rule i (normFactTerms ps) (normFactTerms cs) (normFactTerms as)
+ src/Theory/Tools/LoopBreakers.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Copyright   : (c) 2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Computate the loop-breakers in the premise-conclusion graph of a set of+-- multiset rewriting rules.+module Theory.Tools.LoopBreakers (++  -- * Computing loop breakers for solving premises+  useAutoLoopBreakersAC+  ) where++import Control.Applicative+import Control.Monad.Fresh+import Control.Monad.Reader++import Data.DAG.Simple++import Theory.Model+++-- | An over-approximation of the dependency of solving premises. An element+-- @((fromRu, fromPrem), (toRu, toPrem))@ denotes that solving the premise+-- @(fromRu,fromPrem)@ might lead to a case where the premise @(toRu, toPrem)@+-- is open.+premSolvingRelAC :: (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises+                 -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions+                 -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants+                 -> [a]                         -- ^ Base carrier+                 -> WithMaude (Relation (a, PremIdx))+premSolvingRelAC ePrems eConcs eVariants rules = reader $ \hnd -> do+    (toRu, from) <- dataflowRelAC hnd+    (toPrem, _)  <- ePrems toRu+    return (from, (toRu, toPrem))+  where+    -- An over-approxmiation of the dataflow relation. An element @(fromRu,+    -- (toRu, toPrem))@ denotes that there is a conclusion of @fromRu@+    -- unifying with the premise @(toRu, toPrem)@.+    dataflowRelAC hnd = do+        ruFrom <- rules+        ruTo   <- rules+        (premIdx, premFa0) <- ePrems ruTo+        guard $ or $ do+            premFa <- instances ruTo premFa0+            concFa <- instances ruFrom =<< (snd <$> eConcs ruFrom)+            let concFaFresh = rename concFa `evalFresh` avoid premFa+            return $ (`runReader` hnd) (unifiableLNFacts concFaFresh premFa)+        return (ruFrom, (ruTo, premIdx))++    instances ru fa = do+        subst <- eVariants ru+        return (apply (subst `freshToFreeAvoiding` fa) fa)+++-- | Replace all loop-breaker information with loop-breakers computed+-- automatically from the dataflow relation 'dataflowRelAC'.+useAutoLoopBreakersAC+  :: Ord a+  => (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises+  -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions+  -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants+  -> ([PremIdx] -> a -> a)       -- ^ Add annotation+  -> [a]                         -- ^ Original rules+  -> WithMaude ([a], Relation (a, PremIdx), [(a, PremIdx)])+  -- ^ Annotated rules and the premise solving relation+useAutoLoopBreakersAC ePrems eConcs eVariants addAnn rules =+    reader $ \hnd ->+      let solveRel = (`runReader` hnd) $+              premSolvingRelAC ePrems eConcs eVariants rules+          breakers = dfsLoopBreakers $ solveRel+      in ( do ru <- rules+              return (addAnn [ u | (ru', u) <- breakers, ru == ru' ] ru)+         , solveRel+         , breakers+         )+
+ src/Theory/Tools/RuleVariants.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE ViewPatterns               #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+-- Variants of protocol rules.+module Theory.Tools.RuleVariants where++import           Term.Narrowing.Variants+import           Term.Rewriting.Norm+import           Theory.Model+import           Theory.Tools.EquationStore++import           Extension.Prelude+import           Logic.Connectives++import           Control.Applicative+import           Control.Monad.Bind+import           Control.Monad.Reader+import qualified Control.Monad.Trans.PreciseFresh as Precise++import qualified Data.Map                         as M+import qualified Data.Set                         as S+import           Data.Traversable                 (traverse)++import           Debug.Trace.Ignore++-- Variants of protocol rules+----------------------------------------------------------------------++-- | Compute the variants of a protocol rule.+--   1. Abstract away terms in facts with variables.+--   2. Compute variants of RHSs of equations.+--   3. Apply variant substitutions to equations+--      to obtain DNF of equations.+--   4. Simplify rule.+variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC+variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) =+    -- rename rule to decrease variable indices+    (`Precise.evalFresh` Precise.nothingUsed) . renamePrecise  $ convertRule `evalFreshAvoiding` ru+  where+    convertRule = do+        (abstrPsCsAs, bindings) <- abstrRule+        let eqsAbstr         = map swap (M.toList bindings)+            abstractedTerms  = map snd eqsAbstr+            abstractionSubst = substFromList eqsAbstr+            variantSubsts    = computeVariants (fAppList abstractedTerms) `runReader` hnd+            substs           = [ restrictVFresh (frees abstrPsCsAs) $+                                   removeRenamings $ ((`runReader` hnd) . normSubstVFresh')  $+                                   composeVFresh vsubst abstractionSubst+                               | vsubst <- variantSubsts ]++        case substs of+          [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'"+          _  -> do+              -- x <- return (emptySubst, Just substs) --+              x <- simpDisjunction hnd (const False) (Disj substs)+              case trace (show ("SIMP",abstractedTerms,+                                "abstr", abstrPsCsAs,+                                "substs", substs,+                                "simpSubsts:", x)) x of+                -- the variants can be simplified to a single case+                (commonSubst, Nothing) ->+                  return $ makeRule abstrPsCsAs commonSubst trueDisj+                (commonSubst, Just freshSubsts) ->+                  return $ makeRule abstrPsCsAs commonSubst freshSubsts++    abstrRule = (`runBindT` noBindings) $ do+        -- first import all vars into binding to obtain nicer names+        mapM_ abstrTerm [ varTerm v | v <- frees (prems0, concs0, acts0) ]+        (,,) <$> mapM abstrFact prems0+             <*> mapM abstrFact concs0+             <*> mapM abstrFact acts0++    irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd)+    abstrFact = traverse abstrTerm+    abstrTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =+        fAppNonAC o <$> mapM abstrTerm args+    abstrTerm t = do+        at :: LNTerm <- varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t)+        return at+      where getHint (viewTerm -> Lit (Var v)) = lvarName v+            getHint _                         = "z"++    makeRule (ps, cs, as) subst freshSubsts0 =+        Rule (ProtoRuleACInfo ri (Disj freshSubsts) []) prems concs acts+      where prems = apply subst ps+            concs = apply subst cs+            acts  = apply subst as+            freshSubsts = map (restrictVFresh (frees (prems, concs, acts))) freshSubsts0++    trueDisj = [ emptySubstVFresh ]
+ src/Theory/Tools/Wellformedness.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE ViewPatterns #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Wellformedness checks for intruder variants, protocol rules, and+-- properties.+--+-- The following checks are/should be performed+-- (FIXME: compare the list below to what is really implemented.)+--+--   [protocol rules]+--+--     1. no fresh names in rule. (protocol cond. 1)+--     ==> freshNamesReport+--+--     2. no Out or K facts in premises. (protocol cond. 2)+--     ==> factReports+--+--     3. no Fr, In, or K facts in conclusions. (protocol cond. 3)+--     ==> factReports+--+--     4. vars(rhs) subset of vars(lhs) u V_Pub+--     ==> multRestrictedReport+--+--     5. lhs does not contain reducible function symbols (*-restricted (a))+--     ==> multRestrictedReport+--+--     6. rhs does not contain * (*-restricted (b))+--     ==> multRestrictedReport+--+--     7. all facts are used with the same arity.+--+--     8. fr, in, and out, facts are used with arity 1.+--+--     9. fr facts are used with a variable of sort msg or sort fresh+--+--     10. fresh facts of the same rule contain different variables. [TODO]+--+--     11. no protocol fact uses a reserved name =>+--        [TODO] change parser to ensure this and pretty printer to show this.+--+--   [security properties]+--+--     1. all facts occur with the same arity in the action of some+--        protocol rule.+--+--     2. no node variable is used in a message position and vice versa.+--+--+module Theory.Tools.Wellformedness (++  -- * Wellformedness checking+    WfErrorReport+  , checkWellformedness+  , noteWellformedness++  , prettyWfErrorReport+  ) where++import           Prelude                     hiding (id, (.))++import           Control.Basics+import           Control.Category+import           Data.Char+import           Data.Generics.Uniplate.Data (universeBi)+import           Data.Label+import           Data.List+import           Data.Maybe+import           Data.Monoid                 (mappend, mempty)+import qualified Data.Set                    as S+import           Data.Traversable            (traverse)++import           Control.Monad.Bind++import           Extension.Prelude+import           Term.LTerm+import           Term.Maude.Signature+import           Theory+import           Theory.Text.Pretty++------------------------------------------------------------------------------+-- Types for error reports+------------------------------------------------------------------------------++type Topic         = String+type WfError       = (Topic, Doc)+type WfErrorReport = [WfError]++prettyWfErrorReport :: WfErrorReport -> Doc+prettyWfErrorReport =+    vcat . intersperse (text "") . map ppTopic . groupOn fst+  where+    ppTopic []                 = error "prettyWfErrorReport: groupOn returned empty list"+    ppTopic errs@((topic,_):_) =+      text topic <> colon $-$+      (nest 2 . vcat . intersperse (text "") $ map snd errs)+++------------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------------++-- | All protocol rules of a theory.+-- thyProtoRules :: OpenTheory ->+thyProtoRules :: OpenTheory -> [ProtoRuleE]+thyProtoRules thy = [ ru | RuleItem ru <- get thyItems thy ]++-- | Lower-case a string.+lowerCase :: String -> String+lowerCase = map toLower++-- | Pretty-print a comma, separated list of 'LVar's.+prettyVarList :: Document d => [LVar] -> d+prettyVarList = fsep . punctuate comma . map prettyLVar++-- | Pretty-print a comma, separated list of 'LNTerms's.+prettyLNTermList :: Document d => [LNTerm] -> d+prettyLNTermList = fsep . punctuate comma . map prettyLNTerm++-- | Wrap strings at word boundaries.+wrappedText :: Document d => String -> d+wrappedText = fsep . map text . words++-- | Clashes+clashesOn :: (Ord b, Ord c)+          => (a -> b) -- ^ This projection+          -> (a -> c) -- ^ must determine this projection.+          -> [a] -> [[a]]+clashesOn f g xs = do+    grp <- groupOn f $ sortOn f xs+    guard (length (sortednubOn g grp) >= 2)+    return grp++-- | Nice quoting.+quote :: String -> String+quote cs = '`' : cs ++ "'"++------------------------------------------------------------------------------+-- Checks+------------------------------------------------------------------------------++--- | Check that the protocol rules are well-formed.+sortsClashCheck :: HasFrees t => String -> t -> WfErrorReport+sortsClashCheck info t = case clashesOn removeSort id $ frees t of+    [] -> []+    cs -> return $+            ( "sorts"+            , text info $-$ (nest 2 $ numbered' $ map prettyVarList cs)+            )+  where+    removeSort lv = (lowerCase (lvarName lv), lvarIdx lv)++-- | Report on sort clashes.+ruleSortsReport :: OpenTheory -> WfErrorReport+ruleSortsReport thy = do+    ru <- thyProtoRules thy+    sortsClashCheck ("rule " ++ quote (showRuleCaseName ru) +++                     " clashing sorts, casings, or multiplicities:") ru++-- | Report on fresh names.+freshNamesReport :: OpenTheory -> WfErrorReport+freshNamesReport thy = do+    ru <- thyProtoRules thy+    case filter ((LSortFresh ==) . sortOfName) $ universeBi ru of+      []    -> []+      names -> return $ (,) "fresh names" $ fsep $+          text ( "rule " ++ quote (showRuleCaseName ru) ++ ": " +++                 "fresh names are not allowed in rule:" )+        : punctuate comma (map (nest 2 . text . show) names)++-- | Report on capitalization of public names.+publicNamesReport :: OpenTheory -> WfErrorReport+publicNamesReport thy =+    case findClashes publicNames of+      []      -> []+      clashes -> return $ (,) topic $ numbered' $+          map (nest 2 . fsep . punctuate comma . map ppRuleAndName) clashes+  where+    topic       = "public names with mismatching capitalization"+    publicNames = do+        ru <- thyProtoRules thy+        (,) (showRuleCaseName ru) <$>+            (filter ((LSortPub ==) . sortOfName) $ universeBi ru)+    findClashes   = clashesOn (map toLower . show . snd) (show . snd)+    ppRuleAndName (ruName, pub) =+        text $ "rule " ++ show ruName ++ " name " ++ show pub++-- | Check whether a rule has unbound variables.+unboundCheck :: HasFrees i => String -> Rule i -> WfErrorReport+unboundCheck info ru+    | null unboundVars = []+    | otherwise        = return $+        ( "unbound"+        , text info $-$ (nest 2 $ prettyVarList unboundVars) )+  where+    boundVars   = S.fromList $ frees (get rPrems ru)+    unboundVars = do+        v <- frees (get rConcs ru, get rActs ru, get rInfo ru)+        guard $ not (lvarSort v == LSortPub || v `S.member` boundVars)+        return v++-- | Report on sort clashes.+unboundReport :: OpenTheory -> WfErrorReport+unboundReport thy = do+    RuleItem ru <- get thyItems thy+    unboundCheck ("rule " ++ quote (showRuleCaseName ru) +++                  " has unbound variables: "+                 ) ru++-- | Report on facts usage.+factReports :: OpenTheory -> WfErrorReport+factReports thy = concat+    [ reservedReport, freshFactArguments, specialFactsUsage+    , factUsage, inexistentActions+    ]+  where+    ruleFacts ru =+      ( "rule " ++ quote (showRuleCaseName ru)+      , extFactInfo <$> concatMap (`get` ru) [rPrems, rActs, rConcs])++    -- NOTE: The check that the number of actual function arguments in a term+    -- agrees with the arity of the function as given by the signature is+    -- enforced by the parser and implicitly checked in 'factArity'.++    theoryFacts = -- sortednubOn (fst &&& (snd . snd)) $+          do ruleFacts <$> get thyCache thy+      <|> do RuleItem ru <- get thyItems thy+             return $ ruleFacts ru+      <|> do LemmaItem l <- get thyItems thy+             return $ (,) ("lemma " ++ quote (get lName l)) $ do+                 fa <- formulaFacts (get lFormula l)+                 return $ (text (show fa), factInfo fa)++    -- we must compute all important information up-front in order to+    -- mangle facts with terms with bound variables and such without them+    extFactInfo fa = (prettyLNFact fa, factInfo fa)++    factInfo :: Fact t -> (FactTag, Int, Multiplicity)+    factInfo fa    = (factTag fa, factArity fa, factMultiplicity fa)++    --- Check for usage of protocol facts with reserved names+    reservedReport = do+        (origin, fas) <- theoryFacts+        case mapMaybe reservedFactName fas of+          []   -> []+          errs -> return $ (,) "reseved names" $ foldr1 ($--$) $+              wrappedText ("The " ++ origin +++                           " contains facts with reserved names:")+            : map (nest 2) errs++    reservedFactName (ppFa, info@(ProtoFact _ name _, _,_))+      | map toLower name `elem` ["fr","ku","kd","out","in"] =+          return $ ppFa $-$ text ("show:" ++ show info)+    reservedFactName _ = Nothing++    freshFactArguments = do+       ru                      <- thyProtoRules thy+       fa@(Fact FreshFact [m]) <- get rPrems ru+       guard (not (isMsgVar m || isFreshVar m))+       return $ (,) "Fr facts must only use a fresh- or a msg-variable" $+           text ("rule " ++ quote (showRuleCaseName ru)) <->+           text "fact:" <-> prettyLNFact fa++    -- Check for the usage of special facts at wrong positions+    specialFactsUsage = do+       ru <- thyProtoRules thy+       let lhs = [ fa | fa <- get rPrems ru+                      , factTag fa `elem` [KUFact, KDFact, OutFact] ]+           rhs = [ fa | fa <- get rConcs ru+                      , factTag fa `elem` [FreshFact, KUFact, KDFact, InFact] ]+           check _   []  = mzero+           check msg fas = return $ (,) "special fact usage" $+               text ("rule " ++ quote (showRuleCaseName ru)) <-> text msg $-$+               (nest 2 $ fsep $ punctuate comma $ map prettyLNFact fas)++       msum [ check "uses disallowed facts on left-hand-side:"  lhs+            , check "uses disallowed facts on right-hand-side:" rhs ]++    -- Check for facts with equal name modulo capitalization, but different+    -- multiplicity or arity.+    factUsage = do+       clash <- clashesOn factIdentifier (snd . snd) theoryFacts'+       return $ (,) "fact usage" $ numbered' $ do+           (origin, (ppFa, info@(tag, _, _))) <- clash+           return $ text (origin +++                          ", fact " ++ show (map toLower $ factTagName tag) +++                          ": " ++ showInfo info)+                    $-$ nest 2 ppFa+      where+        showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl)+        theoryFacts'   = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ]+        factIdentifier (_, (_, (tag, _, _))) = map toLower $ factTagName tag+++    -- Check that every fact referenced in a formula is present as an action+    -- of a protocol rule. We have to add the linear "K/1" fact, as the+    -- WF-check cannot rely on a loaded intruder theory.+    ruleActions = S.fromList $ map factInfo $+          kLogFact undefined+        : dedLogFact undefined+        : kuFact undefined+        : (do RuleItem ru <- get thyItems thy; get rActs ru)++    inexistentActions = do+        LemmaItem l <- get thyItems thy+        fa <- sortednub $ formulaFacts (get lFormula l)+        let info = factInfo fa+            name = get lName l+        if info `S.member` ruleActions+          then []+          else return $ (,) "lemma actions" $+                 text ("lemma " ++ quote name ++ " references action ") $-$+                 nest 2 (text $ show info) $-$+                 text "but no rule has such an action."+++-- | Gather all facts referenced in a formula.+formulaFacts :: Formula s c v -> [Fact (VTerm c (BVar v))]+formulaFacts =+    foldFormula atomFacts+      (const mempty)+      id+      (const mappend) (const $ const id)+  where+    atomFacts (Action _ fa)   = [fa]+    atomFacts (EqE _ _)       = mempty+    atomFacts (Less _ _)      = mempty+    atomFacts (Last _)        = mempty++-- | Gather all terms referenced in a formula.+formulaTerms :: Formula s c v -> [VTerm c (BVar v)]+formulaTerms =+    foldFormula atomTerms (const mempty) id (const mappend) (const $ const id)+  where+    atomTerms (Action i fa)   = i : factTerms fa+    atomTerms (EqE t s)       = [t, s]+    atomTerms (Less i j)      = [i, j]+    atomTerms (Last i)        = [i]++-- TODO: Perhaps a lot of errors would be captured when making the signature+-- of facts, term, and atom constructors explicit.+lemmaAttributeReport :: OpenTheory -> WfErrorReport+lemmaAttributeReport thy = do+    lem <- theoryLemmas thy+    guard $    get lTraceQuantifier lem == ExistsTrace+            && ReuseLemma `elem` get lAttributes lem+    return ( "attributes"+           , text "lemma" <-> (text $ quote $ get lName lem) <> colon <->+             text "cannot reuse 'exists-trace' lemmas"+           )++-- | Check for mistakes in lemmas.+--+-- TODO: Perhaps a lot of errors would be captured when making the signature+-- of facts, term, and atom constructors explicit.+formulaReports :: OpenTheory -> WfErrorReport+formulaReports thy = do+    (header, fm) <- annFormulas+    msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fm+         , ((,) "formula terms")    <$> checkTerms header fm+         , ((,) "guardedness")      <$> checkGuarded header fm+         ]+  where+    annFormulas = do LemmaItem l <- get thyItems thy+                     let header = "lemma " ++ quote (get lName l)+                         fm     = get lFormula l+                     return (header, fm)+              <|> do AxiomItem ax <- get thyItems thy+                     let header = "axiom " ++ quote (get axName ax)+                         fm     = get axFormula ax+                     return (header, fm)++    -- check that only message and node variables are used+    checkQuantifiers header fm+      | null disallowed = []+      | otherwise       = return $ fsep $+          (text $ header ++ "uses quantifiers with wrong sort:") :+          (punctuate comma $ map (nest 2 . text . show) disallowed)+      where+        binders    = foldFormula (const mempty) (const mempty) id (const mappend)+                         (\_ binder rest -> binder : rest) fm+        disallowed = filter (not . (`elem` [LSortMsg, LSortNode]) . snd) binders++    -- check that only bound variables and public names are used+    checkTerms header fm+      | null offenders = []+      | otherwise      = return $+          (fsep $+            (text $ header ++ " uses terms of the wrong form:") :+            (punctuate comma $ map (nest 2 . text . quote . show) offenders)+          ) $--$+          wrappedText+            "The only allowed terms are public names and bound node and message\+            \ variables. If you encounter free message variables, then you might\+            \ have forgotten a #-prefix. Sort prefixes can only be dropped where\+            \ this is unambiguous."+      where+        offenders = filter (not . allowed) $ formulaTerms fm+        allowed (viewTerm -> Lit (Var (Bound _)))        = True+        allowed (viewTerm -> Lit (Con (Name PubName _))) = True+        allowed _                                        = False++    -- check that the formula can be converted to a guarded formula+    checkGuarded header fm = case formulaToGuarded fm of+        Left err -> return $+            text (header ++ " cannot be converted to a guarded formula:") $-$+            nest 2 err+        Right _  -> []+++++-- | Check that all rules are multipliation restricted. Compared+-- to the definition in the paper we are slightly more lenient.+-- We also accept a rule that is an instance of a multiplication+-- restricted rule.+-- 1. Consistently abstract terms with outermost reducible function symbols+--    occuring in lhs with fresh variables in rule.+-- 2. check vars(rhs) subset of vars(lhs) u V_Pub for abstracted rule for abstracted variables.+-- 3. check that * does not occur in rhs of abstracted rule.+multRestrictedReport :: OpenTheory -> WfErrorReport+multRestrictedReport thy = do+    ru <- theoryRules thy+    (,) "multiplication restriction of rules" <$>+        case restrictedFailures ru of+          ([],[]) -> []+          (mults, unbounds) ->+              return $+                (text "The following rule is not multiplication restricted:")+                $-$ (nest 2 (prettyProtoRuleE ru))+                $-$ (text "")+                $-$ (text "After replacing reducible function symbols in lhs with variables:")+                $-$ (nest 2 $ prettyProtoRuleE (abstractRule ru))+                $-$ (text "")+                $-$ (if null mults then mempty+                     else nest 2 $ (text "Terms with multiplication: ") <-> (prettyLNTermList mults))+                $-$ (if null unbounds then mempty+                     else nest 2 $ (text "Variables that occur only in rhs: ") <-> (prettyVarList unbounds))+  where+    abstractRule ru@(Rule i lhs acts rhs) =+        (`evalFreshAvoiding` ru) .  (`evalBindT` noBindings) $ do+        Rule i <$> mapM (traverse abstractTerm) lhs+               <*> mapM (traverse replaceAbstracted) acts+               <*> mapM (traverse replaceAbstracted) rhs++    abstractTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =+        fAppNonAC o <$> mapM abstractTerm args+    abstractTerm (viewTerm -> Lit l) = return $ lit l+    abstractTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t "x"++    replaceAbstracted t = do+        b <- lookupBinding t+        case b of+          Just v -> return $ varTerm v+          Nothing ->+              case viewTerm t of+                FApp o args ->+                    fApp o <$> mapM replaceAbstracted args+                Lit l       -> return $ lit l++    restrictedFailures ru = (mults, unbound ruAbstr \\ unbound ru)+      where+        ruAbstr = abstractRule ru++        mults = [ mt | Fact _ ts <- get rConcs ru, t <- ts, mt <- multTerms t ]++        multTerms t@(viewTerm -> FApp (AC Mult) _)  = [t]+        multTerms   (viewTerm -> FApp _         as) = concatMap multTerms as+        multTerms _                                 = []++    unbound ru = [v | v <- frees (get rConcs ru) \\ frees (get rPrems ru)+                 , lvarSort v /= LSortPub ]+++    irreducible = irreducibleFunctionSymbols $ get (sigpMaudeSig . thySignature) thy++++-- | All 2-multicombinations of a list.+-- multicombine2 :: [a] -> [(a,a)]+-- multicombine2 xs0 = do (x,xs) <- zip xs0 $ tails xs0; (,) x <$> xs+++------------------------------------------------------------------------------+-- Theory+------------------------------------------------------------------------------++++-- | Returns a list of errors, if there are any.+checkWellformedness :: OpenTheory+                    -> WfErrorReport+checkWellformedness thy = concatMap ($ thy)+    [ unboundReport+    , freshNamesReport+    , publicNamesReport+    , ruleSortsReport+    , factReports+    , formulaReports+    , lemmaAttributeReport+    , multRestrictedReport+    ]++-- | Adds a note to the end of the theory, if it is not well-formed.+noteWellformedness :: WfErrorReport -> OpenTheory -> OpenTheory+noteWellformedness report thy =+    addComment wfErrorReport thy+  where+    wfErrorReport+      | null report = text "All well-formedness checks were successful."+      | otherwise   = vsep+          [ text "WARNING: the following wellformedness checks failed!"+          , prettyWfErrorReport report+          ]+
+ tamarin-prover-theory.cabal view
@@ -0,0 +1,106 @@+name:               tamarin-prover-theory++cabal-version:      >= 1.8+build-type:         Simple+version:            0.8.2.0+license:            GPL+license-file:       LICENSE+category:           Theorem Provers+author:             Benedikt Schmidt <benedikt.schmidt@inf.ethz.ch>,+                    Simon Meier <simon.meier@inf.ethz.ch>+maintainer:         Benedikt Schmidt <benedikt.schmidt@inf.ethz.ch>+copyright:          Benedikt Schmidt, Simon Meier, ETH Zurich, 2010-2012++synopsis:           Term manipulation library for the tamarin prover.++description:        This is an internal library of the Tamarin prover for+                    security protocol verification+                    (<hackage.haskell.org/package/tamarin-prover>).+                    .+                    This library provides the types to represent security+                    protocol, and it implements the constraint solver.++homepage:           http://www.infsec.ethz.ch/research/software/tamarin+++source-repository head+  type:     git+  location: https://github.com/tamarin-prover/tamarin-prover.git++----------------------+-- library stanzas+----------------------++library+    ghc-options:       -Wall -fwarn-tabs++    ghc-prof-options:  -auto-all++    build-depends:+        base              == 4.*+      , bytestring        == 0.9.*+      , deepseq           == 1.3.*+      , array             >= 0.3   && < 0.5+      , containers        >= 0.4.2 && < 0.5+      , dlist             == 0.5.*+      , mtl               == 2.0.*+      , cmdargs           == 0.9.*+      , filepath          >= 1.1   && < 1.4+      , directory         >= 1.0   && < 1.2+      , process           == 1.1.*+      , parsec            == 3.1.*+      , safe              >= 0.2  && < 0.4+      , transformers      == 0.2.*+      , fclabels          == 1.1.*+      , uniplate          == 1.6.*+      , syb               == 0.3.* && >= 0.3.3+      , binary            == 0.5.*+      , derive            == 2.5.*+      , time              >= 1.2   && < 1.5+      , parallel          == 3.2.*+      , HUnit             == 1.2.*++      , tamarin-prover-utils >= 0.8.2  && < 0.9+      , tamarin-prover-term  >= 0.8.2  && < 0.9+++    hs-source-dirs: src++    exposed-modules:+      Theory+      Theory.Proof++      Theory.Constraint.Solver+      Theory.Constraint.Solver.CaseDistinctions+      Theory.Constraint.Solver.Contradictions+      Theory.Constraint.Solver.Goals+      Theory.Constraint.Solver.ProofMethod+      Theory.Constraint.Solver.Reduction+      Theory.Constraint.Solver.Simplify+      Theory.Constraint.Solver.Types++      Theory.Constraint.System+      Theory.Constraint.System.Constraints+      Theory.Constraint.System.Dot+      Theory.Constraint.System.Guarded++      Theory.Model+      Theory.Model.Atom+      Theory.Model.Fact+      Theory.Model.Formula+      Theory.Model.Rule+      Theory.Model.Signature++      Theory.Text.Pretty+      Theory.Text.Parser+      Theory.Text.Parser.Token++      Theory.Tools.AbstractInterpretation+      Theory.Tools.EquationStore+      Theory.Tools.InjectiveFactInstances+      Theory.Tools.IntruderRules+      Theory.Tools.LoopBreakers+      Theory.Tools.RuleVariants+      Theory.Tools.Wellformedness++    other-modules: