diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,621 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 +-} + +-} diff --git a/src/Theory.hs b/src/Theory.hs new file mode 100644 --- /dev/null +++ b/src/Theory.hs @@ -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 +-- 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) + diff --git a/src/Theory/Constraint/Solver.hs b/src/Theory/Constraint/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver.hs @@ -0,0 +1,79 @@ +-- | +-- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + + diff --git a/src/Theory/Constraint/Solver/CaseDistinctions.hs b/src/Theory/Constraint/Solver/CaseDistinctions.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/CaseDistinctions.hs @@ -0,0 +1,318 @@ +-- | +-- Copyright : (c) 2011,2012 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + + + diff --git a/src/Theory/Constraint/Solver/Contradictions.hs b/src/Theory/Constraint/Solver/Contradictions.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/Contradictions.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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) diff --git a/src/Theory/Constraint/Solver/Goals.hs b/src/Theory/Constraint/Solver/Goals.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/Goals.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + diff --git a/src/Theory/Constraint/Solver/ProofMethod.hs b/src/Theory/Constraint/Solver/ProofMethod.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/ProofMethod.hs @@ -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 +-- 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) diff --git a/src/Theory/Constraint/Solver/Reduction.hs b/src/Theory/Constraint/Solver/Reduction.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/Reduction.hs @@ -0,0 +1,665 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 () + diff --git a/src/Theory/Constraint/Solver/Simplify.hs b/src/Theory/Constraint/Solver/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/Simplify.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 diff --git a/src/Theory/Constraint/Solver/Types.hs b/src/Theory/Constraint/Solver/Types.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/Solver/Types.hs @@ -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 +-- 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) diff --git a/src/Theory/Constraint/System.hs b/src/Theory/Constraint/System.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/System.hs @@ -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 +-- 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) diff --git a/src/Theory/Constraint/System/Constraints.hs b/src/Theory/Constraint/System/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/System/Constraints.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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) diff --git a/src/Theory/Constraint/System/Dot.hs b/src/Theory/Constraint/System/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/System/Dot.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Copyright : (c) 2010, 2011 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 +-} + diff --git a/src/Theory/Constraint/System/Guarded.hs b/src/Theory/Constraint/System/Guarded.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Constraint/System/Guarded.hs @@ -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 +-- 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) diff --git a/src/Theory/Model.hs b/src/Theory/Model.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Model.hs @@ -0,0 +1,25 @@ +-- | +-- Copyright : (c) 2011-2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 diff --git a/src/Theory/Model/Atom.hs b/src/Theory/Model/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Model/Atom.hs @@ -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 +-- 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) diff --git a/src/Theory/Model/Fact.hs b/src/Theory/Model/Fact.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Model/Fact.hs @@ -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 +-- 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) diff --git a/src/Theory/Model/Formula.hs b/src/Theory/Model/Formula.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Model/Formula.hs @@ -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 +-- 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) diff --git a/src/Theory/Model/Rule.hs b/src/Theory/Model/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Model/Rule.hs @@ -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 +-- 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) diff --git a/src/Theory/Model/Signature.hs b/src/Theory/Model/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Model/Signature.hs @@ -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 +-- 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 + diff --git a/src/Theory/Proof.hs b/src/Theory/Proof.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Proof.hs @@ -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 +-- 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 diff --git a/src/Theory/Text/Parser.hs b/src/Theory/Text/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Text/Parser.hs @@ -0,0 +1,634 @@ +-- | +-- Copyright : (c) 2010-2012 Simon Meier, Benedikt Schmidt +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + + diff --git a/src/Theory/Text/Parser/Token.hs b/src/Theory/Text/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Text/Parser/Token.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE TupleSections #-} +-- | +-- Copyright : (c) 2010-2012 Simon Meier, Benedikt Schmidt +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 = "" + + +-- 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_ "-->" diff --git a/src/Theory/Text/Pretty.hs b/src/Theory/Text/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Text/Pretty.hs @@ -0,0 +1,146 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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_ "." + diff --git a/src/Theory/Tools/AbstractInterpretation.hs b/src/Theory/Tools/AbstractInterpretation.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/AbstractInterpretation.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Copyright : (c) 2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- +-- 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 -> + +-} diff --git a/src/Theory/Tools/EquationStore.hs b/src/Theory/Tools/EquationStore.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/EquationStore.hs @@ -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 +-- 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) diff --git a/src/Theory/Tools/InjectiveFactInstances.hs b/src/Theory/Tools/InjectiveFactInstances.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/InjectiveFactInstances.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Copyright : (c) 2012 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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) + diff --git a/src/Theory/Tools/IntruderRules.hs b/src/Theory/Tools/IntruderRules.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/IntruderRules.hs @@ -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 +-- 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) diff --git a/src/Theory/Tools/LoopBreakers.hs b/src/Theory/Tools/LoopBreakers.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/LoopBreakers.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Copyright : (c) 2012 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + ) + diff --git a/src/Theory/Tools/RuleVariants.hs b/src/Theory/Tools/RuleVariants.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/RuleVariants.hs @@ -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 +-- 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 ] diff --git a/src/Theory/Tools/Wellformedness.hs b/src/Theory/Tools/Wellformedness.hs new file mode 100644 --- /dev/null +++ b/src/Theory/Tools/Wellformedness.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE ViewPatterns #-} +-- | +-- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + ] + diff --git a/tamarin-prover-theory.cabal b/tamarin-prover-theory.cabal new file mode 100644 --- /dev/null +++ b/tamarin-prover-theory.cabal @@ -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 , + Simon Meier +maintainer: Benedikt Schmidt +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 + (). + . + 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: