packages feed

tamarin-prover 0.8.1.0 → 0.8.2.0

raw patch · 64 files changed

+2537/−11349 lines, 64 filesdep +conduitdep +tamarin-prover-theorydep −fast-loggerdep −wai-loggerdep ~blaze-htmldep ~bytestringdep ~hamlet

Dependencies added: conduit, tamarin-prover-theory

Dependencies removed: fast-logger, wai-logger

Dependency ranges changed: blaze-html, bytestring, hamlet, http-types, tamarin-prover-term, tamarin-prover-utils, wai, warp, yesod-core, yesod-json, yesod-static

Files

.ghci view
@@ -1,5 +1,6 @@ :set -iinteractive-only-src -- :set -ilib/term/src -- :set -ilib/utils/src+:set -ilib/theory/src :set -isrc :set -Wall -fwarn-tabs
data/AUTHORS view
@@ -1,7 +1,8 @@ Authors:   Benedikt Schmidt <benedikt.schmidt@inf.ethz.ch>-  Simon Meier      <simon.meier@inf.ethz.ch>+  Simon Meier      <iridcode@gmail.com>  Contributors:   protocol models, GUI:   Cas Cremers <cas.cremers@inf.ethz.ch>   original web interface: Cedric Staub <cs@cssx.ch+  YubiKey models:         Robert Kuennemann <kunneman@lsv.ens-cachan.fr>
data/CHANGES view
@@ -1,3 +1,41 @@+* 0.8.2.0+    documentation:+      - The submitted draft of the Meier's PhD thesis on "Advancing Automated+        Security Protocol Analysis" is now available online at++          http://www.infsec.ethz.ch/research/software/tamarin++        It explains the theory underlying Tamarin in much more detail than our+        CSF'12 paper. It also explains the theory underlying trace induction+        and type assertions.++    user interface:+      - allow lemma selection with '--prove': The lemmas being analyzed are the+        ones whose name is an extension of one of the prefixes given with a+        '--prove' flag.+      - disallow parsing of reserved rule names:+        Fresh, irecv, isend, coerce, fresh, pub++    new protocol models (referenced in Meier's PhD thesis):+      - models of TESLA Scheme 1 and 2+      - modeled the+      - injective agreement for TLS and NSLPK++      - include the contributed YubiKey models from:+        "R. Kuennemann and G. Steel. Yubisecure? formal security analysis+        results for the Yubikey and YubiHSM. In Proc. of the 8th Workshop on+        Security and Trust Management (STM 2012), Pisa, Italy, September 2012."++      - minimal hash chain example: this demonstrates a short-coming in our+        current proof calculus. It does not suffice to reason about iterated+        function application.++    architectural changes:+      - upgraded the GUI to use version 1.1 of the Yesod web-framework+      - split off Theory module hierarchy as a separate library called+        'tamarin-prover-theory'++ * 0.8.1.0     - enabled parallelization by default when compiling `tamarin-prover` with       GHC 7.4 and higher. It uses as many threads as there are CPU cores on
data/doc/MANUAL view
@@ -1,7 +1,7 @@ User manual for the Tamarin prover ================================== -Date:    2012/06/04+Date:    2012/09/28 Authors: Simon Meier <iridcode@gmail.com>,          Benedikt Schmidt <beschmi@gmail.com> @@ -140,122 +140,26 @@ Additional Theory ================= -Most of the theory behind the Tamarin prover is described in our CSF 2012-paper, whose extended version is available from+Most of the theory underlying the Tamarin prover is described in the submitted+draft of Meier's PhD thesis available from    http://www.infsec.ethz.ch/research/software/tamarin -The implementation exploits a slightly more restricted definition of normal-dependency graphs and adapted versions of the constraint solving rules that-also allow security properties to refer to the conclusions of normal-construction rules. A technical report documenting this version of the-constraint solver is under preparation. From a usage perspective, the changes-are minor and explained below in the sections on-`Induction` and `Typing Invariants over the Extended Traces`.--Moreover, we added a constraint solving rule that allows to reason about-protocols that make use of exclusive access to linear facts. A typical example-is 'loops/Minimal_Create_Use_Destroy.spthy'. The corresponding constraint-reduction rule is explained below.--Apart from the above changes to the constraint solving rules, we also refined-the theory in two ways that allow to share work between different constraint-reduction steps. First, we store multiple constraint reduction steps in the-form of *precomputed case distinctions*. Second, we delay the enumeration of-the finite variants of multiset rewriting rules using an *equation store*. We-explain both of these refinements below.---Precomputed Case Distinctions--------------------------------Apart from unification, the most common step performed by Tamarin is the-enumeration of the possible origins of an open premise. Most of these-backwards steps result in a number of trivial further constraint reduction-steps being applied immediately. Instead of applying them over and over during-proof/counter-example construction, we precompute the result of doing one-backwards step and use the resulting precomputed case distinctions during-proof/counter-example search.--This precomputation is sound because the applicability of all our constraint-reduction rules is invariant under set union and instantiation. We precompute-cases for an arbitrary instance of every protocol fact and every outermost-constructor of a message.---Inductive Strengthening--------------------------The normal form conditions that we impose on dependency graphs can be seen as-a strong invariant on security protocol execution. As we have shown in our-case studies many security properties follow from these normal form-conditions. For some protocols, we must however strengthen security properties-before being able to prove them using our backwards reasoning technique. This-strengthening works by transforming the security property according to the-induction scheme associated with the set of traces of a protocol. Intuitively,-this strengthening amounts to searching for traces that violate the security-property, but do not contain any prefix that violates the security property.-Stated differently, we focus on first violations of security properties with-respect to the prefix-order on traces.--Properties that should be proven using induction can be marked with the-attribute [use_induction]. In the interactive GUI, one can just select-`induction` as a proof method provided the constraint system contains just one-guarded trace property.--For examples of protocols where inductive strengthening is required for a-successful proof, see the directories `examples/loops` and-`examples/related_work`.---Typing Invariants over the Extended Traces---------------------------------------------Note that every protocol communicating via the public network/adversary-implicitly contains loops. The adversary may send messages received from a-later step of one instance a role to an earlier step of another instance of-the same role. These loops manifest themselves during backwards reasoning as-infinite proof branches. For trivial loops where all messages are also-received as plain-text, we can prune these branches using the constraint-reduction rule N6. To prune more complicated loops, e.g., loops stemming from-receiving an encrypted message and sending out some of its contents, we need-so called typing invariants.--A typing invariant specifies the possible instantiations of a message variable-sent to the adversary. We describe these instantiations by relating an action-logging the instantiation in the rule sending the variable to actions logging-the possible instantiations in the rules sending the contents of this-variable. See the 'classic/NSLPK3.spthy' file for an example of a typing-invariant.--To enable the specification of the case that the intruder constructed the-message that a variable is instantiated with, we changed every construction-rule such that a KU-action logs the rule's conclusion. Properties referring to-this KU-actions can only be evaluated over the traces of normal dependency-graphs of a protocol. We call these traces the 'extended traces of a protocol'.-Note that we cannot transfer the validity of properties over extended traces-to the validity of these properties over standard traces stemming from the-multiset rewriting semantics. However, we can use these properties over-extended traces as lemmas during the proof of a property over standard traces-using the lemma attribute [reuse] or [typing].--The goal of typing invariants is to ensure that all chain-constraints are-solved during the precomputation of the case distinctions. We use a two-step-process to achieve this. We first precompute the so-called *untyped case-distinctions* without the assumption of the validity of any typing invariant.-These untyped precomputed case are used during the proof of a typing-invariant. We then use the typing invariants to refine the untyped case-distinctions to typed case distinctions. They are used during the proofs of-properties other than typing invariants.+Some of the missing pieces will be described in Schmidt's PhD thesis. His+thesis explains the notion of an equation store and design of the normal form+message deduction rules used to reason about Diffie-Hellman explanation,+bilinear pairings, and multiset union. Note that this version of Tamarin does+not yet support bilinear pairings and multiset union. It does support+Diffie-Hellman exponentiation as described in our CSF'12 paper,+and it uses equation stores as explained below. -In the input file, all typing invariants are marked with the [typing]-attribute. In the GUI, you can inspect both the untyped and typed precomputed-case distinctions. A typing invariant achieves its goal, if the typed-precomputed case distinctions are marked with "all chains solved".+Our preliminary support for reasoning about protocols that make use of+exclusive access to linear facts is not yet described as part of a research+paper. It is explained in the following subsection.   Reasoning about Exclusivity: Facts Symbols with Injective Instances------------------------------------------------------------+-------------------------------------------------------------------  We say that a fact symbol 'f' has *injective instances* with respect to a multiset rewriting system 'R', if there is no reachable state of@@ -354,8 +258,8 @@  A security protocol theory specifies a signature, an equational theory, a security protocol, and several lemmas, which formalize security properties.-The paper explaining the theory behind Tamarin has been published at CSF 2012-and its extended version is available from+The formal definition of security protocol theories is given in Meier's thesis+available from    http://www.infsec.ethz.ch/research/software/tamarin
data/examples/Tutorial.spthy view
@@ -3,15 +3,14 @@ ==============================================================  Authors: 	Simon Meier, Benedikt Schmidt-Date: 	        April 2012+Date: 	        September 2012   Introduction ------------ -This user guide assumes that you have a copy of our CSF'12 paper on-"Automated Analysis of Diffie-Hellman Protocols and Advanced Security-Properties", whose extended version is available from+This user guide assumes that you have a copy of the submitted draft of Meier's+PhD thesis, which is  available from http://www.infsec.ethz.ch/research/software/tamarin.  The input files for the Tamarin prover have the extension .spthy, which is@@ -20,8 +19,8 @@   1. the signature and equational theory to use for the message algebra,   2. the set of set of multiset rewriting rules modeling the protocol and      the adversary capabilities, and-  3. the guarded trace properties whose validity we wish to check for this-     set of multiset rewriting rules.+  3. the guarded trace properties whose satisfiability or validity we wish to+     check for this set of multiset rewriting rules.  We explain each of these parts where they occur in the following security protocol theory. Before we start, a few notes on the syntax.@@ -332,6 +331,31 @@   "  /*+Note that we can also strengthen the authentication property to a version of+injective authentication. Our formulation is stronger than the standard+formulation of injective authentication, as it is based on uniqueness instead+of counting. For most protocols, that guarantee injective authentication one+can also prove such a uniqueness claim, as they agree on appropriate fresh+data.+*/++lemma Client_auth_injective:+  " /* For all session keys 'k' setup by clients with a server 'S' */+    ( All S k #i.  SessKeyC(S, k) @ #i+       ==>+         /* there is a server that answered the request */+       ( (Ex #a. AnswerRequest(S, k) @ a+           /* and there is no other client that had the same request */+           & (All #j. SessKeyC(S, k) @ #j ==> #i = #j)+       )+         /* or the intruder performed a long-term key reveal on 'S'+            before the key was setup. */+       | (Ex #r. LtkReveal(S) @ r & r < i)+       )+    )+  "++/*   You can verify them by calling      tamarin-prover --prove Tutorial.spthy@@ -382,16 +406,16 @@ Conclusion ---------- -By now, you should have enough knowledge to understand the case studies from-our CSF'12 paper. Recall that you can find them in the directory listed at the-bottom of the help message, when calling 'tamarin-prover' without any+By now, you should have enough knowledge to understand the case studies+included with Tamarin. Recall that you can find them in the directory listed+at the bottom of the help message, when calling 'tamarin-prover' without any arguments. Note that Tamarin also outputs the path to the reference MANUAL specifying and explaining the grammar of security protocol theories and giving-some additional hints on additional theory exploited by Tamarin.  If you have+some additional hints on additional theory exploited by Tamarin. If you have further questions, please do not hesitate to contact either    Benedikt Schmidt    benedikt.schmidt@inf.ethz.ch-  Simon Meier         simon.meier@inf.ethz.ch+  Simon Meier         iridcode@gmail.com   Cas Cremers         cas.cremers@inf.ethz.ch
data/examples/classic/NSLPK3.spthy view
@@ -60,6 +60,7 @@     ]   --[ IN_R_1_ni( ni, m1 )     , OUT_R_1( m2 )+    , Running(I, $R, <'init',ni,~nr>)     ]->     [ Out( m2 )     , St_R_1($R, I, ni, ~nr)@@ -75,6 +76,9 @@     , !Pk(R, pkR)     ]   --[ IN_I_2_nr( nr, m2)+    , Commit (I, R, <'init',ni,nr>)  // need to log identities explicitely to+    , Running(R, I, <'resp',ni,nr>)  // specify that they must not be+                                     // compromised in the property.     ]->     [ Out( m3 )     , Secret(I,R,nr)@@ -86,7 +90,8 @@     , !Ltk(R, ltkR)     , In( aenc{'3', nr}pk(ltkR) )     ]-  --[]->+  --[ Commit (R, I, <'resp',ni,nr>)+    ]->     [ Secret(R,I,nr)     , Secret(R,I,ni)     ]@@ -141,6 +146,23 @@         & not (Ex #r. RevLtk(B) @ r)        )" +// Injective agreement from the perspective of both the initiator and the responder.+lemma injective_agree:+  " /* Whenever somebody commits to running a session, then*/+    All actor peer params #i.+        Commit(actor, peer, params) @ i+      ==>+        /* there is somebody running a session with the same parameters */+          (Ex #j. Running(actor, peer, params) @ j & j < i+            /* and there is no other commit on the same parameters */+            & not(Ex actor2 peer2 #i2.+                    Commit(actor2, peer2, params) @ i2 & not(#i = #i2)+                 )+          )+        /* or the adversary perform a long-term key reveal on actor or peer */+        | (Ex #r. RevLtk(actor) @ r)+        | (Ex #r. RevLtk(peer)  @ r)+  "  // Consistency check: ensure that secrets can be shared between honest agents. lemma session_key_setup_possible:
+ data/examples/classic/NSPK3.spthy view
@@ -0,0 +1,177 @@+theory NSLPK3+begin++builtins: asymmetric-encryption++/*+   Protocol:    The classic three message version of the+                flawed Needham-Schroeder Public Key Protocol+   Modeler:     Simon Meier+   Date:        September 2012++   Source:      Gavin Lowe. Breaking and fixing the Needham-Schroeder+                public-key protocol using FDR. In Tiziana Margaria and+                Bernhard Steffen, editors, TACAS, volume 1055 of Lecture Notes+                in Computer Science, pages 147–166.  Springer, 1996.++   Status:      working++   Note that we are using explicit global constants for discerning the+   different encryption instead of the implicit typing.+ */+++// Public key infrastructure+rule Register_pk:+  [ Fr(~ltkA) ]+  -->+  [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ]++rule Reveal_ltk:+  [ !Ltk(A, ltkA) ] --[ RevLtk(A)    ]-> [ Out(ltkA) ]+++/* We formalize the following protocol++  protocol NSPK3 {+    1. I -> R: {'1',ni,I}pk(R)+    2. I <- R: {'2',ni,nr}pk(I)+    3. I -> R: {'3',nr}pk(R)+  }+*/++rule I_1:+  let m1 = aenc{'1', ~ni, $I}pkR+  in+    [ Fr(~ni)+    , !Pk($R, pkR)+    ]+  --[ OUT_I_1(m1)+    ]->+    [ Out( m1 )+    , St_I_1($I, $R, ~ni)+    ]++rule R_1:+  let m1 = aenc{'1', ni, I}pk(ltkR)+      m2 = aenc{'2', ni, ~nr}pkI+  in+    [ !Ltk($R, ltkR)+    , In( m1 )+    , !Pk(I, pkI)+    , Fr(~nr)+    ]+  --[ IN_R_1_ni( ni, m1 )+    , OUT_R_1( m2 )+    , Running(I, $R, <'init',ni,~nr>)+    ]->+    [ Out( m2 )+    , St_R_1($R, I, ni, ~nr)+    ]++rule I_2:+  let m2 = aenc{'2', ni, nr}pk(ltkI)+      m3 = aenc{'3', nr}pkR+  in+    [ St_I_1(I, R, ni)+    , !Ltk(I, ltkI)+    , In( m2 )+    , !Pk(R, pkR)+    ]+  --[ IN_I_2_nr( nr, m2)+    , Commit (I, R, <'init',ni,nr>)  // need to log identities explicitely to+    , Running(R, I, <'resp',ni,nr>)  // specify that they must not be+                                     // compromised in the property.+    ]->+    [ Out( m3 )+    , Secret(I,R,nr)+    , Secret(I,R,ni)+    ]++rule R_2:+    [ St_R_1(R, I, ni, nr)+    , !Ltk(R, ltkR)+    , In( aenc{'3', nr}pk(ltkR) )+    ]+  --[ Commit (R, I, <'resp',ni,nr>)+    ]->+    [ Secret(R,I,nr)+    , Secret(R,I,ni)+    ]++/* TODO: Also model session-key reveals and adapt security properties. */+rule Secrecy_claim:+  [ Secret(A, B, m) ] --[ Secret(A, B, m) ]-> []++++/* Note that we are using an untyped protocol model. For proofs, we therefore+require a protocol specific type invariant for proof construction. In+principle, such an invariant is not required for attack search, but does help+a lot.++See 'NSLPK3.spthy' for a detailed explanation of the construction of this+invariant.+*/+lemma types [typing]:+  " (All ni m1 #i.+       IN_R_1_ni( ni, m1) @ i+       ==>+       ( (Ex #j. KU(ni) @ j & j < i)+       | (Ex #j. OUT_I_1( m1 ) @ j)+       )+    )+  & (All nr m2 #i.+       IN_I_2_nr( nr, m2) @ i+       ==>+       ( (Ex #j. KU(nr) @ j & j < i)+       | (Ex #j. OUT_R_1( m2 ) @ j)+       )+    )+  "++// Nonce secrecy from the perspective of both the initiator and the responder.+lemma nonce_secrecy:+  " /* It cannot be that */+    not(+        Ex A B s #i.+          /* somebody claims to have setup a shared secret, */+          Secret(A, B, s) @ i+          /* but the adversary knows it */+        & (Ex #j. K(s) @ j)+          /* without having performed a long-term key reveal. */+        & not (Ex #r. RevLtk(A) @ r)+        & not (Ex #r. RevLtk(B) @ r)+       )"++// Injective agreement from the perspective of both the initiator and the responder.+lemma injective_agree:+  " /* Whenever somebody commits to running a session, then*/+    All actor peer params #i.+        Commit(actor, peer, params) @ i+      ==>+        /* there is somebody running a session with the same parameters */+          (Ex #j. Running(actor, peer, params) @ j & j < i+            /* and there is no other commit on the same parameters */+            & not(Ex actor2 peer2 #i2.+                    Commit(actor2, peer2, params) @ i2 & not(#i = #i2)+                 )+          )+        /* or the adversary perform a long-term key reveal on actor or peer */+        | (Ex #r. RevLtk(actor) @ r)+        | (Ex #r. RevLtk(peer)  @ r)+  "++// Consistency check: ensure that secrets can be shared between honest agents.+lemma session_key_setup_possible:+  exists-trace+  " /* It is possible that */+    Ex A B s #i.+      /* somebody claims to have setup a shared secret, */+      Secret(A, B, s) @ i+      /* without the adversary having performed a long-term key reveal. */+    & not (Ex #r. RevLtk(A) @ r)+    & not (Ex #r. RevLtk(B) @ r)+  "++end
data/examples/classic/TLS_Handshake.spthy view
@@ -87,6 +87,7 @@   let       MS   = PRF(~pms, nc, ns)       Ckey = h('clientKey', nc, ns, MS)+      Skey = h('serverKey', nc, ns, MS)   in     [ St_C_1(C, nc, sid, pc)     , In(@@ -96,7 +97,8 @@     , !Pk(S, pkS)     , !Ltk(C, ltkC)     ]-  --[]->+  --[ Running(S, C, <'server', MS, Skey, Ckey>)+    ]->     [ Out(         < aenc{ '31', ~pms }pkS         , sign{ '32', h('32', ns, S, ~pms) }ltkC@@ -125,6 +127,8 @@     /* Explicit equality check, enforced as part of the property. */   --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true )     , SessionKeys( S, C, Skey, Ckey )+    , Running(C, S, <'client', MS, Skey, Ckey>)+    , Commit(S, C, <'server', MS, Skey, Ckey>)     ]->     [ Out(         senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey@@ -140,23 +144,23 @@     [ St_C_2(S, C, sid, nc, pc, ns, ps, pms)     , In( senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey )     ]-  --[ SessionKeys( S, C, Skey, Ckey ) ]->+  --[ Commit(C, S, <'client', MS, Skey, Ckey>)+    , SessionKeys( S, C, Skey, Ckey )+    ]->     []   /* TODO: Also model session-key reveals and adapt security properties. */ +axiom Eq_check_succeed: "All x y #i. Eq(x,y) @ i ==> x = y" + /* Session key secrecy from the perspective of both the server and the client  * for both the key of the server and the key of the client. Note that this  * lemma thus captures four security properties at once. */ lemma session_key_secrecy:-  " /* If all equality checks succeeded */-    (All x y #i. Eq(x,y) @ i ==> x = y)-  ==>-    /* then there is no attack */-    (not(-         /* It cannot be that */+     /* It cannot be that */+   "not(          Ex S C keyS keyC #k.            /* somebody claims to have setup session keys, */            SessionKeys(S, C, keyS, keyC) @ k@@ -167,7 +171,25 @@            /* without having performed a long-term key reveal. */          & not (Ex #r. RevLtk(S) @ r)          & not (Ex #r. RevLtk(C) @ r)-    )   )"+       )"++// Injective agreement from the perspective of both the initiator and the responder.+lemma injective_agree:+  " /* Whenever somebody commits to running a session, then*/+    All actor peer params #i.+        Commit(actor, peer, params) @ i+      ==>+        /* there is somebody running a session with the same parameters */+          (Ex #j. Running(actor, peer, params) @ j & j < i+            /* and there is no other commit on the same parameters */+            & not(Ex actor2 peer2 #i2.+                    Commit(actor2, peer2, params) @ i2 & not(#i = #i2)+                 )+          )+        /* or the adversary perform a long-term key reveal on actor or peer */+        | (Ex #r. RevLtk(actor) @ r)+        | (Ex #r. RevLtk(peer)  @ r)+  "  /* Consistency check: ensure that session-keys can be setup between honest  * agents. */
data/examples/csf12/Artificial.spthy view
@@ -5,10 +5,11 @@    Protocol:	Example    Modeler: 	Simon Meier, Benedikt Schmidt    Date: 	January 2012-  +    Status: 	working-  -   This is the artificial protocol from our CSF'12 paper, which we use to++   This is the example protocol P_{Ex2} in Simon Meier's PhD thesis.+   It is also the artificial protocol from our CSF'12 paper, which we use to    illustrate constraint solving and characterization. Note that, for    characerization, you have to call the tamarin-prover as follows. @@ -43,23 +44,25 @@ builtins: symmetric-encryption  rule Step1:-  [ Fr(~x), Fr(~k) ] -  --> -  [ St(~x, ~k), Out(senc{~x}~k), Key(~k) ]+  [ Fr(x), Fr(k) ] --> [ St(x, k), Out(senc(x,k)), Key(k) ]  rule Step2:-  [ St(x, k), In(<x,x>) ] -  --[ Fin(x, k) ]-> -  [ ]+  [ St(x, k), In(x) ] --[ Fin(x, k) ]-> [ ]  rule Reveal_key:-    [ Key(k) ]-  --[ Rev(k) ]->-    [ Out(k) ]+    [ Key(k) ] --[ Rev(k) ]-> [ Out(k) ]  // We search for trace-existence, as we want to characterize the possible // traces satisfying the given formula. lemma Characterize_Fin:-  exists-trace "Ex k S #i.  Fin(S, k) @ i"+  exists-trace+  "Ex k S #i.  Fin(S, k) @ i"++lemma Fin_unique:+  "All S k #i #j. Fin(S, k) @ i & Fin(S, k) @ j ==> #i = #j"++lemma Keys_must_be_revealed:+  "All k S #i.  Fin(S, k) @ i ==> Ex #j. Rev(k) @ j & j < i"+  end
+ data/examples/loops/Minimal_HashChain.spthy view
@@ -0,0 +1,123 @@+theory Minimal_HashChain begin++/*+  Protocol:    A minimal HashChain example (inspired by TESLA 2)+  Modeler:     Simon Meier+  Date:        August 2012++  Status:      note yet working+               (requires multiset or repeated exponentiation reasoning)++  This models the key difficulty in the proof of the TESLA 2 protocol with+  re-authentication: the verification that the key checking process is+  sufficient to guarantee that the key is a key of the hash-chain.+*/++functions: f/1++// Chain setup phase+////////////////////++// Hash chain generation+rule Gen_Start:+  [ Fr(seed) ] --> [ Gen(seed, seed), Out(seed) ]++// The NextKey-facts are used by the sender rules to store the link between+// the keys in the chain.+rule Gen_Step:+    [ Gen(seed, chain) ]+  --[ ChainKey(chain)+    ]->+    [ Gen(seed, f(chain) ) ]++// At some point the sender decides to stop the hash-chain precomputation.+rule Gen_Stop:+    [ Gen(seed, kZero) ]+  --[ ChainKey(kZero) ]->+    [ !Final(kZero) ]++// Key checking+///////////////++// Start checking an arbitrary key. Use a loop-id to allow connecting+// different statements about the same loop.+rule Check0:+    [ In(kOrig)+    , Fr(loopId)+    ]+  --[ Start(loopId, kOrig)+    ]->+    [ Loop(loopId, kOrig, kOrig) ]++rule Check:+    [ Loop(loopId, k,    kOrig) ]+  --[ Loop(loopId, k,    kOrig) ]->+    [ Loop(loopId, f(k), kOrig) ]++rule Success:+    [ Loop(loopId, kZero, kOrig), !Final(kZero) ]+  --[ Success(loopId, kOrig)+    ]-> []+++// Provable: restricts the search space+lemma Loop_Start [use_induction, reuse]:+  "All lid k kOrig #i. Loop(lid, k, kOrig) @ i ==>+    Ex #j. Start(lid, kOrig) @ j & j < i"++// Provable: restricts the search space+lemma Loop_Success_ord [use_induction, reuse]:+  "All lid k kOrig1 kOrig2 #i #j.+       Loop(lid, k, kOrig1) @ i+     & Success(lid, kOrig2) @ j+    ==>+     ( i < j)+  "++// Provable: connects an arbitrary loop step with its start.+lemma Loop_charn [use_induction]:+  "All lid k kOrig #i. Loop(lid, k, kOrig) @ i ==>+     Ex #j. Loop(lid, kOrig, kOrig) @ j"++// Not yet provable: the problem is that we cannot express the relation+// between the keys on two different segments of the same loop.+// @BS: Do you have an idea on how we could use multisets to formulate a+// strong enough invariant?+lemma Loop_and_success [use_induction]:+  "All lid k kOrig1 kOrig2 #i #j.+       Loop(lid, k, kOrig1) @ i+     & Success(lid, kOrig2) @ j+    ==>+     (Ex #j. ChainKey(k) @ j)+  "++// The ultimate goal! A successful check implies that the starting key is a+// key of the chain.+lemma Success_charn:+  "All lid k #i. Success(lid, k) @ i ==>+    Ex #j. ChainKey(k) @ j"++++/* A try on building the required 'smaller' relation in an axiomatic fashion.+   This interacts too strongly with++   Does not really work! We need a better way to express this stuff.++rule Succ_to_Smaller:+    [ !Succ(x, y) ] --[ IsSmaller(x, y) ]-> [!Smaller(x, y)]++rule Smaller_Extend:+    [ !Succ(x, y), !Smaller(y, z) ]+  --[ IsSmaller(x, z) ]->+    [ !Smaller(x, z) ]++axiom force_succ_smaller:+    "All #t1 2 a b c. IsSucc(a,b)@t1+       ==> Ex #t2 . IsSmaller(a,b)@t2 "++axiom transitivity:+    "All #t1 #t2 a b c. IsSmaller(a,b)@t1 & IsSmaller(b,c)@t2+       ==> Ex #t3 . IsSmaller(a,c)@t3 "+*/+end
data/examples/loops/TESLA_Scheme1.spthy view
@@ -82,29 +82,30 @@ // the signature on this commitment. We use the receiver nonce to identify // receivers. rule Receiver0a:-    [ Fr( ~rid ) ]+    [ Fr( ~nR ) ]   -->-    [ Out( < $R, $S, ~rid > )-    , Receiver0b( ~rid, $R, $S ) ]+    [ Out( < $R, $S, ~nR > )+    , Receiver0b( ~nR, $R, $S ) ]  rule Receiver0b:-    [ Receiver0b ( rid, R, S )+    [ Receiver0b ( nR, R, S )     , !Pk( S, pkS)     , In( <S, R, commit_k1, signature> )+    , Fr(~rid)             // Fresh name used to identify this receiver thread     ]-  -->-    [ Receiver0b_check( rid, S, commit_k1-                      , verify(signature, <commit_k1, rid>, pkS)) ]+  --[ Setup(~rid) ]->+    [ Receiver0b_check( ~rid, S, commit_k1+                      , verify(signature, <commit_k1, nR>, pkS)) ]  rule Receiver0b_check:-    [ Receiver0b_check(rid, S, commit_k1, true) ]+    [ Receiver0b_check(nR, S, commit_k1, true), Fr(~rid) ]   -->-    [ Receiver1( rid, S, commit_k1 ) ]+    [ Receiver1( nR, S, commit_k1 ) ]   // Authenticated broadcasting rule Send1:-  let data1 = <'1', ~m1, f(~k2)>+  let data1 = <~m1, f(~k2)>   in     [ Sender1(S, ~k1)     , Fr(~m1)@@ -117,7 +118,7 @@     ]  rule Recv1:-  let data1 = <'1', m1, commit_k2>+  let data1 = <m1, commit_k2>   in     [ Receiver1(rid, S, commit_k1)     , In( <data1, mac1> )@@ -127,7 +128,7 @@     [ Receiver(rid, S, data1, mac1, commit_k1, commit_k2) ]  rule SendN:-  let data = <'N', ~m, f(~kNew), ~kOld>+  let data = <~m, f(~kNew), ~kOld>   in     [ Sender(S, ~kOld, ~k)     , Fr(~m)@@ -141,7 +142,7 @@     ]  rule RecvN:-  let data = <'N', m, commit_kNew, kOld>+  let data = <m, commit_kNew, kOld>   in     [ In(< data, mac >)     , Receiver(rid, S, dataOld, MAC{dataOld}kOld, f(kOld), commit_k)@@ -162,8 +163,9 @@   "(All rid S m #i. FromSender(rid, S, m) @ i ==>        /* the server actually sent that data */        ( (Ex #j. Sent(S, m) @ j & j < i)-       /* or the server's longterm key was compromised before the claim */-       | (Ex #j. RevealLtk(S) @ j & j < i)+       /* or the server's longterm key was compromised before the receiver's+          setup was complete */+       | (Ex #s #j. Setup(rid) @ s & RevealLtk(S) @ j & j < s)        /* or one of the receivers expiredness assumptions before the claim           was not met. */        | (Ex commit #ne #e. AssumeCommitNotExpired(rid, commit) @ ne
+ data/examples/loops/TESLA_Scheme2.spthy view
@@ -0,0 +1,216 @@+theory TESLA_Scheme2 begin++/*+  Protocol:    The TESLA protocol, scheme 2+  Modeler:     Simon Meier+  Date:        September 2012++  Status:      not yet working++               (We have trouble reasoning about the authenticity check. More+               precisely, we cannot prove that a successful check implies that+               the key is a key of the hash-chain. See Minimal_HashChain.spthy+               for an example of the core problem.)++  Original descrption in [1]. This model is based on the following description+  from [2].++    Msg 0a. R -> S : nR+    Msg 0b. S -> R : {k0 , nR }SK (S )+    Msg 1.  S -> R : m1 , MAC (k1 , m1 ).++  And for n > 1:+    Msg n. S -> R : Dn , MAC (kn , Dn ) where Dn = mn , kn-1 .++  One aim of this second version is to be able to tolerate an arbitrary number of+  packet losses, and to drop unauthenticated packets, yet continue to authenticate+  later packets.++  We verify that the use of cryptography is correct under the assumption that+  the security condition holds. We do not verify that the timing schedule+  works, as we do not have a notion of time. For a manual, but machine-checked+  verification of the Scheme 2 of the TESLA protocol with time see [3].+++  [1] Perrig, Adrian, Ran Canetti, Dawn Song, and Doug Tygar. "The TESLA+  Broadcast Authentication Protocol." In RSA Cryptobytes, Summer 2002.++  [2] Philippa J. Hopcroft, Gavin Lowe: Analysing a stream authentication+  protocol using model checking. Int. J. Inf. Sec. 3(1): 2-13 (2004)++  [3] David A. Basin, Srdjan Capkun, Patrick Schaller, Benedikt Schmidt:+  Formal Reasoning about Physical Properties of Security Protocols. ACM Trans.+  Inf. Syst. Secur. 14(2): 16 (2011)++*/++builtins: signing++functions: MAC/2, f/1++// PKI+//////++rule Generate_Keypair:+    [ Fr(~ltk) ]+  -->+    [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ]++// We assume an active adversary.+// rule Reveal_Ltk:+//     [ !Ltk(A, ltk) ]+//   --[ RevealLtk(A) ]->+//     [ Out(ltk) ]+++// Chain setup phase+////////////////////++// Hash chain generation+rule Gen_Start:+  [ Fr(~seed) ] --> [ Gen(~seed, ~seed) ]++// The NextKey-facts are used by the sender rules to store the link between+// the keys in the chain.+rule Gen_Step:+    [ Gen(seed, chain) ]+  --[ ChainKey(f(chain))+    ]->+    [ Gen(seed, f(chain) ) , NextKey( f(chain) , chain ) ]++// At some point the sender decides to stop the hash-chain precomputation.+rule Gen_Stop:+    [ Gen(seed, kZero) ]+  --[ Expired(kZero), KeyZero(seed, kZero) ]->+    [ Sender(kZero) , !Sender0($S, kZero) ]++// Intial chain key distribution+////////////////////////////////++// Everybody can listen in by sending a request for k_0.+rule Sender0:+  let msgZero = <nR, kZero>+  in+    [ !Sender0(S, kZero), !Ltk(S, ltkS), In(nR) ]+    -->+    [ Out( <msgZero, sign{msgZero}ltkS> ) ]++// Receivers start by requesting key k_0 adn verifying the signature on this+// response.+rule Receiver0a:+    [ Fr(~nR) ] --> [ Receiver0b($S, ~nR), Out(<$S, ~nR>) ]++rule Receiver0b:+  let msgZero = <nR, kZero>+  in+    [ Receiver0b(S,nR), !Pk(S, pkS), In(<msgZero, signature>) ]+  --[ Eq( verify(signature, msgZero, pkS), true() ) ]->+    [ !Receiver(S, kZero) ]++// Sending+//////////++// We use the convention that k_{n-1} is denoted as kNp, where the 'p' stands+// for predecessor.+rule Sender:+  let msgN = <mN, MAC( kN, mN )>+  in+    [ Sender( kNp ), NextKey( kNp, kN), Fr(mN) ]+  --[ Expired( kNp )+    , Sent( msgN )+    ]->+    [ Sender( kN ), Out(kNp), Out(msgN) ]++// Receiving+////////////++rule Receiver:+  let msg = <m, mac>+  in+    [ !Receiver(S, kZero), In( msg )+    , Fr(expiryCheck)+    ]+  --[ NotExpiredHere( expiryCheck ) ]->+    [ CheckAuth(expiryCheck, S, kZero, msg ) ]++rule CheckAuth0:+  let args = <kZero, expiryCheck, S, k, msg>+  in+    [ CheckAuth(expiryCheck, S, kZero, msg)+    , In(k)+    , Fr(loopId)+    ]+  --[ CheckStart(loopId, args)+    ]->+    [ CheckAuthLoop(loopId, k, args) ]++rule CheckAuth:+    [ CheckAuthLoop(loopId, k, args) ]+  --[ CheckLoop( loopId, f(k), args )+    ]->+    [ CheckAuthLoop(loopId, f(k), args) ]+++rule CheckAuthClaim:+  let msg = <m, MAC(kRef,m)>+  in+    [ CheckAuthLoop(loopId, kZero, <kZero, expiryCheck, S, kRef, msg>) ]+  --[ FromSender(msg, S, kRef, expiryCheck)+    , Success(loopId)+    ]-> []+++// Axioms; i.e., universal restrictions on the traces of interest+/////////////////////////////////////////////////////////////////++axiom Eq_checks_succeed: "(All x y #j. Eq(x, y) @ j ==> x = y)"++axiom Neq_checks_succeed: "(All x #j. Neq(x, x) @ j ==> F)"++// The security condition of TESLA guarantees that+axiom Security_condition:+  "All m S k check #i #j #e.+         FromSender(m, S, k, check) @ i+       & NotExpiredHere(check) @ j+       & Expired(k) @ e+     ==>+         j < e"+++// Security properties+//////////////////////++// The following two lemmas constraint the search space strongly enough to+// allow reasoning about the authenticity of the received messages.++lemma chain_keys_unique [use_induction, reuse]:+  "All k #i #j. ChainKey(k) @ i & ChainKey(k) @ j ==> #i = #j"++lemma knows_only_expired_chain_keys [use_induction, reuse]:+  "All k #i #j. ChainKey(k) @i & KU(k) @ j ==>+      (Ex #e. Expired(k) @ e & e < j)"++// The current proof idea is to assume this axiom because we cannot yet prove+// it. Proving it requires support for multisets or repeated function+// application.+axiom FromSender_charn: // [use_induction]:+  // "All m S k0 lid k args check #i.+  "All lid k args #i #j.+         // FromSender(m, S, k0, check) @ i+         Success(lid) @ i+       & CheckLoop(lid, k, args) @ j+     ==>+       (Ex #c. ChainKey(k) @ c)+  "++lemma authentic [use_induction]:+  "  (All m S k check #i.+           FromSender(m, S, k, check) @ i+         ==>+           (Ex #j. Sent(m) @ j      & j < i)+         // | (Ex #j. RevealLtk(S) @ j & j < i)+     )+  "+++end
+ data/examples/loops/TESLA_Scheme2_lossless.spthy view
@@ -0,0 +1,206 @@+theory TESLA_Scheme2_lossless begin++/*+  Protocol:    The TESLA protocol, scheme 2 (no re-authentication)+  Modeler:     Simon Meier+  Date:        September 2012++  Status:      working++  Original descrption in [1]. This model is based on the following description+  from [2].++    Msg 0a. R -> S : nR+    Msg 0b. S -> R : {k0 , nR }SK (S )+    Msg 1.  S -> R : m1 , MAC (k1 , m1 ).++  And for n > 1:+    Msg n. S -> R : Dn , MAC (kn , Dn ) where Dn = mn , kn-1 .++  Here, we model a simplified version of Scheme 2, which does not allow a+  receiver to re-authenticate once it missed a packet. We have not yet managed+  to verify a model that allows this re-authentication. See+  TESLA_Scheme2.spthy for more information on the problem.++  We verify that the use of cryptography is correct under the assumption that+  the security condition holds. We do not verify that the timing schedule+  works, as we do not have a notion of time. For a manual, but machine-checked+  verification of the Scheme 2 of the TESLA protocol with time see [3].+++  [1] Perrig, Adrian, Ran Canetti, Dawn Song, and Doug Tygar. "The TESLA+  Broadcast Authentication Protocol." In RSA Cryptobytes, Summer 2002.++  [2] Philippa J. Hopcroft, Gavin Lowe: Analysing a stream authentication+  protocol using model checking. Int. J. Inf. Sec. 3(1): 2-13 (2004)++  [3] David A. Basin, Srdjan Capkun, Patrick Schaller, Benedikt Schmidt:+  Formal Reasoning about Physical Properties of Security Protocols. ACM Trans.+  Inf. Syst. Secur. 14(2): 16 (2011)++*/++builtins: signing++functions: MAC/2, f/1++// PKI+//////++rule Generate_Keypair:+    [ Fr(~ltk) ]+  -->+    [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ]++// We assume an active adversary.+rule Reveal_Ltk:+    [ !Ltk(A, ltk) ]+  --[ RevealLtk(A) ]->+    [ Out(ltk) ]+++// Chain setup phase+////////////////////++// Hash chain generation+rule Gen_Start:+  [ Fr(~seed) ] --> [ Gen(~seed) ]++// The NextKey-facts are used by the sender rules to store the link between+// the keys in the chain.+rule Gen_Step:+    [ Gen(chain) ]+  --[ ChainKey(f(chain)) ]->+    [ Gen( f(chain) ) , NextKey( f(chain) , chain ) ]++// At some point the sender decides to stop the hash-chain precomputation.+rule Gen_Stop:+    [ Gen(kZero) ]+  --[ Expired(kZero) ]->+    [ Sender1( $S, kZero) , !Sender0($S, kZero) ]++// Intial chain key distribution+////////////////////////////////++// Everybody can listen in by sending a request for k_0.+rule Sender0:+  let msgZero = <nR, kZero>+  in+    [ !Sender0(S, kZero), !Ltk(S, ltkS), In(nR) ]+    -->+    [ Out( <msgZero, sign{msgZero}ltkS> ) ]++// Receivers start by requesting key k_0 adn verifying the signature on this+// response.+rule Receiver0a:+    [ Fr(~nR) ] --> [ Receiver0b($S, ~nR), Out(<$S, ~nR>) ]++rule Receiver0b:+  let msgZero = <nR, kZero>+  in+    [ Receiver0b(S,nR), !Pk(S, pkS), In(<msgZero, signature>) ]+  --[ Eq( verify(signature, msgZero, pkS), true() ) ]->+    [ Receiver1(S,kZero) ]++// Sending+//////////++rule Sender1:+  let msgOne = <mOne, MAC(kOne, mOne)>+  in+    [ Sender1( S, kZero ), NextKey( kZero, kOne ), Fr(mOne) ]+  --[ Sent(S, msgOne) ]->+    [ SenderN( S, kOne ), Out( msgOne ) ]++// We use the convention that k_{n-1} is denoted as kNp, where the 'p' stands+// for predecessor.+rule SenderN:+  let msgN = <kNp, mN, MAC( kN, mN )>+  in+    [ SenderN( S, kNp ), NextKey( kNp, kN), Fr(mN) ]+  --[ Expired( kNp )+    , Sent( S, msgN )+    ]->+    [ SenderN( S, kN ), Out(msgN) ]++// Receiving+////////////++rule Receiver1:+  let msgOne = <mOne, macOne>+  in+    [ Receiver1(S, kZero), In( msgOne ), Fr(expiryCheckOne) ]+  --[ NotExpiredHere(expiryCheckOne) ]->+    [ ReceiverN(S, kZero, expiryCheckOne, msgOne, mOne, macOne ) ]++rule ReceiverN:+  let msgN = <kNp, mN, macN>+  in+    [ ReceiverN(S, kNpp, expiryCheckNp, msgNp, mNp, macNp), In( msgN )+    , Fr(expiryCheckN)+    ]+  --[ Eq( kNpp, f(kNp) ), Eq( macNp, MAC(kNp, mNp) )+      // This action claims that 'msgNp' was sent by the sender provided that+      // the longterm-key of 'S' was not revealed before and the key 'kNp'+      // expired after the expiry check denoted by 'expiryCheckNp'.+    , FromSender(msgNp, S, kNp, expiryCheckNp)+    , NotExpiredHere( expiryCheckN )+    ]->+    [ ReceiverN(S, kNp, expiryCheckN, msgN, mN, macN ) ]++// Axioms; i.e., universal restrictions on the traces of interest+/////////////////////////////////////////////////////////////////++// We are only interested in traces where all equality checks succeed.+axiom Eq_checks_succeed: "(All x y #j. Eq(x, y) @ j ==> x = y)"++// The security condition of TESLA guarantees that a key never expires+// before the receiver considers it to be expired. This means that we assume+// that the clocks are synchronized. Then, the clock checks are sufficient to+// guarantee this property.+axiom Security_condition:+  "All m S k check #i #j #e.+         FromSender(m, S, k, check) @ i+       & NotExpiredHere(check) @ j+       & Expired(k) @ e+     ==>+         j < e"+++// Security properties+//////////////////////++// Sanity check: there is a honest execution where no key expired too early.+lemma honestly_executable:+  exists-trace+  " ( Ex m S k check #i #j.+          FromSender(m, S, k, check) @ i+        & Sent(S, m) @ j+    )+  & (All S #r. RevealLtk(S) @ r ==> F)   // no longterm key was revealed+  "++// The following two lemmas constraint the search space strongly enough to+// allow reasoning about the authenticity of the received messages.++lemma chain_keys_unique [use_induction, reuse]:+  "All k #i #j. ChainKey(k) @ i & ChainKey(k) @ j ==> #i = #j"++lemma knows_only_expired_chain_keys [use_induction, reuse]:+  "All k #i #j. ChainKey(k) @i & KU(k) @ j ==>+      (Ex #e. Expired(k) @ e & e < j)"++// The desired security property:+lemma authentic [use_induction]:+  " (All m S k check #i.+         /* Whenever the reciever states that it received an authentic message, */+         FromSender(m, S, k, check) @ i+       ==>+         /* the sender sent it */+         (Ex #j. Sent(S, m) @ j   & j < i)+         /* or the adversary revealed the longterm key of the sender. */+       | (Ex #j. RevealLtk(S) @ j & j < i)+   )+  "++end
data/examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy view
@@ -7,115 +7,185 @@  *  * Status: 	working +  [1] Sebastian Moedersheim: Abstraction by set-membership: verifying security  protocols and web services with databases. ACM Conference on Computer and  Communications Security 2010: 351-360- */ -/* Original input file from [1]+ The original model from [1]. -Problem: zebsKeyserver;+    Problem: zebsKeyserver; -Types:-Agent  : {a,b,c,i,s};-U      : {a,b,c};-S      : {s};-H      : {a,b};-D      : {c,i};-DU     : {c};-Sts    : {valid,revoked};-PK,NPK : value;-M1,M2  : untyped;+    Types:+    Agent  : {a,b,c,i,s};+    U      : {a,b,c};+    S      : {s};+    H      : {a,b};+    D      : {c,i};+    DU     : {c};+    Sts    : {valid,revoked};+    PK,NPK : value;+    M1,M2  : untyped; -Sets:-ring(U), db(S,U,Sts);+    Sets:+    ring(U), db(S,U,Sts); -Functions:-public sign/2, pair/2;-private inv/1;+    Functions:+    public sign/2, pair/2;+    private inv/1; -Facts:-iknows/1, attack/0;+    Facts:+    iknows/1, attack/0; -Rules:+    Rules: -\Agent. => iknows(Agent);-iknows(sign(M1,M2)) => iknows(M2);-iknows(M1).iknows(M2) => iknows(sign(M1,M2));-iknows(pair(M1,M2)) => iknows(M1).iknows(M2);-iknows(M1).iknows(M2) => iknows(pair(M1,M2));+    \Agent. => iknows(Agent);+    iknows(sign(M1,M2)) => iknows(M2);+    iknows(M1).iknows(M2) => iknows(sign(M1,M2));+    iknows(pair(M1,M2)) => iknows(M1).iknows(M2);+    iknows(M1).iknows(M2) => iknows(pair(M1,M2));++    \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid);++    \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid);++    \H.+    iknows(PK).PK in ring(H)+    =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK)));++    \S,U.+    iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid).+    forall U,Sts. NPK notin db(S,U,Sts)+    =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK));++    \S,H.+    iknows(inv(PK)).PK in db(S,H,valid)+    =>attack;++  Unfortunately, there are no comments. Moreover, public keys are converted+  freely to private keys, which is not always faithful. We comment on this+  below. */  builtins: signing -// The non-deterministic choice between the rules SetupHonestKey and-// SetupDishonestKey determines whether an agent is honest or not.+/* We also setup a server key to allow server signatures. */+rule SetupServerKey:+    [ Fr(~sk) ]+  -->+    [ !ServerSK(~sk), !ServerPK(pk(~sk)), Out(pk(~sk)) ] -// \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid);+/*+  The non-deterministic choice between the rules SetupHonestKey and+  SetupDishonestKey determines whether an agent is honest or not.++  The rule below models++    \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid);++  Note that servers store public keys and clients store their private key.+  There may be several registered keys at the same time, as there may be+  multiple ServerKey-facts in the state at the same time.+*/ rule SetupHonestKey:     [ Fr(~sk) ]   --[ HonestKey(~sk) ]->-    [ Out(pk(~sk)), ClientKey($A, ~sk), ServerDB($A, ~sk) ]+    [ Out(pk(~sk)) , ClientKey($A, ~sk) , ServerDB($A, pk(~sk)) ] -// \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid);++/* The intruder may register any private key for any agent.++    \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid);++*/ rule SetupDishonestKey:-    [ In(sk) ]-  -->-    [ ServerDB($A, sk) ]+    [ In(sk) ] --> [ ServerDB($A, pk(sk)) ] -// \H.-// iknows(PK).PK in ring(H)-// =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK)));-rule RequestRenewKey:-    [ ClientKey($A, sk), Fr(~skNew) ]+/* A client may renew one of his keys by sending a renew request. In [1], the+   server then leaks the corresponding private key. This is not really+   possible, as the server does not know the private keys corresponding to+   newly setup keys. We model that the key waits for a confirmation of his+   request and only then leaks his key++   The original client request rule was:++     \H.+     iknows(PK).PK in ring(H)+     =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK)));+*/+rule Client_RenewKey:+  let pkNew      = pk(~skNew)+      request    = <'renew', $A, pkNew>+      requestSig = sign{request}~sk+  in+    [ ClientKey($A, ~sk), Fr(~skNew) ]   --[ HonestKey(~skNew) ]->-    [ Out( sign{'renew', $A, pk(~skNew)}sk )+    [ Out( <request, requestSig> )     , ClientKey($A, ~skNew)+    , AwaitConfirmation(requestSig,~sk)     ] -// \S,U.-// iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid).-// forall U,Sts. NPK notin db(S,U,Sts)-// =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK));-rule RenewKey:-    [ In( sign{'renew', A, pk(skNew)}sk )-    , ServerDB(A, sk)-    ]-  --[ Revoked(sk) ]->-    [ ServerDB(A, skNew)-    , Out( sk )+rule Client_LeakKey:+    [ AwaitConfirmation(request,sk)+    , !ServerPK(pkServer)+    , In(sig)     ]+  --[ Eq(verify(sig, <'confirm', request>, pkServer), true)+    , Revoked(sk)+    ]->+    [ Out(sk) ] -// Typing lemma: it can be proven, but not with the current heuristic. It-// focuses too much on the first-order part and neglects solving the-// signature. Moreover, it should use an age-based strategy for the goals to-// ensure that it always makes at least some progress.-lemma types [typing]:-  "All sk #i. Revoked(sk) @ i ==>-     ( (Ex #j. KU(sk) @ j & j < i)-     | (Ex #j. HonestKey(sk) @ j & j < i)-     )-  "-/*-The following property proven in Moedersheim's paper is rather easy to-prove, as it depends only on the fact that secret keys are not leaked by-any other means than the "RenewKey" rule. The "RenewKey" rule always log's-that the key is "Revoked", which directly implies the lemma below.+/* The server updating his database. See the comment above for the change in+   leaking the private key. The original rule in [1] is -TODO: Prove property that depends on ordering of revocation. For example,-DH-key exchange always succeeds for a protocol with an online key-server. This-crucially depends on the client not sending a renewal message while he's-waiting for the key confirmation.+     \S,U.+     iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid).+     forall U,Sts. NPK notin db(S,U,Sts)+     =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK));++   The leaking of 'inv(PK)' is unrealistic as the server only learns the+   public key of new messages. */+rule Server_RenewKey:+  let request = <'renew', A, pkNew>+  in+    [ In( <request, requestSig> )+    , ServerDB(A, pk(sk))+    , !ServerSK(skServer)+    ]+  --[ Eq(verify(requestSig, request, pk(sk)), true)+    ]->+    [ ServerDB(A, pkNew)+    , Out(sign{'confirm', requestSig}skServer)+    ] +// We assume that rule's are only executed if their equality checks succeed.+axiom Eq_checks_succeed: "All x y #i. Eq(x,y) @ i ==> x = y" -// \S,H.-// iknows(inv(PK)).PK in db(S,H,valid)-// =>attack;-lemma In_Honest_Key_imp_Revoked:+/* The following property proven in Moedersheim's paper is rather easy to+   prove, as it depends only on the fact that secret keys are not leaked by+   any other means than the "RenewKey" rule. The "RenewKey" rule always log's+   that the key is "Revoked", which directly implies the lemma below.++     \S,H.+     iknows(inv(PK)).PK in db(S,H,valid)+     =>attack;+*/++lemma Knows_Honest_Key_imp_Revoked:   "All sk #i #d. HonestKey(sk) @ i & K(sk) @ d ==>       (Ex #r. Revoked(sk) @ r)   " +/*+/* Sanity check. Commented out for runtime comparison to [1]. */+lemma Honest_Revoked_Known_Reachable:+  exists-trace+  "(Ex sk #i #j #r. HonestKey(sk) @ i+                  & K(sk) @ j+                  & Revoked(sk) @ r+   )"+*/  end+
− data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy 
@@ -1,149 +0,0 @@-theory StatVerif_Example1 begin--/*-   Protocol:    Simple security device (Example 1 from [1])-   Modeler:     Simon Meier-   Date:        May 2012--   Status:      working--   This is the simple security device example presented in Section V.A of the-   following paper.--   [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful-   Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011.--   It models a hardware device that stores both a private key and a-   configuration register that can be set to 'left' for decrypting the first-   component of tuples encrypted using the device's public key and 'right' for-   decrypting the second component of tuples encrypted using the device's-   public key. Alice uses such a device to encrypt tuples such that Bob-   can access either all their first components or all their second-   components, but never both.--   Note that in contrast to [1], we allow the creation of an unbounded number-   of devices. We also verify both the accessibility of left and right-   components, as well as their exclusivity. The source code of the model-   from [1] is attached at the end of this file.--*/--builtins: asymmetric-encryption---// Create a new device. It stores the private key and publishes the-// corresponding public key.-rule NewDevice:-    [ Fr(~sk)  // We let the key identify the device.-    ]-  -->-    [  UnconfiguredDevice(~sk)-    , !DevicePublicKey(pk(~sk))-    ,  Out(pk(~sk))-    ]--// Alice can use any public key associated to such a hardware security device-// for publishing messages with exclusive access.-rule Alice:-    [  Fr(~x)-    ,  Fr(~y)-    , !DevicePublicKey(key)-    ]-  --[ Exclusive(~x,~y) ]->-    [ Out( aenc{~x,~y}key )-    ]--// Unconfigured devices can be configured exactly once.-rule ConfigureDevice:-    [ UnconfiguredDevice(sk), In(config) ]-    -->-    [ !ConfiguredDevice(sk, config) ]--// Devices configured to 'left' can be used to decrypt the first component of-// messages encrypted using the device's public key.-rule UseLeftDevice:-    [ !ConfiguredDevice(sk, 'left'), In(aenc{x,y}pk(sk)) ]-  --[ Access(x) ]->-    [ Out(x) ]--// Devices configured to 'right' can be used to decrypt the second component of-// messages encrypted using the device's public key.-rule UseRightDevice:-    [ !ConfiguredDevice(sk, 'right'), In(aenc{x,y}pk(sk)) ]-  --[ Access(y) ]->-    [ Out(y) ]---// As we use a backwards search, we must specify the possible structure of-// messages sent in 'UseLeftDevice' and 'UseRightDevice' precise enough such-// that we can solve all chain constraints starting from the sent message. We-// therefore log the message being accessed and relate it to its possible-// origins: known to the intruder in an earlier step or part of an exclusive-// message generated by 'Alice'. Typing lemmas are proven by induction and-// incorporated in the case distinction precomputation.-lemma types [typing]:-  "All m #i. Access(m) @ i ==>-      (Ex #j. KU(m) @ j & j < i)  // Make use of the KU-facts logged-                                  // by the construction rules.-    | (Ex x #j. Exclusive(x,m) @ j)-    | (Ex y #j. Exclusive(m,y) @ j)-  "--// Check that there is some trace where the intruder knows the left message of-// an exclusive message-tuple. In contrast to the typing lemma, we use the-// standard 'K'-fact, which is logged by the built-in 'ISend' rule.-lemma reachability_left:-  exists-trace-  "Ex x y #i #j. Exclusive(x,y) @i & K(x) @ j"--lemma reachability_right:-  exists-trace-  "Ex x y #i #k. Exclusive(x,y) @i & K(y) @ k"--// Check that exclusivity is maintained-lemma secrecy:-  "not(Ex x y #i #k1 #k2.-         Exclusive(x,y) @i & K(x) @ k1 & K(y) @ k2-      )-  "--end--/* StatVerif source code of the original model from [1].--fun pair/2.-fun aenc/3.-fun pk/1.-free left.-free right.-free init.-free c.--reduc-    projl(pair(xleft, xright)) = xleft;-    projr(pair(xleft, xright)) = xright;-    adec(u, aenc(pk(u), v, w)) = w.--query-    att:vs,pair(sl,sr).--let device =-    out(c, pk(k)) |-    ( ! lock(s); in(c, x); read s as y;-        if y = init then-            (if x = left then s := x; unlock(s)-            else if x = right then s := x; unlock(s))  ) |-    ( ! lock(s); in(c, x); read s as y; let z = adec(k, x) in-        let zl = projl(z) in-        let zr = projr(z) in-        ((if y = left then out(c, zl); unlock(s)) |-         (if y = right then out(c, zr); unlock(s)))).--let user =-    new sl; new sr; new r;-        out(c, aenc(pk(k), r, pair(sl,sr))).--process-    new k; new s; [s |-> init] | device | ! user--*/
+ data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_GM_Contract_Signing.spthy view
@@ -0,0 +1,305 @@+theory StatVerif_GM_Contract_Signing begin++/*+   Protocol:    Contract Signing Protocol (Example 2 from [1])+   Modeler:     Simon Meier <iridcode@gmail.com>+   Date:        September 2012++   Status:      working++   This is the contract signing example presented in Section V.B of the+   following paper.++   [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful+   Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011.++   It models the two-party version of the contract signing protocol proposed+   in++   [2] Juan A. Garay, Markus Jakobsson, and Philip D. MacKenzie. Abuse-free+   optimistic contract signing. In Michael J. Wiener, editor, CRYPTO, volume+   1666 of Lecture Notes in Computer Science, pages 449–466. Springer, 1999.++   Note that in contrast to [1], we do not require any protocol-specific+   abstraction, as we support reasoning about state under replication.++*/++functions:+  pk/1, sign/2, pcs/3, check_getmsg/2, checkpcs/5, true/0, convertpcs/2++equations:+  // Checking and getting the message in a standard signature+    check_getmsg(pk(xsk), sign(xsk, xm)) = xm++  , checkpcs(xc, pk(xsk), ypk, zpk, pcs(sign(xsk, xc), ypk, zpk)) = true()++  , convertpcs(zsk, pcs(sign(xsk, xc), ypk, pk(zsk))) = sign(xsk, xc)+  /*+    The above two equations are inspired by the following design decisions.+    We model a private signature of a contract 'xc' that is+      - meant for 'y' identified by his public key 'ypk'+      - privately signed by 'x' using his private key 'xsk'+      - to be converted by the trusted party 'z' identified by its public key+        'zpk'+     using the term 'pcs(sign(xsk, xc), ypk, zpk)'.++     This term chan be checked against 'xc', 'pk(xsk)', ypk, and zpk using+     the 'checkpcs' algorithm.++     It can be converted to a standard signature using the 'convertpcs'+     algorithm provided one has access to the private key of the trusted+     party.++     Note that we embedd the proper standard signature immediately into the+     'pcs' term, as the resulting equational theory is not subterm-convergent+     otherwise.+  */++// Setting up the trusted third party, i.e., choose its signing key+rule Setup_TTP:+  [ Fr(seed) ] --> [ !TTP(seed), Out(pk(seed)) ]++// Our goal is to check that the TTP cannot be abused to provide the adversary+// with both a certificate that the contract was resolved and a certificate+// that the contract was aborted.++// The TTP answering an 'abort' request.+rule Abort1:+  let msg      = <ct, pk1, pk2, pcsig1>+      abortSig = sign(skT, pcsig1)+  in+    [ !TTP(skT)+    , In(<'abort', msg>)+    ]+  --[ // The TTP answers at most once per contract.+      Answered(ct)+      // Check signatures. This is essential. Try uncommenting it and check+      // the resulting attacks.+    , Eq(checkpcs(ct, pk1, pk2, pk(skT), pcsig1), true)+      // Log this action for referencing it in properties+    , Abort1(ct)+    ]->+    [ Out(abortSig) ]++// We refrain from modelling the repeated answering with the same answer.+// It would be easy to model, but does obviously not strengthen the adversary.++// The TTP answering a resolve request by party 2.+rule Resolve2:+  let msg        = <ct, pk1, pk2, pcsig1, sig2>+      sig1       = convertpcs(skT, pcsig1)+      resolveSig = sign(skT, <sig1, sig2>)+  in+    [ !TTP(skT)+    , In(<'resolve2', msg>)+    ]+  --[ // The TTP answers at most once per contract.+      Answered(ct)+      // Check signatures+    , Eq(check_getmsg(pk2, sig2), ct)+    , Eq(checkpcs(ct, pk1, pk2, pk(skT), pcsig1), true)+      // Log this action for referencing it in properties+    , Resolve2(ct)+    ]->+    [ Out(resolveSig) ]++// The TTP answering a resolve request by party 1.+rule Resolve1:+  let msg        = <ct, pk1, pk2, sig1, pcsig2>+      sig2       = convertpcs(skT, pcsig2)+      resolveSig = sign(skT, <sig1, sig2>)+  in+    [ !TTP(skT)+    , In(<'resolve1', msg>)+    ]+  --[ // The TTP answers at most once per contract.+      Answered(ct)+      // Check signatures+    , Eq(check_getmsg(pk1, sig1), ct)+    , Eq(checkpcs(ct, pk2, pk1, pk(skT), pcsig2), true)+      // Log this action for referencing it in properties+    , Resolve1(ct)+    ]->+    [ Out(resolveSig) ]+++// Witnessing aborted contracts.+rule Witness_Aborted:+  let abortC = sign(skT, pcs(sign(sk1, ct), pk(ysk), pk(skT)))+  in+    [ In(abortC), !TTP(skT) ] --[ AbortCert(ct) ]-> []++// Witnessing resolved contracts.+rule Witness_Resolved:+  let resolveC = sign(skT, <sign(sk1, ct), sign(sk2, ct)>)+  in+    [ In(resolveC), !TTP(skT) ] --[ ResolveCert(ct) ]-> []+++// Axiom: the TTP does not answer any request twice+axiom Answered_unique:+    "All x #i #j. Answered(x) @ i & Answered(x) @ j ==> #i = #j"++// Axiom: the TTP stops if an equality check fails+axiom Eq_checks_succeed: "All x y #i. Eq(x,y) @ i ==> x = y"+++/*+Our desired goal: there is not contract where the adversary can present+both an abort-certificate and a resolve-certificate. This is what is+verified in [1]. It is almost trivial, as it only relies on the uniqueness+check and properly checking the signatures.++TODO: Investigate more interesting properties. Especially properties from the+perspective of the local agents.+*/+lemma aborted_and_resolved_exclusive:+  "not (Ex ct #i #j. AbortCert(ct) @ i & ResolveCert(ct) @ j)"++// Sanity checks: The terms reductions behave as expected.+lemma aborted_contract_reachable:+  exists-trace+  " (Ex ct #i. AbortCert(ct) @ i )+    // Ensure that this is possible with at most one Abort step.+  & (All ct1 ct2 #i1 #i2 .+       Abort1(ct1) @ i1 & Abort1(ct2) @ i2 ==> #i1 = #i2)+  & (All ct #i. Resolve1(ct) @ i ==> F)+  & (All ct #i. Resolve2(ct) @ i ==> F)+  "++lemma resolved1_contract_reachable:+  exists-trace+  " (Ex ct #i. ResolveCert(ct) @ i)+    // Ensure that this is possible with at most one Resolve1 step.+  & (All ct #i. Abort1(ct) @ i ==> F)+  & (All ct1 ct2 #i1 #i2 .+       Resolve1(ct1) @ i1 & Resolve1(ct2) @ i2 ==> #i1 = #i2)+  & (All ct #i. Resolve2(ct) @ i ==> F)+  "++lemma resolved2_contract_reachable:+  exists-trace+  "(Ex ct #i. ResolveCert(ct) @ i)+    // Ensure that this is possible with at most one Resolve1 step.+  & (All ct #i. Abort1(ct) @ i ==> F)+  & (All ct #i. Resolve1(ct) @ i ==> F)+  & (All ct1 ct2 #i1 #i2 .+       Resolve2(ct1) @ i1 & Resolve2(ct2) @ i2 ==> #i1 = #i2)+  "+++/*+Original code from [1]. There is a strange discrepance between the description+of the protocol in [1, Figure 5] and the implementation here. The Abort1+process does not check for a private contract signature, but for a standard+signature. However, the query listed on [1, page 12] considers a TTP-signed+pcs as the abort-certificate.+*/++/*++free c.+free init.+free ok.+free abort.+free resolve1.+free resolve2.+free aborted.+free resolved.+free wtn_contract.+free skA.+free skB.++fun pair/2.+fun pk/1.+fun sign/2.+fun pcs/4.++reduc projl(pair(xl, xr)) = xl.+reduc projr(pair(xl, xr)) = xr.++reduc check_getmsg(pk(xsk), sign(xsk, xm)) = xm.++reduc checkpcs(xc, pk(xsk), ypk, zpk, pcs(xsk, ypk, zpk, xc)) = ok.+reduc convertpcs(zsk, pcs(xsk, ypk, pk(zsk), xc)) = sign(xsk, xc).++let T =+  new skT; (out(c, pk(skT)) | ! C)++let C =+  new s; new ct;+  [s -> pair(init, init)] |+    out(c, ct); in(c, xpk1); in(c, xpk2);+    ( ! Abort1 | ! Resolve2 | ! Resolve1 )++let Abort1 =+  lock;+  in(c, x);+  let xcmd = projl(x) in+  if xcmd = abort then+    let y = projr(x) in+    let yl = projl(y) in+    let ycontract = projl(yl) in+    let yparties = projr(yl) in+    if yparties = pair(xpk1, xpk2) then+      if ycontract = ct then+        let ysig = projr(y) in+        let ym = check_getmsg(xpk1, ysig) in+        if ym = yl then+          read s as ys;+          let ystatus = projl(ys) in+          (if ystatus = aborted then+            let ysigs = projr(ys) in+            out(c, ysigs); unlock) |+          (if ystatus = init then+            s := pair(aborted, sign(skT, y));+            out(c, sign(skT, y)); unlock)++let Resolve2 =+  lock;+  in(c, x);+  let xcmd = projl(x) in+  if xcmd = resolve2 then+    let y = projr(x) in+    let ypcs1 = projl(y) in+    let ysig2 = projr(y) in+    let ycontract = check_getmsg(xpk2, ysig2) in+    if ycontract = ct then+      let ycheck = checkpcs(ct, xpk1, xpk2, pk(skT), ypcs1) in+      if ycheck = ok then+        read s as ys;+        let ystatus = projl(ys) in+        (if ystatus = resolved2 then+          let ysigs = projr(ys) in+          out(c, ysigs); unlock) |+        (if ystatus = init then+          let ysig1 = convertpcs(skT, ypcs1) in+          s := pair(resolved2, sign(skT, pair(ysig1, ysig2)));+          out(c, sign(skT, pair(ysig1, ysig2))); unlock)++let Resolve1 =+  lock;+  in(c, x);+  let xcmd = projl(x) in+  if xcmd = resolve1 then+    let y = projr(x) in+    let ysig1 = projl(y) in+    let ypcs2 = projr(y) in+    let ycontract = check_getmsg(xpk1, ysig1) in+    if ycontract = ct then+      let ycheck = checkpcs(ct, xpk2, xpk1, pk(skT), ypcs2) in+      if ycheck = ok then+        read s as ys;+        let ystatus = projl(ys) in+        (if ystatus = resolved1 then+          let ysigs = projr(ys) in+          out(c, ysigs); unlock) |+        (if ystatus = init then+          let ysig2 = convertpcs(skT, ypcs2) in+          s := pair(resolved1, sign(skT, pair(ysig1, ysig2)));+          out(c, sign(skT, pair(ysig1,ysig2))); unlock)++*/++end
+ data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Security_Device.spthy view
@@ -0,0 +1,149 @@+theory StatVerif_Security_Device begin++/*+   Protocol:    Simple security device (Example 1 from [1])+   Modeler:     Simon Meier+   Date:        May 2012++   Status:      working++   This is the simple security device example presented in Section V.A of the+   following paper.++   [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful+   Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011.++   It models a hardware device that stores both a private key and a+   configuration register that can be set to 'left' for decrypting the first+   component of tuples encrypted using the device's public key and 'right' for+   decrypting the second component of tuples encrypted using the device's+   public key. Alice uses such a device to encrypt tuples such that Bob+   can access either all their first components or all their second+   components, but never both.++   Note that in contrast to [1], we allow the creation of an unbounded number+   of devices. We also verify both the accessibility of left and right+   components, as well as their exclusivity. The source code of the model+   from [1] is attached at the end of this file.++*/++builtins: asymmetric-encryption+++// Create a new device. It stores the private key and publishes the+// corresponding public key.+rule NewDevice:+    [ Fr(~sk)  // We let the key identify the device.+    ]+  -->+    [  UnconfiguredDevice(~sk)+    , !DevicePublicKey(pk(~sk))+    ,  Out(pk(~sk))+    ]++// Alice can use any public key associated to such a hardware security device+// for publishing messages with exclusive access.+rule Alice:+    [  Fr(~x)+    ,  Fr(~y)+    , !DevicePublicKey(key)+    ]+  --[ Exclusive(~x,~y) ]->+    [ Out( aenc{~x,~y}key )+    ]++// Unconfigured devices can be configured exactly once.+rule ConfigureDevice:+    [ UnconfiguredDevice(sk), In(config) ]+    -->+    [ !ConfiguredDevice(sk, config) ]++// Devices configured to 'left' can be used to decrypt the first component of+// messages encrypted using the device's public key.+rule UseLeftDevice:+    [ !ConfiguredDevice(sk, 'left'), In(aenc{x,y}pk(sk)) ]+  --[ Access(x) ]->+    [ Out(x) ]++// Devices configured to 'right' can be used to decrypt the second component of+// messages encrypted using the device's public key.+rule UseRightDevice:+    [ !ConfiguredDevice(sk, 'right'), In(aenc{x,y}pk(sk)) ]+  --[ Access(y) ]->+    [ Out(y) ]+++// As we use a backwards search, we must specify the possible structure of+// messages sent in 'UseLeftDevice' and 'UseRightDevice' precise enough such+// that we can solve all chain constraints starting from the sent message. We+// therefore log the message being accessed and relate it to its possible+// origins: known to the intruder in an earlier step or part of an exclusive+// message generated by 'Alice'. Typing lemmas are proven by induction and+// incorporated in the case distinction precomputation.+lemma types [typing]:+  "All m #i. Access(m) @ i ==>+      (Ex #j. KU(m) @ j & j < i)  // Make use of the KU-facts logged+                                  // by the construction rules.+    | (Ex x #j. Exclusive(x,m) @ j)+    | (Ex y #j. Exclusive(m,y) @ j)+  "++// Check that there is some trace where the intruder knows the left message of+// an exclusive message-tuple. In contrast to the typing lemma, we use the+// standard 'K'-fact, which is logged by the built-in 'ISend' rule.+lemma reachability_left:+  exists-trace+  "Ex x y #i #j. Exclusive(x,y) @i & K(x) @ j"++lemma reachability_right:+  exists-trace+  "Ex x y #i #k. Exclusive(x,y) @i & K(y) @ k"++// Check that exclusivity is maintained+lemma secrecy:+  "not(Ex x y #i #k1 #k2.+         Exclusive(x,y) @i & K(x) @ k1 & K(y) @ k2+      )+  "++end++/* StatVerif source code of the original model from [1].++fun pair/2.+fun aenc/3.+fun pk/1.+free left.+free right.+free init.+free c.++reduc+    projl(pair(xleft, xright)) = xleft;+    projr(pair(xleft, xright)) = xright;+    adec(u, aenc(pk(u), v, w)) = w.++query+    att:vs,pair(sl,sr).++let device =+    out(c, pk(k)) |+    ( ! lock(s); in(c, x); read s as y;+        if y = init then+            (if x = left then s := x; unlock(s)+            else if x = right then s := x; unlock(s))  ) |+    ( ! lock(s); in(c, x); read s as y; let z = adec(k, x) in+        let zl = projl(z) in+        let zr = projr(z) in+        ((if y = left then out(c, zl); unlock(s)) |+         (if y = right then out(c, zr); unlock(s)))).++let user =+    new sl; new sr; new r;+        out(c, aenc(pk(k), r, pair(sl,sr))).++process+    new k; new s; [s |-> init] | device | ! user++*/
data/examples/related_work/TPM_DKRS_CSF11/Envelope.spthy view
@@ -1,21 +1,32 @@ theory TPM_Envelope begin -text{* Envelope protocol example from:+/*+  Protocol: The Envelope protocol modeled according to [1]+  Modeler: Simon Meier+  Date:    September 2012+  Status:  Working -[1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal-Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 IEEE-24th Computer Security Foundations Symposium, 2011.+  [1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal+  Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011+  IEEE 24th Computer Security Foundations Symposium, 2011. -Modeler: Simon Meier-Date:    June 2012-Status:  No automatic proof (interactive proof possible)+  Note that this model can also be verified for an arbitrary number of+  reboots. This is an open problem in [1]. The verification relies on the+  construction that we track all writes to the PCR-fact using the additional+  PCR_Write-fact. This allows us then to descend in the hash chain by solving+  PCR_Write-premises. -Note that this model incorporates an arbitrary number of reboots, which is an-open problem in [1]. The verification relies on the construction that we track-all writes to the PCR-fact using the additional PCR_Write-fact. This allows us-then to descend in the hash chain by solving PCR_Write-premises.+  Note also that verification without a reboot takes 19 seconds on an Intel i7+  Quad Core laptop with 4GB RAM. This is two orders of magnitude faster than+  the time reported for [1]; 35min according to+  http://www.lsv.ens-cachan.fr/~delaune/TPM-PCR/. -*}+  The verification with reboot takes 75 seconds on this Intel i7 laptop. The+  key reason why both of these times are so high is that the heuristic has+  trouble discerning between the useful looping goals and the useless ones. A+  manual proof can be much shorter than the one automatically produced.+  Investigating a better heuristic is future work.+*/  builtins: signing, asymmetric-encryption, hashing @@ -35,16 +46,21 @@     , Out(pk(~aik))        // publish the public key of the auth. id. key     ] -// reset the PCR to 'pcr0'+// reset the PCR to 'pcr0'. The proof goes also through with reboot, but takes+// considerably longer: about 1m 20sec on my i7 laptop. However, this is only+// a problem with the heuristic. The interactively constructed proof given+// below requires only 28 steps and 0.5 seconds to check.+/* rule PCR_Reboot:-    [ PCR(x)-    , PCR_Write(x)-    ]-  --[ PCR_Write('pcr0')-    ]->-    [ PCR_Write('pcr0')-    , PCR('pcr0')-    ]+     [ PCR(x)+     , PCR_Write(x)+     ]+   --[ PCR_Write('pcr0')+     ]->+     [ PCR_Write('pcr0')+     , PCR('pcr0')+     ]+*/  // Extend the hash-chain in the PCR rule PCR_Extend:@@ -146,7 +162,16 @@     , Out(pk(~sk))     ] -// Automatically proven+// Axioms; i.e., restrictions on the traces of interest+///////////////////////////////////////////////////////++axiom PCR_Init_unique:+  " All #i #j. PCR_Init() @ i & PCR_Init() @ j ==> #i = #j "++// Security Properties+//////////////////////++// Characterizing the values extractible via unbinding. lemma types [typing]:     // Values created by the PCR_Unbind rule   " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==>@@ -155,7 +180,8 @@     )   " -// Automatically proven+// Every read value was written once. This allows us to reason backwards and+// ensure that the PCR value becomes smaller. lemma PCR_Write_charn [reuse, use_induction]:     // Values read from the PCR have been written to it beforehand.   " (All x #i. PCR_Read(x) @ i ==>@@ -163,17 +189,107 @@     )   " -// Assuming that there is at most one instance of the PCR,-// the adversary (playing Bob) must not know a secret that Alice created and-// thinks that access to it was denied.-//-// Currently, we have to construct its proof manually. The key argument relies-// on following the PCR_Write-premises once their presence has been-// established via the PCR_Write_charn lemma.-lemma reachable_Denied:-  "(All #i #j. PCR_Init() @ i & PCR_Init() @ j ==> #i = #j)-   ==>-   not(Ex s #i #j #k. Secret(s) @ i & Denied(s) @ j & K(s) @ k)"+// The desired security property: the adversary (Bob) cannot know a secret to+// which he officially denied having access.+lemma Secret_and_Denied_exclusive:+   " not(Ex s #i #j #k. Secret(s) @ i & Denied(s) @ j & K(s) @ k)"+/* Note that the 28 steps of the proof below suffices to justify this lemma+   even with the reboot rule enabled. The heuristic is stymied by the looping+   PCR facts and acts too conservatively, thereby using significantly more+   proof steps (7136) and time (74 seconds).+*/+/*+simplify+solve( Alice1( n ) ▶₀ #i )+  case Alice1+  solve( !AIK( aik ) ▶₂ #i )+    case PCR_Init+    solve( Alice2( n.1, ~s ) ▶₀ #j )+      case Alice2+      solve( !AIK( aik.1 ) ▶₁ #j )+        case PCR_Init+        solve( !KU( sign(<'certkey',+                          h(<h(<'pcr0', ~n>), 'obtain'>), pk>,+                         ~aik)+               ) @ #vk )+          case PCR_CertKey+          solve( !KU( sign(<'certpcr',+                            h(<h(<'pcr0', ~n>), 'deny'>)>,+                           ~aik)+                 ) @ #vk.1 )+            case PCR_Quote+            solve( PCR_Write( h(<h(<'pcr0', ~n>),+                                 'deny'>)+                   ) @ #j.2 )+              case PCR_Extend+              solve( !KU( ~s ) @ #vk.2 )+                case Alice2+                by solve( !KU( ~sk ) @ #vk.5 )+              next+                case PCR_Unbind+                solve( !KU( aenc(~s, pk(~sk.1)) ) @ #vk.5 )+                  case Alice2+                  solve( PCR_Write( h(<h(<'pcr0', ~n>),+                                       'obtain'>)+                         ) @ #j.3 )+                    case PCR_Extend+                    solve( PCR_Write( h(<'pcr0', ~n>) ) @ #j.4 )+                      case Alice1+                      solve( PCR_Write( h(<'pcr0', ~n>) ) @ #j.3 )+                        case Alice1+                        solve( PCR_Write( 'pcr0' ) ▶₂ #vr )+                          case PCR_Init+                          solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.1 )+                            case Alice1+                            solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.2 )+                              case PCR_Extend+                              by solve( !KU( ~n ) @ #vk.6 )+                            qed+                          next+                            case PCR_Extend+                            by solve( !KU( ~n ) @ #vk.6 )+                          qed+                        next+                          case PCR_Reboot+                          solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.1 )+                            case Alice1+                            solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.2 )+                              case PCR_Extend+                              by solve( !KU( ~n ) @ #vk.6 )+                            qed+                          next+                            case PCR_Extend+                            by solve( !KU( ~n ) @ #vk.6 )+                          qed+                        qed+                      next+                        case PCR_Extend+                        by solve( !KU( ~n ) @ #vk.6 )+                      qed+                    next+                      case PCR_Extend+                      by solve( !KU( ~n ) @ #vk.6 )+                    qed+                  qed+                next+                  case caenc+                  by contradiction+                qed+              qed+            qed+          next+            case csign+            by solve( !KU( ~aik ) @ #vk.5 )+          qed+        next+          case csign+          by solve( !KU( ~aik ) @ #vk.4 )+        qed+      qed+    qed+  qed+qed+*/   end
− data/examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy 
@@ -1,123 +0,0 @@-theory CSF11_RunningExample begin--text{* Running example from:--Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal Analysis-of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 IEEE 24th-Computer Security Foundations Symposium, 2011.--Modeler: Simon Meier-Date:    June 2012-Status:  Working--*}--builtins: hashing, asymmetric-encryption, signing--// TPM PCR model-rule PCR_Init:-    [ Fr(~aik)          // Authentication identity key-    ]-  --[ PCR_Init('pcr0',~aik)-    , UniqueInit()      // For removing traces that have multiple initializations-    ]->-    [ PCR('pcr0')       // the initial PCR value is 'pcr0'-    , !AIK(~aik)        // the auth. id. key is persistent-    , Out(pk(~aik))     // publish the public key of the auth. id. key-    ]---// Disabled, as the protocol is not secure under reboots.-// TODO: Check that we can find the attack.-//-// Note that we miss the attack, as we do not consider collapsing different-// PCR_Unbind nodes. In order to find this attack, we would require to-// introduce strongly different node variables.-//-// rule PCR_Reboot:-//     [ PCR(x) ] --> [ PCR('pcr0') ]  // reset the PCR to 'pcr0'--rule PCR_Extend:-    [ PCR(x)-    , In(y)-    ]-  --[ PCR_Extend(x,y,h(x,y))-    ]->-    [ PCR(h(x,y))-    ]--rule PCR_CertKey:-    [ !AIK(aik)-    , !KeyTable(x, sk)-    ]-  --[ PCR_CertKey_Inst(x)-    ]->-    [ Out(sign{'certkey', x, pk(sk)}aik) ]--rule PCR_Unbind:-    [ PCR(x)-    , !KeyTable(x, sk)-    , In( aenc{m}pk(sk) )-    ]-  --[ PCR_Unbind(x,sk,m)-    ]->-    [ PCR(x)-    , Out(m) ]--// Alice-rule Alice_Init:-    [ Fr(~s0)-    , Fr(~s1)-    , !AIK(aik)-    , In(sign{'certkey', x0, pk0}aik)-    , In(sign{'certkey', x1, pk1}aik)-    ]-  --[ Ineq(x0, x1)-    , Secrets(~s0,~s1)-    ]->-    [ Out(aenc{~s0}pk0)-    , Out(aenc{~s1}pk1)-    ]--// Keytable-rule MkKey:-    // Fr(<'MkKey',$a>)  // register at most one key per public constant-    [ Fr(~ska) ]-    -->-    [ !KeyTable(h('pcr0',$a), ~ska) ]--lemma types [typing]:-  " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==>-        (Ex #j.   KU(m) @ j & j < i)-      | (Ex s #j. Secrets(m, s) @ j)-      | (Ex s #j. Secrets(s, m) @ j)-    )-  "--lemma Unbind_PCR_Value [reuse, use_induction]:-    "All x sk m #i.-        PCR_Unbind(x, sk, m) @ i-        ==>-        ( (Ex aik #j.     PCR_Init(x, aik) @ j  )-        | (Ex y xPrev #j. PCR_Extend(xPrev,y,x) @ j)-        | (Ex #i #j. UniqueInit() @ j & UniqueInit() @ i & not (#i = #j))-        )-    "--lemma secrecy:-  " ( (All #i #j. UniqueInit() @ j & UniqueInit() @ i ==> #i = #j)-    & (All t #e. Ineq(t,t) @ e ==> F)-    ) ==>-    not( (Ex s0 s1 #i #d0 #d1.-             Secrets(s0, s1) @ i-           & K(s0) @ d0-           & K(s1) @ d1-       ) )"--------end
+ data/examples/related_work/TPM_DKRS_CSF11/TPM_Exclusive_Secrets.spthy view
@@ -0,0 +1,167 @@+theory TPM_Exclusive_Secrets begin++/*+    Protocol: Running example from [1]+    Modeler: Simon Meier+    Date:    September 2012+    Status:  Working++    [1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal+    Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011+    IEEE 24th Computer Security Foundations Symposium, 2011.++    The goal of this example is to verify that the adversary cannot exploit+    his TPM to simultainously access the two secrets that were encryped+    exclusively by Alice.++    Note that we could easily model multiple PCR's, if required.++*/++builtins: hashing, asymmetric-encryption, signing++// TPM Model with support for a single PCRs+///////////////////////////////////////////++rule PCR_Init:+    [ Fr(~aik)          // Authentication identity key+    ]+  --[ PCR_Init('pcr0',~aik)+    , UniqueInit()      // For removing traces that have multiple initializations+    ]->+    [ PCR('pcr0')       // the initial PCR value is 'pcr0'+    , !AIK(~aik)        // the auth. id. key is persistent+    , Out(pk(~aik))     // publish the public key of the attest. ident. key+    ]+++// Disabled, as the protocol is not secure under reboots.+//+// Note that we miss the attack, as we do not consider collapsing different+// PCR_Unbind nodes by default. The general construction would require+// distinctness constraints on temporal variables. We can however simulate it+// by proving a simple case distinction lemma with a 'reuse' attribute, as+// demonstrated below.+//+// rule PCR_Reboot:+//    [ PCR(x) ] --> [ PCR('pcr0') ]  // reset the PCR to 'pcr0'++// Extending the PCR register with the value 'y'+rule PCR_Extend:+    [ PCR(x) , In(y) ] --[ PCR_Extend(x,y,h(x,y)) ]-> [ PCR(h(x,y)) ]++// Create a fresh  key that is bound to 'pcr0' extended with a public+// constant.+rule PCR_CreateKey:+    [ Fr(~ska) ] --> [ !KeyTable(h('pcr0',$a), ~ska) ]++// Certifying a key using the TPM's Attestation Identity Key (AIK)+rule PCR_CertKey:+    [ !AIK(aik)+    , !KeyTable(x, sk)   // Any key in the keytable can be certified.+    ]+  --[ PCR_CertKey_Inst(x)+    ]->+    [ Out(sign{'certkey', x, pk(sk)}aik) ]++// Keys in the keytable are bound to a fixed PCR value. If this value, agrees+// with the actual PCR value, then the TPM can be used to decrypt messages+// encrypted with these keys.+rule PCR_Unbind:+    [ PCR(x)+    , !KeyTable(x, sk)+    , In( aenc{m}pk(sk) )+    ]+  --[ PCR_Unbind(x,sk,m)+    ]->+    [ PCR(x) , Out(m) ]++// Alice generates two secrets and accepts two *different* keys signed by the+// TPM to provide exlusive access to them. We are a bit lazy here and use+// pattern matching for the signature verification.+rule Alice_Init:+    [ Fr(~s0)+    , Fr(~s1)+    , !AIK(aik)+    , In(sign{'certkey', x0, pk0}aik)+    , In(sign{'certkey', x1, pk1}aik)+    ]+  --[ InEq(x0, x1)+    , Secrets(~s0,~s1)+    ]->+    [ Out(aenc{~s0}pk0)+    , Out(aenc{~s1}pk1)+    ]++++// Axioms; i.e., restrictions on the set of traces of interest+//////////////////////////////////////////////////////////////++axiom UniqueInit_unique:+  " All #i #j. UniqueInit() @ j & UniqueInit() @ i ==> #i = #j "++axiom Ineq_checks_succeed:+  " All t #e. InEq(t,t) @ e ==> F "+++// Security Properties+//////////////////////+++// A type invariant characterizing the values that can be learned using the+// TPM to Unbind (i.e., decrypt) messages.+lemma types [typing]:+  " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==>+        (Ex #j.   KU(m) @ j & j < i)+      | (Ex s #j. Secrets(m, s) @ j)+      | (Ex s #j. Secrets(s, m) @ j)+    )+  "++// Characterizing the unbinding operation. This is the key lemma. It allows us+// to jump backwards to smaller values of the PCR register during reasoning.+lemma Unbind_PCR_charn [reuse, use_induction]:+    "All x sk m #i.+        // If the key 'sk' bound to PCR value 'x' is used to extract the body+        // 'm' of an encryption, then+        PCR_Unbind(x, sk, m) @ i+        ==>+        // 'x' is the initial PCR value+        ( (Ex aik #j.     PCR_Init(x, aik) @ j  )+        // or it was the result of an extension.+        | (Ex y xPrev #j. PCR_Extend(xPrev,y,x) @ j)+        )+    "++// Uncomment to perform case distinctions on the identity of different+// PCR_Unbind nodes. This is required to find the attack when using reboots.+/*+lemma PCR_Unbind_case_distinctions [reuse]:+  "All d11 d21 m1 #i1 d12 d22 m2 #i2.+      PCR_Unbind(d11, d21, m1) @ i1+    & PCR_Unbind(d12, d22, m2) @ i2+    ==>+      (#i1 = #i2) | not(#i1 = #i2)+  "+*/++// The desired security property+lemma exclusive_secrets:+  " not(Ex s0 s1 #i #d0 #d1.+           Secrets(s0, s1) @ i+         & K(s0) @ d0+         & K(s1) @ d1+       )"++// Sanity check: both secrets can be accessed individually.+lemma left_reachable:+  exists-trace+  " Ex s0 s1 #i #j.  Secrets(s0, s1) @ i & K(s0) @ j "++lemma right_reachable:+  exists-trace+  " Ex s0 s1 #i #j.  Secrets(s0, s1) @ i & K(s1) @ j "+++end
+ data/examples/related_work/YubiSecure_KS_STM12/Yubikey.spthy view
@@ -0,0 +1,227 @@+theory Yubikey+begin++section{* The Yubikey-Protocol *}++/*+ * Protocol:    Yubikey Protocol+ * Modeler:     Robert Kunnemann, Graham Steel+ * Date:    August 2012+ *+ * Status:  working+ */++builtins: symmetric-encryption++functions: S/1,zero/0++/* We to model the Yubikey protocol, described in+*  http://www.yubico.com/documentation+*  http://www.yubico.com/developers-intro+*  This is simplified version, in particular:+*  - timestamps are not modelled+*  - We do not distinguish the session and token counter. We describe them+*    as one single counter, that represents the pair (session counter, token+*    counter) with a lexicographical order on the pair. This implies that+*    a) pressing the button on the Yubikey increases this counter by 1, and+*    b) a plugin of the Yubikey increases it by an arbitrary amount the+*       adversary gets to choose (giving him more power).+*/++/* The following rules model two binary relations between integers. !Succ+ * is functional. If !Succ(a,b), then the adversary was able to show that b+ * is the successor of b. Similarly, albeit !Smaller is not functional, if+ * !Smaller(a,b), then the adversary was able to show that a is smaller+ * than b.+ * The Theory() action is used to enforce that this relation (to the extend+ * it is needed in this trace) has to be build up before running the first+ * protocol actions.+*/+rule InitSucc:+    [In(zero),In(S(zero))]+	 --[Theory(), IsSucc(zero,S(zero)),IsZero(zero)]->+	[!Succ(zero,S(zero))]++rule StepSucc:+    [In(y),In(S(y)), !Succ(x,y)]+	--[Theory(), IsSucc(y,S(y)) ]->+	[!Succ(y,S(y))]++rule SimpleSmaller:+    [!Succ(x,y)]+	--[Theory(), IsSmaller(x,y)]->+	[!Smaller(x,y)]++rule ZExtendedSmaller:+    [!Smaller(x,y),!Succ(y,z)]+	--[Theory(), IsSmaller(x,z)]->+	[!Smaller(x,z)]++/* A Yubikey is initialised with a zero counter, a key and a public, as well as a+ * secret identifier, ~pid and ~sid. This information is shared with the+ * Authentication Server, so we assume a trusted way of installing a+ * Yubikey+*/+rule BuyANewYubikey:+        [Fr(~k),Fr(~pid),Fr(~sid)] //for fresh k, public and secret id..+        --[Protocol(), Init(~pid,~k),ExtendedInit(~pid,~sid,~k),IsZero(zero)]->+        [!Y(~pid,~sid), Y_counter(~pid,zero),+        //..store public and secret id along with the starting counter+        //(zero) on the Yubikey..+		 Server(~pid,~sid,zero),!SharedKey(~pid,~k), //and on the server+         Out(~pid)] //and make the public id public++//On plugin, the session counter is increased and the token counter reset+rule Yubikey_Plugin:+        [Y_counter(pid,sc),!Smaller(sc, Ssc) ] +        //The old counter value sc is removed+        --[ Yubi(pid,Ssc) ]-> +        [Y_counter(pid, Ssc)]+        //and substituted by a new counter value, larger, Ssc++//If the Button is pressed, the token counter is increased+rule Yubikey_PressButton:+        [!Y(pid,sid), Y_counter(pid,tc),!SharedKey(pid,k),+         !Succ(tc,Stc),Fr(~npr),Fr(~nonce) ]+        //The old countervalue tc is removed+        --[ YubiPress(pid,tc), YubiOTP(pid,senc(<sid,tc,~npr>,k)),+            YubiSid(pid,sid,k) ]->+        [Y_counter(pid, Stc), //and substituted by its successor+         Out(<pid,~nonce,senc(<sid,tc,~npr>,k)>) +        //in addition, an encrypted otp is output along with a nonce and+        //the public id of the Yubikey used.+        ]++/* Upon receiving an encrypted OTP, the Server compares the (unencrypted)+ * public id to his data base to identify the key to decrypt the OTP. After+ * making sure that the secret id is correct, the Server verifies that the+ * received counter value is larger than the last one stored. If the Login+ * is successful, i.e., the previous conditions were fulfilled, the counter+ * value on the Server that is associated to the Yubikey is updated.+ */++rule Server_ReceiveOTP_NewSession:+        [Server(pid,sid,otc), In(<pid,nonce,senc(<sid,tc,~pr>,k)>),+        !SharedKey(pid,k), !Smaller(otc,tc) ]+        //if the Server receives an OTP encrypted with k that belongs to+        //the (unencrypted) public id, and the OTP has the right format,+        //contains the correct secret id as well as a counter tc that is+        //larger than the current counter otc, then...+         --[ Login(pid,sid,tc,senc(<sid,tc,~pr>,k)),+             LoginCounter(pid,otc,tc) //..the Login is accepted..+          ]->+        [Server(pid,sid,tc)] //..and the counter value updated.++/* The following three axioms are conditions on the traces that make sure+ * that : */++//a) the !Smaller relation is transitive+axiom transitivity: //axiomatic+        "All #t1 #t2 a b c. IsSmaller(a,b)@t1 & IsSmaller(b,c)@t2+        ==> Ex #t3 . IsSmaller(a,c)@t3 "++//b) !Smaller implies unequality+axiom smaller_implies_unequal: //axiomatic+        "not (Ex a #t . IsSmaller(a,a)@t)"++//c) The protocol runs only after the IsSmaller and IsSuccessor relation is+//   build up+axiom theory_before_protocol: +    "All #i #j. Theory() @ i & Protocol() @ j ==> i < j"++// For sanity: Ensure that a successful login is reachable.+lemma Login_reachable:+  exists-trace+  "Ex #i pid sid x otp1. Login(pid,sid,x,otp1)@i"++// Each succesful login with counter value x was preceeded by a PressButton+// event with the same counter value+lemma one_count_foreach_login[reuse,use_induction]:+        "All pid sid x otp  #t2 . Login(pid,sid,x,otp)@t2 ==>+         ( Ex #t1  . YubiPress(pid,x)@#t1 & #t1<#t2 )"++// If a succesful Login happens before a second sucesfull Login, the+// counter value of the first is smaller than the counter value of the+// second+lemma slightly_weaker_invariant[reuse, use_induction]:+        "(All pid otc1 tc1 otc2 tc2 #t1 #t2 .+             LoginCounter(pid,otc1,tc1)@#t1 & LoginCounter(pid,otc2,tc2)@#t2+        ==> ( #t1<#t2 & ( Ex #t3 . IsSmaller(tc1,tc2)@t3 ))+            | #t2<#t1 | #t1=#t2)+        "+induction+  case empty_trace+  by contradiction // from formulas+next+  case non_empty_trace+  simplify+  solve( (∀ pid otc1 tc1 otc2 tc2 #t1 #t2.+           (LoginCounter( pid, otc1, tc1 ) @ #t1) ∧+           (LoginCounter( pid, otc2, tc2 ) @ #t2)+          ⇒+           (last(#t2)) ∨+           (last(#t1)) ∨+           ((#t1 < #t2) ∧+            (∃ #t3. (IsSmaller( tc1, tc2 ) @ #t3) ∧ ¬(last(#t3)))) ∨+           (#t2 < #t1) ∨+           (#t1 = #t2))  ∥+         (∃ #t1 #t2 a b c.+           (IsSmaller( a, b ) @ #t1) ∧ (IsSmaller( b, c ) @ #t2)+          ∧+           (¬(last(#t2))) ∧+           (¬(last(#t1))) ∧+           (∀ #t3. (IsSmaller( a, c ) @ #t3) ⇒ last(#t3))) )+    case case_1+    solve( (last(#t2))  ∥ (last(#t1))  ∥+           ((#t1 < #t2) ∧+            (∃ #t3. (IsSmaller( tc1, tc2 ) @ #t3) ∧ ¬(last(#t3))))  ∥+           (#t2 < #t1)  ∥ (#t1 = #t2) )+      case case_1+	  solve( Server( pid, sid, otc1 ) ▶₀ #t1 )+		case BuyANewYubikey+		solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 )+		  by sorry+	  next+		case Server_ReceiveOTP_NewSession_case_1+		solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 )+		  by sorry+	  next+		case Server_ReceiveOTP_NewSession_case_2+		solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 )+		  by sorry+	  next+		case Server_ReceiveOTP_NewSession_case_3+		solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 )+		  by sorry+	  next+		case Server_ReceiveOTP_NewSession_case_4+		solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 )+		  by sorry+	  qed+    next+      case case_2+      by contradiction // cyclic+    next+      case case_3+      by contradiction // from formulas+    next+      case case_4+      by contradiction // from formulas+    next+      case case_5+      by contradiction // from formulas+    qed+  next+    case case_2+    by sorry+  qed+qed++// It is not possible to have to distinct logins with the same counter+// value+lemma no_replay:+        "not (Ex #i #j pid sid x otp1 otp2 .+         Login(pid,sid,x,otp1)@i &  Login(pid,sid,x,otp2)@j +         & not(#i=#j))"+end+
+ data/examples/related_work/YubiSecure_KS_STM12/Yubikey_and_YubiHSM.spthy view
@@ -0,0 +1,277 @@+theory YubikeyHSM+begin++section{* The Yubikey-Protocol with a YubiHSM *}++/*+ * Protocol:    Yubikey Protocol with a YubiHSM+ * Modeler:     Robert Kunnemann, Graham Steel+ * Date:    August 2012+ *+ * Status:  working+ */++builtins: symmetric-encryption++functions: S/1,zero/0++/* We to model the Yubikey protocol, described in+*  http://www.yubico.com/documentation+*  http://www.yubico.com/developers-intro+*  In this version, we assume the Authentication Server to be under the+*  control of the attacker. We investigate the secrecy of keys in case the+*  Authentication Server can protect the keys by encrypting them using a+*  Hardware Token called YubiHSM, see:+*  TODO URL will follow+*  This is simplified version, in particular:+*  - timestamps are not modelled+*  - we do not distinguish the session and token counter. We described them+*    as one single counter, that represents the pair (session counter, token+*    counter) with a lexicographical oder on the pair.+*  - we model encryption in more detail than the Theory Yubikey. However,+*    we use a very much simplified model of XOR+*  - we assume the YubiHSM to be in a configuration where only the flags+*    YSM_AEAD_RANDOM_GENERATE and+*    YSM_AEAD_YUBIKEY_OTP_DECODE+*    are activated.+*/++++/* keystream models the way the keystream used for encryption is computed.+ * Mac describes the MAC used inside the AEADs, which are computed using+ * CBC mode, described in RFC 3610.+ * keystream_kh and keyhandle_n model the adversaries capacity to extract the+ * used keyhandle and nonce that determined the keystream. (Similar for+ * demac.)+*/+functions: keystream/2,  keystream_kh/1, keystream_n/1,+            xorc/2, dexor1/2, dexor2/2,+            mac/2, demac/2+equations: keystream_kh(keystream(kh,n))=kh,+            keystream_n(keystream(n,n))=n,+/* an incomplete way of modelling the algebraic properties of the XOR+ * operator */+            dexor1(xorc(a,b),a)=b,+            dexor2(xorc(a,b),b)=a,+/* using mac, adv might find out *something* about the message, we+ * overapproximate */+            demac(mac(m,k),k)=m++/* The following rules model two binary relations between integers. !Succ+ * is functional. If !Succ(a,b), then the adversary was able to show that b+ * is the successor of b. Similarly, albeit !Smaller is not functional, if+ * !Smaller(a,b), then the adversary was able to show that a is smaller+ * than b.+ * The Theory() action is used to enforce that this relation (to the extend+ * it is needed in this trace) has to be build up before running the first+ * protocol actions.+*/+rule InitSucc:+    [In(zero),In(S(zero))]+	 --[Theory(), IsSucc(zero,S(zero)),IsZero(zero)]->+	[!Succ(zero,S(zero))]++rule StepSucc:+    [In(y),In(S(y)), !Succ(x,y)]+	--[Theory(), IsSucc(y,S(y)) ]->+	[!Succ(y,S(y))]++rule SimpleSmaller:+    [!Succ(x,y)]+	--[Theory(), IsSmaller(x,y)]->+	[!Smaller(x,y)]++rule ZExtendedSmaller:+    [!Smaller(x,y),!Succ(y,z)]+	--[Theory(), IsSmaller(x,z)]->+	[!Smaller(x,z)]++// Rules for intruder's control over Server++/* The attacker can send messages to the HSM, i.e., on behalf of the+ * authentication server. Likewise, he can receive messages.+ */++rule isendHSM:+   [ In( x ) ] --[ HSMWrite(x) ]-> [ InHSM( x ) ]+rule irecvHSM:+   [ OutHSM( x ) ] --[ HSMRead(x) ]-> [Out(x)]++/* The attacker can write and read the Authentication Server's database.+ * This database contains a list of public ideas and corresponding AEADs+ */+rule read_AEAD:+    [ !S_AEAD(pid,aead)  ] --[ AEADRead(aead),HSMRead(aead) ]-> [Out(aead)]+rule write_AEAD:+    [ In(aead), In(pid) ] --[ AEADWrite(aead),HSMWrite(aead) ]-> [!S_AEAD(pid,aead) ]+++/* Initialisation of HSM and Authentication Server. OneTime() Assures that+ * this can only happen a single time in a trace */+rule HSMInit:+    [Fr(~k), Fr(~kh)] --[Protocol(), GenerateRole1(~k),MasterKey(~k), OneTime()]->+    [ !HSM(~kh,~k), Out(~kh),+/* If the following line is uncommented, we are able to reproduce the+ * attack described in+ * http://static.yubico.com/var/uploads/pdfs/Security%20Advisory.pdf+ */+//!YSM_AEAD_GENERATE(~kh), //uncomment to produce attacks+!YSM_AEAD_YUBIKEY_OTP_DECODE(~kh)+]++//Some commands on the HSM:+rule YSM_AEAD_RANDOM_GENERATE:+    let ks=keystream(kh,N)+        aead=<xorc(senc(ks,k),~data),mac(~data,k)>+    in+    [Fr(~data), InHSM(<N,kh>),!HSM(kh,k),!YSM_AEAD_RANDOM_GENERATE(kh)]+    --[GenerateRandomAEAD(~data)]->+    [OutHSM( aead)+    ]++rule YSM_AEAD_GENERATE:+    let ks=keystream(kh,N)+        aead=<xorc(senc(ks,k),data),mac(data,k)>+    in+    [InHSM(<N,kh,data>),!HSM(kh,k),!YSM_AEAD_GENERATE(kh)]+    --[GenerateAEAD(data,aead )]->+    [OutHSM( aead) ]++rule YSM_AES_ESC_BLOCK_ENCRYPT:+    [InHSM(<kh,data>), !HSM(kh,k), !YSM_AES_ESC_BLOCK_ENCRYPT(kh)]+    --[]->+    [OutHSM(senc(data,k))]++rule YSM_AEAD_YUBIKEY_OTP_DECODE:+    let ks=keystream(kh,N)+        aead=<xorc(senc(ks,k),<k2,did>),mac(<k2,did>,k)>+        otp=senc(<did,sc,rand>,k2)+    in+    [InHSM(<did,kh,aead,otp>), !HSM(kh,k), !YSM_AEAD_YUBIKEY_OTP_DECODE(kh)+    ]+    --[+    OtpDecode(k2,k,<did,sc,rand>,sc,xorc(senc(ks,k),<k2,did>),mac(<k2,did>,k)),+    OtpDecodeMaster(k2,k)+    ]->+    [OutHSM(sc)]++//Yubikey operations+//(see Yubikey.spthy for more detailed comments)+rule BuyANewYubikey:+    let ks=keystream(kh,~pid)+        aead=<xorc(senc(ks,~k),<~k2,~sid>),mac(<~k2,~sid>,~k)>+    in+/* This rule implicitly uses YSM_AEAD_GENERATE to produce the AEAD that+ * stores the secret identity and shared key of a Yubikey. By disabling the+ * YSM_AEAD_GENERATE flag but nevertheless permitting this operation, we+ * model a scenario where YSM_AEAD_GENERATE can be safely used to guarantee+ * the operation, but not by the attacker. This corresponds to a scenario+ * where Yubikey set-up takes place on a different server, or where the+ * set-up takes place before the server is plugged into the network.+ * Uncomment the following line to require the HSM to have the+ * YSM_AEAD_GENERATE flag set.+ */+//!YSM_AEAD_GENERATE(kh),+    [ Fr(~k2),Fr(~pid),Fr(~sid),+    !HSM(kh,~k),+    !Succ(zero,one) ]+     --[Init(~pid,~k2)]->+    [Y_counter(~pid,one), !Y_Key(~pid,~k2), !Y_sid(~pid,~sid),+    S_Counter(~pid,zero), !S_AEAD(~pid,aead), !S_sid(~pid,~sid),+    Out(~pid) ]++//On plugin, the session counter is increased and the token counter reset+rule Yubikey_Plugin:+        [Y_counter(pid,sc),!Smaller(sc, Ssc) ]+        //The old counter value sc is removed+        --[ Yubi(pid,Ssc) ]->+        [Y_counter(pid, Ssc)]+        //and substituted by a new counter value, larger, Ssc++rule Yubikey_PressButton:+    [Y_counter(pid,tc),!Y_Key(pid,k2),!Y_sid(pid,sid),+     !Succ(tc,Stc),Fr(~pr),Fr(~nonce) ]+    --[ YubiPress(pid,tc),+        YubiPressOtp(pid,<sid,tc,~pr>,tc,k2) ]->+    [Y_counter(pid,Stc), Out(<pid,~nonce,senc(<sid,tc,~pr>,k2)>)]++rule Server_ReceiveOTP_NewSession:+    let ks=keystream(kh,pid)+        aead=<xorc(senc(ks,k),<k2,sid>),mac(<k2,sid>,k)>+    in+    [In(<pid,nonce,senc(<sid,tc,~pr>,k2)>) ,+        !HSM(kh,k), !S_AEAD(pid,aead), S_Counter(pid,otc),+        !S_sid(pid,sid), !Smaller(otc,tc) ]+     --[ Login(pid,sid,tc,senc(<sid,tc,~pr>,k2)) ]->+    [ S_Counter(pid,tc) ]++/* The following three axioms are conditions on the traces that make sure+ * that : */+//+//a) the !Smaller relation is transitive+axiom transitivity: //axiomatic+        "All #t1 #t2 a b c. IsSmaller(a,b)@t1 & IsSmaller(b,c)@t2+        ==> Ex #t3 . IsSmaller(a,c)@t3 "++//b) !Smaller implies unequality+axiom smaller_implies_unequal: //axiomatic+        "not (Ex a #t . IsSmaller(a,a)@t)"++/*c) The protocol runs only after the IsSmaller and IsSuccessor relation is+ *   build up+ */+axiom theory_before_protocol:+    "All #i #j. Theory() @ i & Protocol() @ j ==> i < j"++axiom onetime:+    "All #t3 #t4 . OneTime()@#t3 & OneTime()@t4 ==> #t3=#t4"++//LEMMAS:++// For sanity: Ensure that a successful login is reachable.+//TODO reactivate+//lemma Login_reachable:+//  exists-trace+//  "Ex #i pid sid x otp1. Login(pid,sid, x, otp1)@i"++/* Every counter produced by a Yubikey could be computed by the adversary+ * anyway. (This saves a lot of steps in the backwards induction of the+ * following lemmas).+*/+lemma adv_can_guess_counter[reuse,use_induction]:+    "All pid sc #t2 . YubiPress(pid,sc)@t2+    ==> (Ex #t1 . K(sc)@#t1 & #t1<#t2)"++/* Everything that can be learned by using OtpDecode is the counter of a+ * Yubikey, which can be computed according to the previous lemma.+*/+lemma otp_decode_does_not_help_adv_use_induction[reuse,use_induction]:+    "All #t3 k2 k m sc enc mac . OtpDecode(k2,k,m,sc,enc,mac)@t3+    ==> Ex #t1 pid . YubiPress(pid,sc)@#t1 & #t1<#t3"++/* All keys shared between the YubiHSM and the Authentication Server are+ * either not known to the adversary, or the adversary learned the key used+ * to encrypt said keys in form of AEADs.+ */+lemma k2_is_secret_use_induction[use_induction,reuse]:+    "All #t1 #t2 pid k2 . Init(pid,k2)@t1 & K(k2)@t2+    ==>+     (Ex #t3 #t4 k . K(k)@t3 & MasterKey(k)@t4 & #t3<#t2)"++/* Neither of those kinds of keys are ever learned by the adversary */+lemma neither_k_nor_k2_are_ever_leaked_inv[use_induction,reuse]:+    "+not( Ex #t1 #t2 k . MasterKey(k)@t1 & K(k)@t2 )+& not (Ex  #t5 #t6 k6 pid . Init(pid,k6)@t5 & K(k6)@t6 )+    "++// Each succesful login with counter value x was preceeded by a PressButton+// event with the same counter value+// This lemma cannot be proven at the moment, but it would be a first step+// to reach the no_replay result present in Yubikey.spthy+//lemma one_count_foreach_login[reuse,use_induction]:+//        "All pid sid x otp  #t2 . Login(pid,sid,x,otp)@t2 ==>+//         ( Ex #t1  . YubiPress(pid,x)@#t1 & #t1<#t2 )"++end
interactive-only-src/Paths_tamarin_prover.hs view
@@ -12,7 +12,7 @@   version :: Version-version = Version {versionBranch = [0,8,1,0], versionTags = []}+version = Version {versionBranch = [0,8,2,0], versionTags = []} bindir, libdir, datadir, libexecdir :: FilePath  bindir     = "./"
src/Main/Mode/Intruder.hs view
@@ -18,11 +18,11 @@ import           System.FilePath  import           Theory-import           Theory.Text.Parser              (intruderVariantsFile) import           Theory.Tools.IntruderRules  import           Main.Console import           Main.Environment+import           Main.TheoryLoader               (intruderVariantsFile) import           Main.Utils
src/Main/Mode/Test.hs view
@@ -23,7 +23,7 @@  import qualified Term.UnitTests                  as Term (tests) import           Theory-import qualified Theory.Text.Parser.UnitTests    as Parser+import qualified Test.ParserTests                as Parser   -- | Self-test mode.
src/Main/TheoryLoader.hs view
@@ -24,27 +24,37 @@    , closeThy +  -- ** Message deduction variants+  , intruderVariantsFile+  , addMessageDeductionRuleVariants+   ) where  import           Prelude                             hiding (id, (.))  import           Data.Char                           (toLower)+import           Data.Label+import           Data.List                           (isPrefixOf) import           Data.Monoid  import           Control.Basics import           Control.Category-import           Control.DeepSeq (rnf)+import           Control.DeepSeq                     (rnf)+import           Extension.Prelude                   (ifM)  import           System.Console.CmdArgs.Explicit+import           System.Directory                    (doesFileExist)  import           Theory import           Theory.Text.Parser import           Theory.Text.Pretty import           Theory.Tools.AbstractInterpretation (EvaluationStyle(..))+import           Theory.Tools.IntruderRules          (specialIntruderRules, subtermIntruderRules) import           Theory.Tools.Wellformedness  import           Main.Console import           Main.Environment+import           Paths_tamarin_prover                (getDataFileName)   ------------------------------------------------------------------------------@@ -55,8 +65,8 @@ -- | Flags for loading a theory. theoryLoadFlags :: [Flag Arguments] theoryLoadFlags =-  [ flagNone ["prove"] (addEmptyArg "addProofs")-      "Attempt to prove all security properties"+  [ flagOpt "" ["prove"] (updateArg "prove") "LEMMAPREFIX"+      "Attempt to prove a lemma "    , flagOpt "dfs" ["stop-on-trace"] (updateArg "stopOnTrace") "DFS|BFS|NONE"       "How to search for traces (default DFS)"@@ -142,7 +152,7 @@ -- | Close a theory according to arguments. closeThy :: Arguments -> OpenTheory -> IO ClosedTheory closeThy as =-      fmap (proveTheory prover . partialEvaluation)+      fmap (proveTheory lemmaSelector prover . partialEvaluation)     . closeTheory (maudePath as)     -- FIXME: wf-check is at the wrong position here. Needs to be more     -- fine-grained.@@ -163,11 +173,17 @@       noteWellformedness         (checkWellformedness thy) thy +    lemmaSelector :: Lemma p -> Bool+    lemmaSelector lem =+        any (`isPrefixOf` get lName lem) lemmaNames+      where+        lemmaNames = findArg "prove" as+     -- replace all annotated sorrys with the configured autoprover.     prover :: Prover-    prover | argExists "addProofs" as =+    prover | argExists "prove" as =                  replaceSorryProver $ runAutoProver $ constructAutoProver as-           | otherwise                = mempty+           | otherwise            = mempty  -- | Construct an 'AutoProver' from the given arguments (--bound, -- --stop-on-trace).@@ -203,3 +219,31 @@       Just "none" -> CutNothing       Just "bfs"  -> CutBFS       Just other  -> error $ "unknown stop-on-trace method: " ++ other+++------------------------------------------------------------------------------+-- Message deduction variants cached in files+------------------------------------------------------------------------------++-- | The name of the intruder variants file.+intruderVariantsFile :: FilePath+intruderVariantsFile = "intruder_variants_dh.spthy"++-- | Add the variants of the message deduction rule. Uses the cached version+-- of the @"intruder_variants_dh.spthy"@ file for the variants of the message+-- deduction rules for Diffie-Hellman exponentiation.+addMessageDeductionRuleVariants :: OpenTheory -> IO OpenTheory+addMessageDeductionRuleVariants thy0+  | enableDH msig = do+      variantsFile <- getDataFileName intruderVariantsFile+      ifM (doesFileExist variantsFile)+          (do dhVariants <- parseIntruderRulesDH variantsFile+              return $ addIntrRuleACs dhVariants thy+          )+          (error $ "could not find intruder message deduction theory '"+                     ++ variantsFile ++ "'")+  | otherwise = return thy+  where+    msig         = get (sigpMaudeSig . thySignature) thy0+    rules        = subtermIntruderRules msig ++ specialIntruderRules+    thy          = addIntrRuleACs rules thy0
+ src/Test/ParserTests.hs view
@@ -0,0 +1,92 @@+-- |+-- Copyright   : (c) 2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+--+-- Unit tests for checking that all examples parse properly.+module Test.ParserTests (++   testParseFile+ , testParseDirectory+ ) where++import           Test.HUnit++import           Control.Basics++import           System.Directory+import           System.FilePath++import           Theory+import           Theory.Text.Parser+import           Theory.Text.Pretty (render)+import           Main.TheoryLoader (addMessageDeductionRuleVariants)++-- | Test wether a given file exists, can be parsed, and can still be parsed+-- after being pretty printed.+testParseFile :: Maybe (FilePath, Prover)+              -- ^ Path to maude and prover for testing whether proof parsing+              -- works properly.+              -> FilePath+              -- ^ File on which to test parsing (and proving)+              -> Test+testParseFile optionalProver inpFile = TestLabel inpFile $ TestCase $ do+    thyString <- readFile inpFile+    thy0      <- parse "original file:" thyString+    -- add proofs and pretty print closed theory, if desired+    (thy, thyPretty) <- case optionalProver of+        Nothing                  ->+            return  (thy0, prettyOpenTheory thy0)+        Just (maudePath, prover) -> do+            closedThy <- proveTheory (const True) prover <$> closeTheory maudePath thy0+            return $ ( normalizeTheory $ openTheory closedThy+                     , prettyClosedTheory closedThy)+    thy' <- parse "pretty printed theory:" (render thyPretty)+    unless (thy == thy') $ do+        let (diff1, diff2) =+                unzip $ dropWhile (uncurry (==)) $ zip (show thy) (show thy')+        assertFailure $ unlines+          [ "Original theory",            "",  render (prettyOpenTheory thy), ""+          , "Pretty printed and parsed" , "", render (prettyOpenTheory thy'), ""+          , "Original theory (diff)",            "", indent diff1, ""+          , "Pretty printed and parsed (diff)" , "", indent diff2, "", "DIFFER"+          ]+    return ()+  where+    indent = unlines . map (' ' :) . lines++    parse msg str = case parseOpenTheoryString [] str  of+        Left err  -> do assertFailure $ withLineNumbers $ indent $ show err+                        return (error "testParseFile: dead code")+        Right thy -> normalizeTheory <$> addMessageDeductionRuleVariants thy+      where+        withLineNumbers err =+            unlines $ zipWith (\i l -> nr (show i) ++ l) [(1::Int)..] ls+                      ++ ["", "Parse error when parsing the " ++ msg, err]+          where+            ls   = lines str+            n    = length (show (length ls))+            nr i = replicate (1 + max 0 (n - length i)) ' ' ++ i ++ ": "++-- | Create the test whether 'testParseFile' succeeds on all @*.spthy@ files+-- in a given directory and all its subdirectories of depth n.+testParseDirectory :: (FilePath -> Test)  -- ^ Test creation function.+                   -> Int                 -- ^ Maximal depth of traversal.+                   -> FilePath            -- ^ Starting directory.+                   -> IO [Test]+testParseDirectory mkTest n dir+  | n < 0     = return []+  | otherwise = do+      rawContents <- getDirectoryContents dir+      let contents = [ dir </> content+                     | content <- rawContents+                     , content /= ".", content /= ".." ]+      subDirs     <- filterM doesDirectoryExist contents+      innerTests  <- mapM (testParseDirectory mkTest (n - 1)) subDirs+      let tests = [ file+                  | file <- contents, takeExtension file == ".spthy" ]+      mapM_ (putStrLn . (" peparing: " ++)) tests+      return $ map mkTest tests ++ map TestList innerTests++
− src/Theory.hs 
@@ -1,942 +0,0 @@-{-# LANGUAGE DeriveFunctor        #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeSynonymInstances #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Theory datatype and transformations on it.-module Theory (-  -- * Axioms-    Axiom(..)-  , axName-  , axFormula--  -- * Lemmas-  , LemmaAttribute(..)-  , TraceQuantifier(..)-  , Lemma-  , lName-  , lTraceQuantifier-  , lFormula-  , lAttributes-  , lProof-  , unprovenLemma-  , skeletonLemma--  -- * Theories-  , Theory(..)-  , TheoryItem(..)-  , thyName-  , thySignature-  , thyCache-  , thyItems-  , theoryRules-  , theoryLemmas-  , theoryAxioms-  , addAxiom-  , addLemma-  , removeLemma-  , lookupLemma-  , addComment-  , addStringComment-  , addFormalComment-  , cprRuleE--  -- ** Open theories-  , OpenTheory-  , defaultOpenTheory-  , addProtoRule-  , applyPartialEvaluation-  , addIntrRuleACs-  , normalizeTheory--  -- ** Closed theories-  , ClosedTheory-  , ClosedRuleCache(..) -- FIXME: this is only exported for the Binary instances-  , closeTheory-  , openTheory--  , ClosedProtoRule(..)--  , getLemmas-  , getIntrVariants-  , getProtoRuleEs-  , getProofContext-  , getClassifiedRules-  , getInjectiveFactInsts--  , getCaseDistinction--  -- ** Proving-  , ProofSkeleton-  , proveTheory--  -- ** Lemma references-  , lookupLemmaProof-  , modifyLemmaProof--  -- * Pretty printing-  , prettyFormalComment-  , prettyLemmaName-  , prettyAxiom-  , prettyLemma-  , prettyClosedTheory-  , prettyOpenTheory--  , prettyClosedSummary--  , prettyIntruderVariants-  , prettyTraceQuantifier--  -- * Convenience exports-  , module Theory.Model-  , module Theory.Proof--  ) where--import           Prelude                             hiding (id, (.))--import           Data.Binary-import           Data.DeriveTH-import           Data.Foldable                       (Foldable, foldMap)-import           Data.List-import           Data.Maybe-import           Data.Monoid                         (Sum(..))-import qualified Data.Set                            as S-import           Data.Traversable                    (Traversable, traverse)--import           Control.Basics-import           Control.Category-import           Control.DeepSeq-import           Control.Monad.Reader-import qualified Control.Monad.State                 as MS-import           Control.Parallel.Strategies--import           Extension.Data.Label                hiding (get)-import qualified Extension.Data.Label                as L--import           Theory.Model-import           Theory.Proof-import           Theory.Text.Pretty-import           Theory.Tools.AbstractInterpretation-import           Theory.Tools.InjectiveFactInstances-import           Theory.Tools.LoopBreakers-import           Theory.Tools.RuleVariants----------------------------------------------------------------------------------- Specific proof types----------------------------------------------------------------------------------- | Proof skeletons are used to represent proofs in open theories.-type ProofSkeleton    = Proof ()---- | Convert a proof skeleton to an incremental proof without any sequent--- annotations.-skeletonToIncrementalProof :: ProofSkeleton -> IncrementalProof-skeletonToIncrementalProof = fmap (fmap (const Nothing))---- | Convert an incremental proof to a proof skeleton by dropping all--- annotations.-incrementalToSkeletonProof :: IncrementalProof -> ProofSkeleton-incrementalToSkeletonProof = fmap (fmap (const ()))------------------------------------------------------------------------------------ Commented sets of rewriting rules----------------------------------------------------------------------------------- | A protocol rewriting rule modulo E together with its possible assertion--- soundness proof.-type OpenProtoRule = ProtoRuleE---- | A closed proto rule lists its original rule modulo E, the corresponding--- variant modulo AC, and if required the assertion soundness proof.-data ClosedProtoRule = ClosedProtoRule-       { _cprRuleE  :: ProtoRuleE             -- original rule modulo E-       , _cprRuleAC :: ProtoRuleAC            -- variant modulo AC-       }-       deriving( Eq, Ord, Show )--type OpenRuleCache = [IntrRuleAC]--data ClosedRuleCache = ClosedRuleCache-       { _crcRules            :: ClassifiedRules-       , _crcUntypedCaseDists :: [CaseDistinction]-       , _crcTypedCaseDists   :: [CaseDistinction]-       , _crcInjectiveFactInsts  :: S.Set FactTag-       }-       deriving( Eq, Ord, Show )---$(mkLabels [''ClosedProtoRule, ''ClosedRuleCache])--instance HasRuleName ClosedProtoRule where-    ruleName = ruleName . L.get cprRuleE----- Relation between open and closed rule sets-------------------------------------------------- | All intruder rules of a set of classified rules.-intruderRules :: ClassifiedRules -> [IntrRuleAC]-intruderRules rules = do-    Rule (IntrInfo i) ps cs as <- joinAllRules rules-    return $ Rule i ps cs as---- | Open a rule cache. Variants and precomputed case distinctions are dropped.-openRuleCache :: ClosedRuleCache -> OpenRuleCache-openRuleCache = intruderRules . L.get crcRules---- | Open a protocol rule; i.e., drop variants and proof annotations.-openProtoRule :: ClosedProtoRule -> OpenProtoRule-openProtoRule = L.get cprRuleE---- | Close a protocol rule; i.e., compute AC variant and typing assertion--- soundness sequent, if required.-closeProtoRule :: MaudeHandle -> OpenProtoRule -> ClosedProtoRule-closeProtoRule hnd ruE = ClosedProtoRule ruE (variantsProtoRule hnd ruE)--- | Close a rule cache. Hower, note that the--- requires case distinctions are not computed here.-closeRuleCache :: [LNGuarded]        -- ^ Axioms to use.-               -> [LNGuarded]        -- ^ Typing lemmas to use.-               -> SignatureWithMaude -- ^ Signature of theory.-               -> [ClosedProtoRule]  -- ^ Protocol rules with variants.-               -> OpenRuleCache      -- ^ Intruder rules modulo AC.-               -> ClosedRuleCache    -- ^ Cached rules and case distinctions.-closeRuleCache axioms typAsms sig protoRules intrRulesAC =-    ClosedRuleCache-        classifiedRules untypedCaseDists typedCaseDists injFactInstances-  where-    ctxt0 = ProofContext-        sig classifiedRules injFactInstances UntypedCaseDist [] AvoidInduction-        (error "closeRuleCache: trace quantifier should not matter here")--    -- inj fact instances-    injFactInstances =-        simpleInjectiveFactInstances $ L.get cprRuleE <$> protoRules--    -- precomputing the case distinctions: we make sure to only add safety-    -- axioms. Otherwise, it wouldn't be sound to use the precomputed case-    -- distinctions for properties proven using induction.-    safetyAxioms     = filter isSafetyFormula axioms-    untypedCaseDists = precomputeCaseDistinctions ctxt0 safetyAxioms-    typedCaseDists   = refineWithTypingAsms typAsms ctxt0 untypedCaseDists--    -- classifying the rules-    rulesAC = (fmap IntrInfo                      <$> intrRulesAC) <|>-              ((fmap ProtoInfo . L.get cprRuleAC) <$> protoRules)--    anyOf ps = partition (\x -> any ($ x) ps)--    (nonProto, proto) = anyOf [isDestrRule, isConstrRule] rulesAC-    (constr, destr)   = anyOf [isConstrRule] nonProto--    -- and sort them into ClassifiedRules datastructure for later use in proofs-    classifiedRules = ClassifiedRules-      { _crConstruct  = constr-      , _crDestruct   = destr-      , _crProtocol   = proto-      }------------------------------------------------------------------------------------ Axioms (Trace filters)----------------------------------------------------------------------------------- | An axiom describes a property that must hold for all traces. Axioms are--- always used as lemmas in proofs.-data Axiom = Axiom-       { _axName    :: String-       , _axFormula :: LNFormula-       }-       deriving( Eq, Ord, Show )--$(mkLabels [''Axiom])------------------------------------------------------------------------------------ Lemmas----------------------------------------------------------------------------------- | An attribute for a 'Lemma'.-data LemmaAttribute =-         TypingLemma-       | ReuseLemma-       | InvariantLemma-       deriving( Eq, Ord, Show )---- | A 'TraceQuantifier' stating whether we check satisfiability of validity.-data TraceQuantifier = ExistsTrace | AllTraces-       deriving( Eq, Ord, Show )---- | A lemma describes a property that holds in the context of a theory--- together with a proof of its correctness.-data Lemma p = Lemma-       { _lName            :: String-       , _lTraceQuantifier :: TraceQuantifier-       , _lFormula         :: LNFormula-       , _lAttributes      :: [LemmaAttribute]-       , _lProof           :: p-       }-       deriving( Eq, Ord, Show )--$(mkLabels [''Lemma])----- Instances---------------instance Functor Lemma where-    fmap f (Lemma n qua fm atts prf) = Lemma n qua fm atts (f prf)--instance Foldable Lemma where-    foldMap f = f . L.get lProof--instance Traversable Lemma where-    traverse f (Lemma n qua fm atts prf) = Lemma n qua fm atts <$> f prf----- Lemma queries--------------------------------------- | Convert a trace quantifier to a sequent trace quantifier.-toSystemTraceQuantifier :: TraceQuantifier -> SystemTraceQuantifier-toSystemTraceQuantifier AllTraces   = ExistsNoTrace-toSystemTraceQuantifier ExistsTrace = ExistsSomeTrace---- | True iff the lemma can be used as a typing lemma.-isTypingLemma :: Lemma p -> Bool-isTypingLemma lem =-     (AllTraces == L.get lTraceQuantifier lem)-  && (TypingLemma `elem` L.get lAttributes lem)----- Lemma construction/modification--------------------------------------- | Create a new unproven lemma from a formula modulo E.-unprovenLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> LNFormula-              -> Lemma ProofSkeleton-unprovenLemma name atts qua fm = Lemma name qua fm atts (unproven ())--skeletonLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> LNFormula-              -> ProofSkeleton -> Lemma ProofSkeleton-skeletonLemma name atts qua fm = Lemma name qua fm atts---- | The case-distinction kind allowed for a lemma-lemmaCaseDistKind :: Lemma p -> CaseDistKind-lemmaCaseDistKind lem-  | TypingLemma `elem` L.get lAttributes lem = UntypedCaseDist-  | otherwise                                = TypedCaseDist------------------------------------------------------------------------------------ Theories----------------------------------------------------------------------------------- | A formal comment is a header together with the body of the comment.-type FormalComment = (String, String)---- | A theory item built over the given rule type.-data TheoryItem r p =-       RuleItem r-     | LemmaItem (Lemma p)-     | AxiomItem Axiom-     | TextItem FormalComment-     deriving( Show, Eq, Ord, Functor )----- | A theory contains a single set of rewriting rules modeling a protocol--- and the lemmas that-data Theory sig c r p = Theory {-         _thyName      :: String-       , _thySignature :: sig-       , _thyCache     :: c-       , _thyItems     :: [TheoryItem r p]-       }-       deriving( Eq, Ord, Show )--$(mkLabels [''Theory])---- | Open theories can be extended. Invariants:---   1. Lemma names are unique.-type OpenTheory =-    Theory SignaturePure [IntrRuleAC] OpenProtoRule ProofSkeleton----- | Closed theories can be proven. Invariants:---     1. Lemma names are unique---     2. All proof steps with annotated sequents are sound with respect to the---        closed rule set of the theory.---     3. Maude is running under the given handle.-type ClosedTheory =-    Theory SignatureWithMaude ClosedRuleCache ClosedProtoRule IncrementalProof------ Shared theory modification functions-------------------------------------------- | Fold a theory item.-foldTheoryItem-    :: (r -> a) -> (Axiom -> a) -> (Lemma p -> a) -> (FormalComment -> a)-    -> TheoryItem r p -> a-foldTheoryItem fRule fAxiom fLemma fText i = case i of-    RuleItem ru   -> fRule ru-    LemmaItem lem -> fLemma lem-    TextItem txt  -> fText txt-    AxiomItem ax  -> fAxiom ax---- | Map a theory item.-mapTheoryItem :: (r -> r') -> (p -> p') -> TheoryItem r p -> TheoryItem r' p'-mapTheoryItem f g =-    foldTheoryItem (RuleItem . f) AxiomItem (LemmaItem . fmap g) TextItem---- | All rules of a theory.-theoryRules :: Theory sig c r p -> [r]-theoryRules =-    foldTheoryItem return (const []) (const []) (const []) <=< L.get thyItems---- | All axioms of a theory.-theoryAxioms :: Theory sig c r p -> [Axiom]-theoryAxioms =-    foldTheoryItem (const []) return (const []) (const []) <=< L.get thyItems---- | All lemmas of a theory.-theoryLemmas :: Theory sig c r p -> [Lemma p]-theoryLemmas =-    foldTheoryItem (const []) (const []) return (const []) <=< L.get thyItems---- | Add a new axiom. Fails, if axiom with the same name exists.-addAxiom :: Axiom -> Theory sig c r p -> Maybe (Theory sig c r p)-addAxiom l thy = do-    guard (isNothing $ lookupAxiom (L.get axName l) thy)-    return $ modify thyItems (++ [AxiomItem l]) thy---- | Add a new lemma. Fails, if a lemma with the same name exists.-addLemma :: Lemma p -> Theory sig c r p -> Maybe (Theory sig c r p)-addLemma l thy = do-    guard (isNothing $ lookupLemma (L.get lName l) thy)-    return $ modify thyItems (++ [LemmaItem l]) thy---- | Remove a lemma by name. Fails, if the lemma does not exist.-removeLemma :: String -> Theory sig c r p -> Maybe (Theory sig c r p)-removeLemma lemmaName thy = do-    _ <- lookupLemma lemmaName thy-    return $ modify thyItems (concatMap fItem) thy-  where-    fItem   = foldTheoryItem (return . RuleItem)-                             (return . AxiomItem)-                             check-                             (return . TextItem)-    check l = do guard (L.get lName l /= lemmaName); return (LemmaItem l)---- | Find the axiom with the given name.-lookupAxiom :: String -> Theory sig c r p -> Maybe Axiom-lookupAxiom name = find ((name ==) . L.get axName) . theoryAxioms---- | Find the lemma with the given name.-lookupLemma :: String -> Theory sig c r p -> Maybe (Lemma p)-lookupLemma name = find ((name ==) . L.get lName) . theoryLemmas---- | Add a comment to the theory.-addComment :: Doc -> Theory sig c r p -> Theory sig c r p-addComment c = modify thyItems (++ [TextItem ("", render c)])---- | Add a comment represented as a string to the theory.-addStringComment :: String -> Theory sig c r p -> Theory sig c r p-addStringComment = addComment . vcat . map text . lines--addFormalComment :: FormalComment -> Theory sig c r p -> Theory sig c r p-addFormalComment c = modify thyItems (++ [TextItem c])------------------------------------------------------------------------------------ Open theory construction / modification----------------------------------------------------------------------------------- | Default theory-defaultOpenTheory :: OpenTheory-defaultOpenTheory = Theory "default" emptySignaturePure [] []---- | Open a theory by dropping the closed world assumption and values whose--- soundness dependens on it.-openTheory :: ClosedTheory -> OpenTheory-openTheory  (Theory n sig c items) =-    Theory n (toSignaturePure sig) (openRuleCache c)-      (map (mapTheoryItem openProtoRule incrementalToSkeletonProof) items)---- | Find the open protocol rule with the given name.-lookupOpenProtoRule :: ProtoRuleName -> OpenTheory -> Maybe OpenProtoRule-lookupOpenProtoRule name =-    find ((name ==) . L.get rInfo) . theoryRules---- | Add a new protocol rules. Fails, if a protocol rule with the same name--- exists.-addProtoRule :: ProtoRuleE -> OpenTheory -> Maybe OpenTheory-addProtoRule ruE thy = do-    guard (maybe True ((ruE ==)) $-        lookupOpenProtoRule (L.get rInfo ruE) thy)-    return $ modify thyItems (++ [RuleItem 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 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 :: Prover -> ClosedTheory -> ClosedTheory-proveTheory 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 =-        modify lProof add lem-      where-        ctxt    = getProofContext lem thy-        sys     = mkSystem ctxt (theoryAxioms thy) preItems $ L.get lFormula lem-        add prf = fromMaybe prf $ runProver prover ctxt 0 sys prf---- | Construct a constraint system for verifying the given formula.-mkSystem :: ProofContext -> [Axiom] -> [TheoryItem r p]-         -> LNFormula -> System-mkSystem ctxt axioms previousItems =-    -- Note that it is OK to add reusable lemmas directly to the system, as-    -- they do not change the considered set of traces. This is the key-    -- difference between lemmas and axioms.-    addLemmas-  . formulaToSystem (map (formulaToGuarded_ . L.get axFormula) axioms)-                    (L.get pcCaseDistKind ctxt)-                    (L.get pcTraceQuantifier ctxt)-  where-    addLemmas sys =-        insertLemmas (gatherReusableLemmas $ L.get sCaseDistKind sys) sys--    gatherReusableLemmas kind = do-        LemmaItem lem <- previousItems-        guard $    lemmaCaseDistKind lem <= kind-                && ReuseLemma `elem` L.get lAttributes lem-                && AllTraces == L.get lTraceQuantifier lem-        return $ formulaToGuarded_ $ L.get lFormula lem------------------------------------------------------------------------------------ References to lemmas----------------------------------------------------------------------------------- | Lemmas are referenced by their name.-type LemmaRef = String---- | Resolve a path in a theory.-lookupLemmaProof :: LemmaRef -> ClosedTheory -> Maybe IncrementalProof-lookupLemmaProof name thy = L.get lProof <$> lookupLemma name thy---- | Modify the proof at the given lemma ref, if there is one. Fails if the--- path is not present or if the prover fails.-modifyLemmaProof :: Prover -> LemmaRef -> ClosedTheory -> Maybe ClosedTheory-modifyLemmaProof prover name thy =-    modA thyItems changeItems thy-  where-    findLemma (LemmaItem lem) = name == L.get lName lem-    findLemma _               = False--    change preItems (LemmaItem lem) = do-         let ctxt = getProofContext lem thy-             sys  = mkSystem ctxt (theoryAxioms thy) preItems $ L.get lFormula lem-         lem' <- modA lProof (runProver prover ctxt 0 sys) lem-         return $ LemmaItem lem'-    change _ _ = error "LemmaProof: change: impossible"--    changeItems items = case break findLemma items of-        (pre, i:post) -> do-             i' <- change pre i-             return $ pre ++ i':post-        (_, []) -> Nothing------------------------------------------------------------------------------------ Pretty printing----------------------------------------------------------------------------------- | Pretty print a formal comment-prettyFormalComment :: HighlightDocument d => String -> String -> d-prettyFormalComment "" body = multiComment_ [body]-prettyFormalComment header body = text $ header ++ "{*" ++ body ++ "*}"---- | Pretty print a theory.-prettyTheory :: HighlightDocument d-             => (sig -> d) -> (c -> d) -> (r -> d) -> (p -> d)-             -> Theory sig c r p -> d-prettyTheory ppSig ppCache ppRule ppPrf thy = vsep $-    [ kwTheoryHeader $ text $ L.get thyName thy-    , lineComment_ "Function signature and definition of the equational theory E"-    , ppSig $ L.get thySignature thy-    , ppCache $ L.get thyCache thy-    ] ++-    parMap rdeepseq ppItem (L.get thyItems thy) ++-    [ kwEnd ]-  where-    ppItem = foldTheoryItem-        ppRule prettyAxiom (prettyLemma ppPrf) (uncurry prettyFormalComment)---- | Pretty print the lemma name together with its attributes.-prettyLemmaName :: HighlightDocument d => Lemma p -> d-prettyLemmaName l = case L.get lAttributes l of-      [] -> text (L.get lName l)-      as -> text (L.get lName l) <->-            (brackets $ fsep $ punctuate comma $ map prettyLemmaAttribute as)-  where-    prettyLemmaAttribute TypingLemma    = text "typing"-    prettyLemmaAttribute ReuseLemma     = text "reuse"-    prettyLemmaAttribute InvariantLemma = text "use_induction"---- | Pretty print an axiom.-prettyAxiom :: HighlightDocument d => Axiom -> d-prettyAxiom ax =-    kwAxiom <-> text (L.get axName ax) <> colon $-$-    (nest 2 $ doubleQuotes $ prettyLNFormula $ L.get axFormula ax) $-$-    (nest 2 $ if safety then lineComment_ "safety formula" else emptyDoc)-  where-    safety = isSafetyFormula $ formulaToGuarded_ $ L.get axFormula ax---- | Pretty print a lemma.-prettyLemma :: HighlightDocument d => (p -> d) -> Lemma p -> d-prettyLemma ppPrf lem =-    kwLemma <-> prettyLemmaName lem <> colon $-$-    (nest 2 $-      sep [ prettyTraceQuantifier $ L.get lTraceQuantifier lem-          , doubleQuotes $ prettyLNFormula $ L.get lFormula lem-          ]-    )-    $-$-    ppLNFormulaGuarded (L.get lFormula lem)-    $-$-    ppPrf (L.get lProof lem)-  where-    ppLNFormulaGuarded fm = case formulaToGuarded fm of-        Left err -> multiComment $-            text "conversion to guarded formula failed:" $$-            nest 2 err-        Right gf -> case toSystemTraceQuantifier $ L.get lTraceQuantifier lem of-          ExistsNoTrace -> multiComment-            ( text "guarded formula characterizing all counter-examples:" $-$-              doubleQuotes (prettyGuarded (gnot gf)) )-          ExistsSomeTrace -> multiComment-            ( text "guarded formula characterizing all satisfying traces:" $-$-              doubleQuotes (prettyGuarded gf) )----- | Pretty-print a non-empty bunch of intruder rules.-prettyIntruderVariants :: HighlightDocument d => [IntrRuleAC] -> d-prettyIntruderVariants vs = vcat . intersperse (text "") $ map prettyIntrRuleAC vs--{---- | Pretty-print the intruder variants section.-prettyIntrVariantsSection :: HighlightDocument d => [IntrRuleAC] -> d-prettyIntrVariantsSection rules =-    prettyFormalComment "section" " Finite Variants of the Intruder Rules " $--$-    nest 1 (prettyIntruderVariants rules)--}---- | Pretty print an open rule together with its assertion soundness proof.-prettyOpenProtoRule :: HighlightDocument d => OpenProtoRule -> d-prettyOpenProtoRule = prettyProtoRuleE--prettyIncrementalProof :: HighlightDocument d => IncrementalProof -> d-prettyIncrementalProof = prettyProofWith ppStep (const id)-  where-    ppStep step = sep-      [ prettyProofMethod (psMethod step)-      , if isNothing (psInfo step) then multiComment_ ["unannotated"]-                                   else emptyDoc-      ]---- | Pretty print an closed rule.-prettyClosedProtoRule :: HighlightDocument d => ClosedProtoRule -> d-prettyClosedProtoRule cru =-    (prettyProtoRuleE ruE) $--$-    (nest 2 $ prettyLoopBreakers (L.get rInfo ruAC) $-$ ppRuleAC)-  where-    ruAC = L.get cprRuleAC cru-    ruE  = L.get cprRuleE cru-    ppRuleAC-      | isTrivialProtoVariantAC ruAC ruE = multiComment_ ["has exactly the trivial AC variant"]-      | otherwise                        = multiComment $ prettyProtoRuleAC ruAC---- | Pretty print an open theory.-prettyOpenTheory :: HighlightDocument d => OpenTheory -> d-prettyOpenTheory =-    prettyTheory prettySignaturePure-                 (const emptyDoc) prettyOpenProtoRule prettyProof-                 -- prettyIntrVariantsSection prettyOpenProtoRule prettyProof---- | Pretty print a closed theory.-prettyClosedTheory :: HighlightDocument d => ClosedTheory -> d-prettyClosedTheory thy =-    prettyTheory prettySignatureWithMaude-                 ppInjectiveFactInsts-                 -- (prettyIntrVariantsSection . intruderRules . L.get crcRules)-                 prettyClosedProtoRule-                 prettyIncrementalProof-                 thy-  where-    ppInjectiveFactInsts crc =-        case S.toList $ L.get crcInjectiveFactInsts crc of-            []   -> emptyDoc-            tags -> lineComment $ sep-                      [ text "looping facts with injective instances:"-                      , nest 2 $ fsepList (text . showFactTagArity) tags ]--prettyClosedSummary :: Document d => ClosedTheory -> d-prettyClosedSummary thy =-    vcat lemmaSummaries-  where-    lemmaSummaries = do-        LemmaItem lem  <- L.get thyItems thy-        -- Note that here we are relying on the invariant that all proof steps-        -- with a 'Just' annotation follow from the application of-        -- 'execProofMethod' to their parent and are valid in the sense that-        -- the application of 'execProofMethod' to their method and constraint-        -- system is guaranteed to succeed.-        ---        -- This is guaranteed initially by 'closeTheory' and is (must be)-        -- maintained by the provers being applied to the theory using-        -- 'modifyLemmaProof' or 'proveTheory'. Note that we could check the-        -- proof right before computing its status. This is however quite-        -- expensive, as it requires recomputing all intermediate constraint-        -- systems.-        ---        -- TODO: The whole consruction seems a bit hacky. Think of a more-        -- principled constrution with better correctness guarantees.-        let (status, Sum siz) = foldProof proofStepSummary $ L.get lProof lem-            quantifier = (toSystemTraceQuantifier $ L.get lTraceQuantifier lem)-            analysisType = parens $ prettyTraceQuantifier $ L.get lTraceQuantifier lem-        return $ text (L.get lName lem) <-> analysisType <> colon <->-                 text (showProofStatus quantifier status) <->-                 parens (integer siz <-> text "steps")--    proofStepSummary = proofStepStatus &&& const (Sum (1::Integer))----- | Pretty print a 'TraceQuantifier'.-prettyTraceQuantifier :: Document d => TraceQuantifier -> d-prettyTraceQuantifier ExistsTrace = text "exists-trace"-prettyTraceQuantifier AllTraces   = text "all-traces"----- Instances: FIXME: Sort them into the right files-----------------------------------------------------$( derive makeBinary ''TheoryItem)-$( derive makeBinary ''LemmaAttribute)-$( derive makeBinary ''TraceQuantifier)-$( derive makeBinary ''Axiom)-$( derive makeBinary ''Lemma)-$( derive makeBinary ''ClosedProtoRule)-$( derive makeBinary ''ClosedRuleCache)-$( derive makeBinary ''Theory)--$( derive makeNFData ''TheoryItem)-$( derive makeNFData ''LemmaAttribute)-$( derive makeNFData ''TraceQuantifier)-$( derive makeNFData ''Axiom)-$( derive makeNFData ''Lemma)-$( derive makeNFData ''ClosedProtoRule)-$( derive makeNFData ''ClosedRuleCache)-$( derive makeNFData ''Theory)-
− src/Theory/Constraint/Solver.hs 
@@ -1,79 +0,0 @@--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ The public interface of the constraint solver, which implements all--- constraint reduction rules and together with a rule application heuristic.-module Theory.Constraint.Solver (--  -- * Constraint systems-    module Theory.Constraint.System--  -- * Proof contexts-  -- | The proof context captures all relevant information about the context-  -- in which we are using the constraint solver. These are things like the-  -- signature of the message theory, the multiset rewriting rules of the-  -- protocol, the available precomputed case distinctions, whether induction-  -- should be applied or not, whether typed or untyped case distinctions are-  -- used, and whether we are looking for the existence of a trace or proving-  -- the absence of any trace satisfying the constraint system.-  , ProofContext(..)-  , pcSignature-  , pcRules-  , pcCaseDists-  , pcUseInduction-  , pcCaseDistKind-  , pcTraceQuantifier-  , pcInjectiveFactInsts--  , InductionHint(..)--  , ClassifiedRules(..)-  , joinAllRules-  , crProtocol-  , crConstruct-  , crDestruct--  -- * Constraint reduction rules--  -- ** Contradictions-  -- | All rules that reduce a constraint system to the empty set of-  -- constraint systems. The 'Contradiction' datatype stores the information-  -- about the contradiction for later display to the user.-  , Contradiction-  , contradictions--  -- ** Precomputed case distinctions-  -- | For better speed, we precompute case distinctions. This is especially-  -- important for getting rid of all chain constraints before actually-  -- starting to verify security properties.-  , CaseDistinction-  , cdGoal-  , cdCases--  , precomputeCaseDistinctions-  , refineWithTypingAsms-  , unsolvedChainConstraints--  -- * Proof methods-  -- | Proof methods are the external to the constraint solver. They allow its-  -- small step execution. This module also provides the heuristics for-  -- selecting the best proof method to apply to a constraint system.-  , module Theory.Constraint.Solver.ProofMethod--  -- ** Convenience export-  , module Logic.Connectives--  ) where--import           Logic.Connectives-import           Theory.Constraint.Solver.CaseDistinctions-import           Theory.Constraint.Solver.Contradictions-import           Theory.Constraint.Solver.ProofMethod-import           Theory.Constraint.Solver.Types-import           Theory.Constraint.System--
− src/Theory/Constraint/Solver/CaseDistinctions.hs 
@@ -1,318 +0,0 @@--- |--- Copyright   : (c) 2011,2012 Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Big-step proofs using case distinctions on the possible sources of a fact.-module Theory.Constraint.Solver.CaseDistinctions (-  -- * Precomputed case distinctions--  -- ** Queries-    unsolvedChainConstraints--  -- ** Construction-  , precomputeCaseDistinctions-  , refineWithTypingAsms--  -- ** Application-  , solveWithCaseDistinction--  ) where--import           Prelude                                 hiding (id, (.))-import           Safe--import           Data.Foldable                           (asum)-import qualified Data.Map                                as M-import           Data.Maybe                              (isJust)-import qualified Data.Set                                as S--import           Control.Basics-import           Control.Category-import           Control.Monad.Disj-import           Control.Monad.Reader-import           Control.Monad.State                     (gets)-import           Control.Parallel.Strategies--import           Text.PrettyPrint.Highlight--import           Extension.Data.Label-import           Extension.Prelude--import           Theory.Constraint.Solver.Contradictions (contradictorySystem)-import           Theory.Constraint.Solver.Goals-import           Theory.Constraint.Solver.Reduction-import           Theory.Constraint.Solver.Simplify-import           Theory.Constraint.Solver.Types-import           Theory.Constraint.System-import           Theory.Model------------------------------------------------------------------------------------ Precomputing case distinctions----------------------------------------------------------------------------------- | The number of remaining chain constraints of each case.-unsolvedChainConstraints :: CaseDistinction -> [Int]-unsolvedChainConstraints =-    map (length . unsolvedChains . snd) . getDisj . get cdCases----- Construction-------------------- | The initial case distinction if the given goal is required and the--- given typing assumptions are justified.-initialCaseDistinction-    :: ProofContext-    -> [LNGuarded] -- ^ Axioms.-    -> Goal-    -> CaseDistinction-initialCaseDistinction ctxt axioms goal =-    CaseDistinction goal cases-  where-    polish ((name, se), _) = ([name], se)-    se0   = insertLemmas axioms $ emptySystem UntypedCaseDist-    cases = fmap polish $-        runReduction instantiate ctxt se0 (avoid (goal, se0))-    instantiate = do-        insertGoal goal False-        solveGoal goal---- | Refine a source case distinction by applying the additional proof step.-refineCaseDistinction-    :: ProofContext-    -> Reduction (a, [String])  -- proof step with result and path extension-    -> CaseDistinction-    -> ([a], CaseDistinction)-refineCaseDistinction ctxt proofStep th =-    ( map fst $ getDisj refinement-    , set cdCases (snd <$> refinement) th )-  where-    fs         = avoid th-    refinement = do-        (names, se)   <- get cdCases th-        ((x, names'), se') <- fst <$> runReduction proofStep ctxt se fs-        return (x, (combine names names', se'))--    -- Combine names such that the coerce rule is blended out.-    combine []            ns' = ns'-    combine ("coerce":ns) ns' = combine ns ns'-    combine (n       :_)  _   = [n]---- | Solves all chain and splitting goals as well as all premise goals solvable--- with one of the given precomputed requires case distinction theorems, while--- repeatedly simplifying the proof state.------ Returns the names of the steps applied.-solveAllSafeGoals :: [CaseDistinction] -> Reduction [String]-solveAllSafeGoals ths =-    solve []-  where-    safeGoal _       (_,   (_, LoopBreaker)) = False-    safeGoal doSplit (goal, _              ) =-      case goal of-        ChainG _ _    -> True-        ActionG _ fa  -> not (isKUFact fa)-        PremiseG _ fa -> not (isKUFact fa)-        DisjG _       -> doSplit-        -- Uncomment to get more extensive case splitting-        -- SplitG _   -> doSplit-        SplitG _      -> False--    usefulGoal (_, (_, Useful)) = True-    usefulGoal _                = False--    solve caseNames = do-        simplifySystem-        ctxt <- ask-        contradictoryIf =<< gets (contradictorySystem ctxt)-        goals  <- gets openGoals-        chains <- gets unsolvedChains-        -- try to either solve a safe goal or use one of the precomputed case-        -- distinctions-        let noChainGoals = null [ () | (ChainG _ _, _) <- goals ]-            -- we perform equation splits, if there is a chain goal starting-            -- from a message variable; i.e., a chain constraint that is no-            -- open goal.-            splitAllowed = noChainGoals && not (null chains)-            safeGoals    = fst <$> filter (safeGoal splitAllowed) goals-            usefulGoals  = fst <$> filter usefulGoal goals-            nextStep        =-                ((fmap return . solveGoal) <$> headMay safeGoals) <|>-                (asum $ map (solveWithCaseDistinction ctxt ths) usefulGoals)-        case nextStep of-          Nothing   -> return $ caseNames-          Just step -> solve . (caseNames ++) =<< step------------------------------------------------------------------------------------ Applying precomputed case distinctions----------------------------------------------------------------------------------- | Match a precomputed 'CaseDistinction' to a goal.-matchToGoal-    :: ProofContext     -- ^ Proof context used for refining the case distinction.-    -> CaseDistinction  -- ^ Case distinction to use.-    -> Goal             -- ^ Goal to match-    -> Maybe (Reduction [String])-    -- ^ A constraint reduction step to apply the resulting case distinction.-    -- Note that this step assumes that the theorem has been imported using-    -- 'someInst' into the context that this reduction is executed in.-    ---    -- FIXME: This is a mess. Factor code such that this inter-dependency-    -- between 'applyCaseDistinction' and 'matchToGoal' goes away.-matchToGoal ctxt th goalTerm =-  case (goalTerm, get cdGoal th) of-    ( PremiseG      (iTerm, premIdxTerm) faTerm-     ,PremiseG pPat@(iPat,  _          ) faPat  ) ->-        let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in-        case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of-            []      -> Nothing-            subst:_ -> Just $ genericApply subst $-                -- add the missing edge to each case of the theorem-                modify sEdges (substNodePrem pPat (iPat, premIdxTerm))--    (ActionG iTerm faTerm, ActionG iPat faPat) ->-        let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in-        case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of-            []      -> Nothing-            subst:_ -> Just $ genericApply subst id--    -- No other matches possible, as we only precompute case distinctions for-    -- premises and KU-actions.-    _ -> Nothing-  where-    genericApply subst systemModifier = do-        void (solveSubstEqs SplitNow subst)-        (names, sysTh) <- disjunctionOfList $ getDisj $ get cdCases th-        conjoinSystem (systemModifier sysTh)-        return names--    substNodePrem from to = S.map-        (\ e@(Edge c p) -> if p == from then Edge c to else e)---- | Try to solve a premise goal or 'Ded' action using the first precomputed--- case distinction with a matching premise.-solveWithCaseDistinction :: ProofContext-                         -> [CaseDistinction]-                         -> Goal-                         -> Maybe (Reduction [String])-solveWithCaseDistinction hnd ths goal = do-    -- goal <- toBigStepGoal goal0-    asum [ applyCaseDistinction hnd th goal | th <- ths ]---- | Apply a precomputed case distinction theorem to a required fact.-applyCaseDistinction :: ProofContext-                     -> CaseDistinction    -- ^ Case distinction theorem.-                     -> Goal               -- ^ Required goal-                     -> Maybe (Reduction [String])-applyCaseDistinction ctxt th goal-  | isJust $ matchToGoal ctxt th goal = Just $ do-        markGoalAsSolved "precomputed" goal-        thRenamed <- rename th-        fromJustNote "applyCaseDistinction: impossible" $-            matchToGoal ctxt thRenamed goal--  | otherwise = Nothing---- | Saturate the case distinctions with respect to each other such that no--- additional splitting is introduced; i.e., only rules with a single or no--- conclusion are used for the saturation.-saturateCaseDistinctions-    :: ProofContext -> [CaseDistinction] -> [CaseDistinction]-saturateCaseDistinctions ctxt =-    go-  where-    go ths =-        if any or (changes `using` parList rdeepseq)-          then go ths'-          else ths'-      where-        (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths-        goodTh th  = length (getDisj (get cdCases th)) <= 1-        solver     = do names <- solveAllSafeGoals (filter goodTh ths)-                        return (not $ null names, names)---- | Precompute a saturated set of case distinctions.-precomputeCaseDistinctions-    :: ProofContext-    -> [LNGuarded]       -- ^ Axioms.-    -> [CaseDistinction]-precomputeCaseDistinctions ctxt axioms =-    map cleanupCaseNames $ saturateCaseDistinctions ctxt rawCaseDists-  where-    cleanupCaseNames = modify cdCases $ fmap $ first $-        filter (not . null)-      . map (filter (`elem` '_' : ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']))--    rawCaseDists =-        initialCaseDistinction ctxt axioms <$> (protoGoals ++ msgGoals)--    -- construct case distinction starting from facts from non-special rules-    protoGoals = someProtoGoal <$> absProtoFacts-    msgGoals   = someKUGoal <$> absMsgFacts--    getProtoFact (Fact KUFact _ ) = mzero-    getProtoFact (Fact KDFact _ ) = mzero-    getProtoFact fa               = return fa--    absFact (Fact tag ts) = (tag, length ts)--    nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ]--    someProtoGoal :: (FactTag, Int) -> Goal-    someProtoGoal (tag, arity) =-        PremiseG (someNodeId, PremIdx 0) (Fact tag (nMsgVars arity))--    someKUGoal :: LNTerm -> Goal-    someKUGoal m = ActionG someNodeId (kuFact m)--    someNodeId = LVar "i" LSortNode 0--    -- FIXME: Also use facts from proof context.-    rules = get pcRules ctxt-    absProtoFacts = sortednub $ do-        ru <- joinAllRules rules-        fa <- absFact <$> (getProtoFact =<< (get rConcs ru ++ get rPrems ru))-        -- exclude facts handled specially by the prover-        guard (not $ fst fa `elem` [OutFact, InFact, FreshFact])-        return fa--    absMsgFacts :: [LNTerm]-    absMsgFacts = asum $ sortednub $-      [ do return $ lit $ Var (LVar "t" LSortFresh 1)--      , [ fAppNonAC (s,k) $ nMsgVars k-        | (s,k) <- S.toList . allFunctionSymbols  . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt-        , (s,k) `S.notMember` implicitFunSig, k > 0 ]-      ]---- | Refine a set of case distinction by exploiting additional typing--- assumptions.-refineWithTypingAsms-    :: [LNGuarded]        -- ^ Typing assumptions to use.-    -> ProofContext       -- ^ Proof context to use.-    -> [CaseDistinction]  -- ^ Original, untyped case distinctions.-    -> [CaseDistinction]  -- ^ Refined, typed case distinctions.-refineWithTypingAsms assumptions ctxt cases0 =-    fmap (modifySystems removeFormulas) $-    saturateCaseDistinctions ctxt $-    modifySystems updateSystem <$> cases0-  where-    modifySystems   = modify cdCases . fmap . second-    updateSystem se =-        modify sFormulas (S.union (S.fromList assumptions)) $-        set sCaseDistKind TypedCaseDist                     $ se-    removeFormulas =-        modify sGoals (M.filterWithKey isNoDisjGoal)-      . set sFormulas S.empty-      . set sSolvedFormulas S.empty--    isNoDisjGoal (DisjG _)  _ = False-    isNoDisjGoal _          _ = True---
− src/Theory/Constraint/Solver/Contradictions.hs 
@@ -1,242 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns    #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ This is the public interface for constructing and deconstructing constraint--- systems. The interface for performing constraint solving provided by--- "Theory.Constraint.Solver".-module Theory.Constraint.Solver.Contradictions (--  -- * Contradictory constraint systems-    Contradiction(..)-  , substCreatesNonNormalTerms-  , contradictions-  , contradictorySystem--  -- ** Pretty-printing-  , prettyContradiction--  ) where--import           Prelude                        hiding (id, (.))--import           Data.Binary-import qualified Data.DAG.Simple                as D (cyclic, reachableSet)-import           Data.DeriveTH-import qualified Data.Foldable                  as F-import           Data.List-import qualified Data.Map                       as M-import           Data.Maybe                     (fromMaybe)-import           Data.Monoid-import qualified Data.Set                       as S-import           Safe                           (headMay)--import           Control.Basics-import           Control.Category-import           Control.DeepSeq-import           Control.Monad.Reader--import qualified Extension.Data.Label           as L-import           Extension.Prelude--import           Theory.Constraint.Solver.Types-import           Theory.Constraint.System-import           Theory.Model-import           Theory.Text.Pretty--import           Term.Rewriting.Norm            (maybeNotNfSubterms, nf')------------------------------------------------------------------------------------ Contradictions----------------------------------------------------------------------------------- | Reasons why a constraint 'System' can be contradictory.-data Contradiction =-    Cyclic                         -- ^ The paths are cyclic.-  | NonNormalTerms                 -- ^ Has terms that are not in normal form.-  -- | NonLastNode                    -- ^ Has a non-silent node after the last node.-  | ForbiddenExp                   -- ^ Forbidden Exp-down rule instance-  | NonInjectiveFactInstance (NodeId, NodeId, NodeId)-    -- ^ Contradicts that certain facts have unique instances.-  | IncompatibleEqs                -- ^ Incompatible equalities.-  | FormulasFalse                  -- ^ False in formulas-  | SuperfluousLearn LNTerm NodeId -- ^ A term is derived both before and after a learn-  | NodeAfterLast (NodeId, NodeId) -- ^ There is a node after the last node.-  deriving( Eq, Ord, Show )----- | 'True' if the constraint system is contradictory.-contradictorySystem :: ProofContext -> System -> Bool-contradictorySystem ctxt = not . null . contradictions ctxt---- | All CR-rules reducing a constraint system to *⟂* represented as a list of--- trivial contradictions. Note that some constraint systems are also removed--- because they have no unifier. This is part of unification. Note also that--- *S_{¬,@}* is handled as part of *S_∀*.-contradictions :: ProofContext -> System -> [Contradiction]-contradictions ctxt sys = F.asum-    -- CR-rule **-    [ guard (D.cyclic $ rawLessRel sys)             *> pure Cyclic-    -- CR-rule *N1*-    , guard (hasNonNormalTerms sig sys)             *> pure NonNormalTerms-    -- CR-rule *N7*-    , guard (hasForbiddenExp sys)                   *> pure ForbiddenExp-    -- CR-rules *S_≐* and *S_≈* are implemented via the equation store-    , guard (eqsIsFalse $ L.get sEqStore sys)       *> pure IncompatibleEqs-    -- CR-rules *S_⟂*, *S_{¬,last,1}*, *S_{¬,≐}*, *S_{¬,≈}*-    , guard (S.member gfalse $ L.get sFormulas sys) *> pure FormulasFalse-    ]-    ++-    -- This rule is not yet documented. It removes constraint systems that-    -- require a unique fact to be present in the system state more than once.-    -- Unique facts are declared as part of the specification of the rule-    -- system.-    (NonInjectiveFactInstance <$> nonInjectiveFactInstances ctxt sys)-    ++-    -- TODO: Document corresponding constratint reduction rule.-    (NodeAfterLast <$> nodesAfterLast sys)-  where-    sig = L.get pcSignature ctxt---- | True iff there are terms in the node constraints that are not in normal form wrt.--- to 'Term.Rewriting.Norm.norm' (DH/AC).-hasNonNormalTerms :: SignatureWithMaude -> System -> Bool-hasNonNormalTerms sig se =-    any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se)-  where hnd = L.get sigmMaudeHandle sig---- | Returns all (sub)terms of node constraints that may be not in normal form.-maybeNonNormalTerms :: MaudeHandle -> System -> [LNTerm]-maybeNonNormalTerms hnd se =-    sortednub . concatMap getTerms . M.elems . L.get sNodes $ se-  where getTerms (Rule _ ps cs as) = do-          f <- ps++cs++as-          t <- factTerms f-          maybeNotNfSubterms (mhMaudeSig hnd) t--substCreatesNonNormalTerms :: MaudeHandle -> System -> LNSubstVFresh -> Bool-substCreatesNonNormalTerms hnd se =-    \subst -> any (not . nfApply subst) terms-  where terms = maybeNonNormalTerms hnd se-        nfApply subst0 t = t == t'  || nf' t' `runReader` hnd-          where tvars = freesList t-                subst = restrictVFresh tvars subst0-                t'  = apply (freshToFreeAvoidingFast subst tvars) t---- | True if there is no @EXP-down@ rule that should be replaced by an--- @EXP-up@ rule.-hasForbiddenExp :: System -> Bool-hasForbiddenExp se =-    any (isForbiddenExp) $ M.elems $ L.get sNodes se---- | @isForbiddenExp ru@ returns @True@ if @ru@ is not allowed in--- a normal dependency graph.--- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]---                           [Fact KDFact [expTagToTerm IsExp, Exp p1 (Mult x2 x3)]] [])--- > False--- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]---                           [Fact KDFact [expTagToTerm IsExp, Exp p1 x2]] [])--- > True-isForbiddenExp :: Rule a -> Bool-isForbiddenExp ru = fromMaybe False $ do-    [p1,p2] <- return $ L.get rPrems ru-    [conc]  <- return $ L.get rConcs ru-    (DnK, viewTerm2 -> FExp _ _) <- kFactView p1-    (UpK, b                    ) <- kFactView p2-    (DnK, viewTerm2 -> FExp g c) <- kFactView conc--    -- For a forbidden exp the following conditions must hold: g must be of-    -- sort 'pub' and the required inputs for c are already required by b-    return $    sortOfLNTerm g == LSortPub-             && (inputTerms c \\ inputTerms b == [])----- | Compute all contradictions to injective fact instances.------ Formally, they are computed as follows. Let 'f' be a fact symbol with--- injective instances. Let i, j, and k be temporal variables ordered--- according to------   i < j < k------ and let there be an edge from (i,u) to (k,w) for some indices u and v------ Then, we have a contradiction if both the premise (k,w) that requires a--- fact 'f(t,...)' and there is a premise (j,v) requiring a fact 'f(t,...)'.------ These two premises would have to be merged, but cannot due to the ordering--- constraint 'j < k'.-nonInjectiveFactInstances :: ProofContext -> System -> [(NodeId, NodeId, NodeId)]-nonInjectiveFactInstances ctxt se = do-    Edge c@(i, _) (k, _) <- S.toList $ L.get sEdges se-    let kFaPrem            = nodeConcFact c se-        kTag               = factTag kFaPrem-        kTerm              = firstTerm kFaPrem-        conflictingFact fa = factTag fa == kTag && firstTerm fa == kTerm--    guard (kTag `S.member` L.get pcInjectiveFactInsts ctxt)-    j <- S.toList $ D.reachableSet [i] less--    let isCounterExample = (j /= i) && (j /= k) &&-                           maybe False checkRule (M.lookup j $ L.get sNodes se)--        -- FIXME: There should be a weaker version of the rule that just-        -- introduces the constraint 'k < j || k == j' here.-        checkRule jRu    = any conflictingFact (L.get rPrems jRu) &&-                           k `S.member` D.reachableSet [j] less--    guard isCounterExample-    return (i, j, k) -- counter-example to unique fact instances-  where-    less      = rawLessRel se-    firstTerm = headMay . factTerms---- | The node-ids that must be instantiated to the trace, but are temporally--- after the last node.-nodesAfterLast :: System -> [(NodeId, NodeId)]-nodesAfterLast sys = case L.get sLastAtom sys of-  Nothing -> []-  Just i  -> do j <- S.toList $ D.reachableSet [i] $ rawLessRel sys-                guard (j /= i && isInTrace sys j)-                return (i, j)----- | Pretty-print a 'Contradiction'.-prettyContradiction :: Document d => Contradiction -> d-prettyContradiction contra = case contra of-    Cyclic                       -> text "cyclic"-    IncompatibleEqs              -> text "incompatible equalities"-    NonNormalTerms               -> text "non-normal terms"-    ForbiddenExp                 -> text "non-normal exponentiation instance"-    NonInjectiveFactInstance cex -> text $ "non-injective facts " ++ show cex-    FormulasFalse                -> text "from formulas"-    SuperfluousLearn m v         ->-        doubleQuotes (prettyLNTerm m) <->-        text ("derived before and after") <->-        doubleQuotes (prettyNodeId v)-    NodeAfterLast (i,j)       ->-        text $ "node " ++ show j ++ " after last node " ++ show i----- Instances---------------instance HasFrees Contradiction where-  foldFrees f (SuperfluousLearn t v)       = foldFrees f t `mappend` foldFrees f v-  foldFrees f (NonInjectiveFactInstance x) = foldFrees f x-  foldFrees f (NodeAfterLast x)            = foldFrees f x-  foldFrees _ _                            = mempty--  mapFrees f (SuperfluousLearn t v)       = SuperfluousLearn <$> mapFrees f t <*> mapFrees f v-  mapFrees f (NonInjectiveFactInstance x) = NonInjectiveFactInstance <$> mapFrees f x-  mapFrees f (NodeAfterLast x)            = NodeAfterLast <$> mapFrees f x-  mapFrees _ c                            = pure c--$( derive makeBinary ''Contradiction)-$( derive makeNFData ''Contradiction)
− src/Theory/Constraint/Solver/Goals.hs 
@@ -1,284 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns  #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ The constraint reduction rules, which are not enforced as invariants in--- "Theory.Constraint.Solver.Reduction".------ A goal represents a possible application of a rule that may result in--- multiple cases or even non-termination (if applied repeatedly). These goals--- are computed as the list of 'openGoals'. See--- "Theory.Constraint.Solver.ProofMethod" for the public interface to solving--- goals and the implementation of heuristics.-module Theory.Constraint.Solver.Goals (-    Usefulness(..)-  , AnnotatedGoal-  , openGoals-  , solveGoal-  ) where--import           Prelude                                 hiding (id, (.))--import qualified Data.DAG.Simple                         as D (cyclic)-import qualified Data.Map                                as M-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. Needs to be-  -- handled fairly.-  | ProbablySolvable-  -- ^ A goal that is very likely to be solvable without introducing further-  -- interesting constraints. These goals are delayed until the very end.-  deriving (Show, Eq)---- | Goals annotated with their number and usefulness.-type AnnotatedGoal = (Goal, (Integer, Usefulness))----- Instances----------------- We need a custom 'Ord' instance that guarantees that @Useful < Useless@.-instance Ord Usefulness where-        compare a b =-            check a b-          where-            check Useful           Useful           = EQ-            check LoopBreaker      LoopBreaker      = EQ-            check ProbablySolvable ProbablySolvable = EQ-            check x y                               = compare (tag x) (tag y)--            tag (Useful)           = 0 :: Int-            tag (LoopBreaker)      = 1-            tag (ProbablySolvable) = 2----- | 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-            | isSimpleTerm m || deducible i m       -> ProbablySolvable-          _                                         -> Useful--    return (goal, (get gsNr status, useful))-  where-    existingDeps = rawLessRel sys-    hasKUGuards  =-        any ((KUFact `elem`) . guardFactTags) $ S.toList $ get sFormulas sys--    -- We use the following heuristic for marking KU-actions as useful (worth-    -- solving now) or useless (to be delayed until no more useful goals-    -- remain). We ignore all goals that are simple terms or where there-    -- exists a node, not after the premise or the last node, providing an Out-    -- or KD conclusion that provides the message we are looking for as a-    -- toplevel term. If such a node exist, then solving the goal will result-    -- in at least one case where we didn't make real progress except.-    toplevelTerms t@(destPair -> Just (t1, t2)) =-        t : toplevelTerms t1 ++ toplevelTerms t2-    toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1-    toplevelTerms t = [t]--    deducible 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))------------------------------------------------------------------------------------ Solving 'Goal's----------------------------------------------------------------------------------- | @solveGoal rules goal@ enumerates all possible cases of how this goal--- could be solved in the context of the given @rules@. For each case, a--- sensible case-name is returned.-solveGoal :: Goal -> Reduction String-solveGoal goal = do-    -- mark before solving, as representation might change due to unification-    markGoalAsSolved "directly" goal-    rules <- askM pcRules-    case goal of-      ActionG i fa  -> solveAction  (nonSilentRules rules) (i, fa)-      PremiseG p fa ->-           solvePremise (get crProtocol rules ++ get crConstruct rules) p fa-      ChainG c p    -> solveChain (get crDestruct  rules) (c, p)-      SplitG i      -> solveSplit i-      DisjG disj    -> solveDisjunction disj---- The follwoing functions are internal to 'solveGoal'. Use them with great--- care.---- | CR-rule *S_at*: solve an action goal.-solveAction :: [RuleAC]          -- ^ All rules labelled with an action-            -> (NodeId, LNFact)  -- ^ The action we are looking for.-            -> Reduction String  -- ^ A sensible case name.-solveAction rules (i, fa) = do-    mayRu <- M.lookup i <$> getM sNodes-    showRuleCaseName <$> case mayRu of-        Nothing -> do ru  <- labelNodeId i rules-                      act <- disjunctionOfList $ get rActs ru-                      void (solveFactEqs SplitNow [Equal fa act])-                      return ru--        Just ru -> do unless (fa `elem` get rActs ru) $ do-                          act <- disjunctionOfList $ get rActs ru-                          void (solveFactEqs SplitNow [Equal fa act])-                      return ru---- | CR-rules *DG_{2,P}* and *DG_{2,d}*: solve a premise with a direct edge--- from a unifying conclusion or using a destruction chain.------ Note that *In*, *Fr*, and *KU* facts are solved directly when adding a--- 'ruleNode'.----solvePremise :: [RuleAC]       -- ^ All rules with a non-K-fact conclusion.-             -> NodePrem       -- ^ Premise to solve.-             -> LNFact         -- ^ Fact required at this premise.-             -> Reduction String -- ^ Case name to use.-solvePremise rules p faPrem-  | isKDFact faPrem = do-      iLearn    <- freshLVar "vl" LSortNode-      mLearn    <- varTerm <$> freshLVar "t" LSortMsg-      let concLearn = kdFact mLearn-          premLearn = outFact mLearn-          -- !! Make sure that you construct the correct rule!-          ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] []-          cLearn = (iLearn, ConcIdx 0)-          pLearn = (iLearn, PremIdx 0)-      modM sNodes  (M.insert iLearn ruLearn)-      insertChain cLearn p-      solvePremise rules pLearn premLearn--  | otherwise = do-      (ru, c, faConc) <- insertFreshNodeConc rules-      insertEdges [(c, faConc, faPrem, p)]-      return $ showRuleCaseName ru---- | CR-rule *DG2_chain*: solve a chain constraint.-solveChain :: [RuleAC]              -- ^ All destruction rules.-           -> (NodeConc, NodePrem)  -- ^ The chain to extend by one step.-           -> Reduction String      -- ^ Case name to use.-solveChain rules (c, p) = do-    faConc  <- gets $ nodeConcFact c-    (do -- solve it by a direct edge-        faPrem <- gets $ nodePremFact p-        insertEdges [(c, faConc, faPrem, p)]-        let m = case kFactView faConc of-                  Just (DnK, m') -> m'-                  _              -> error $ "solveChain: impossible"-            caseName (viewTerm -> FApp o _) = showFunSymName o-            caseName t                      = show t-        return $ caseName m-     `disjunction`-     do -- extend it with one step-        cRule <- gets $ nodeRule (nodeConcNode c)-        (i, ru)     <- insertFreshNode rules-        -- contradicts normal form condition:-        -- no edge from dexp to dexp KD premise-        -- (this condition replaces the exp/noexp tags)-        contradictoryIf (isDexpRule cRule && isDexpRule ru)-        (v, faPrem) <- disjunctionOfList $ enumPrems ru-        insertEdges [(c, faConc, faPrem, (i, v))]-        markGoalAsSolved "directly" (PremiseG (i, v) faPrem)-        insertChain (i, ConcIdx 0) p-        return $ showRuleCaseName ru-     )-  where-    isDexpRule ru = case get rInfo ru of-        IntrInfo (DestrRule n) | n == expSymString -> True-        _                                          -> False---- | Solve an equation split. There is no corresponding CR-rule in the rule--- system on paper because there we eagerly split over all variants of a rule.--- In practice, this is too expensive and we therefore use the equation store--- to delay these splits.-solveSplit :: SplitId -> Reduction String-solveSplit x = do-    split <- gets ((`performSplit` x) . get sEqStore)-    let errMsg = error "solveSplit: inexistent split-id"-    store      <- maybe errMsg disjunctionOfList split-    -- FIXME: Simplify this interaction with the equation store-    hnd        <- getMaudeHandle-    substCheck <- gets (substCreatesNonNormalTerms hnd)-    store'     <- simp hnd substCheck store-    contradictoryIf (eqsIsFalse store')-    sEqStore =: store'-    return "split"---- | CR-rule *S_disj*: solve a disjunction of guarded formulas using a case--- distinction.------ In contrast to the paper, we use n-ary disjunctions and also split over all--- of them at once.-solveDisjunction :: Disj LNGuarded -> Reduction String-solveDisjunction disj = do-    (i, gfm) <- disjunctionOfList $ zip [(1::Int)..] $ getDisj disj-    insertFormula gfm-    return $ "case_" ++ show i-
− src/Theory/Constraint/Solver/ProofMethod.hs 
@@ -1,414 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections   #-}-{-# LANGUAGE ViewPatterns    #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Proof methods and heuristics: the external small-step interface to the--- constraint solver.-module Theory.Constraint.Solver.ProofMethod (-  -- * Proof methods-    CaseName-  , ProofMethod(..)-  , execProofMethod--  -- ** Heuristics-  , GoalRanking(..)-  , goalRankingName-  , rankProofMethods--  , Heuristic-  , roundRobinHeuristic-  , useHeuristic--  -- ** Pretty Printing-  , prettyProofMethod--) where--import           Data.Binary-import           Data.DeriveTH-import           Data.Function                             (on)-import           Data.Label                                hiding (get)-import qualified Data.Label                                as L-import           Data.List-import qualified Data.Map                                  as M-import           Data.Monoid-import           Data.Ord                                  (comparing)-import qualified Data.Set                                  as S-import           Extension.Prelude                         (sortOn)--import           Control.Basics-import           Control.DeepSeq-import           Control.Monad.Bind-import qualified Control.Monad.Trans.PreciseFresh          as Precise--import           Theory.Constraint.Solver.CaseDistinctions-import           Theory.Constraint.Solver.Contradictions-import           Theory.Constraint.Solver.Goals-import           Theory.Constraint.Solver.Reduction-import           Theory.Constraint.Solver.Simplify-import           Theory.Constraint.Solver.Types-import           Theory.Constraint.System-import           Theory.Model-import           Theory.Text.Pretty------------------------------------------------------------------------------------ Utilities----------------------------------------------------------------------------------- | @uniqueListBy eq changes xs@ zips the @changes@ with all sequences equal--- elements in the list.------ > uniqueListBy compare id (const [ (++ show i) | i <- [1..] ]) ["a","b","a"] =--- > ["a1","b","a2"]----uniqueListBy :: (a -> a -> Ordering) -> (a -> a) -> (Int -> [a -> a]) -> [a] -> [a]-uniqueListBy ord single distinguish xs0 =-      map fst-    $ sortBy (comparing snd)-    $ concat $ map uniquify $ groupBy (\x y -> ord (fst x) (fst y) == EQ)-    $ sortBy (ord `on` fst)-    $ zip xs0 [(0::Int)..]-  where-    uniquify []      = error "impossible"-    uniquify [(x,i)] = [(single x, i)]-    uniquify xs      = zipWith (\f (x,i) -> (f x, i)) dist xs-      where-        dist = distinguish $ length xs------------------------------------------------------------------------------------ Proof Methods----------------------------------------------------------------------------------- | Every case in a proof is uniquely named.-type CaseName = String---- | Sound transformations of sequents.-data ProofMethod =-    Sorry (Maybe String)                 -- ^ Proof was not completed-  | Solved                               -- ^ An attack was fond-  | Simplify                             -- ^ A simplification step.-  | SolveGoal Goal                       -- ^ A goal that was solved.-  | Contradiction (Maybe Contradiction)  -- ^ A contradiction could be-                                         -- derived, possibly with a reason.-  | Induction                            -- ^ Use inductive strengthening on-                                         -- the single formula constraint in-                                         -- the system.-  deriving( Eq, Ord, Show )--instance HasFrees ProofMethod where-    foldFrees f (SolveGoal g)     = foldFrees f g-    foldFrees f (Contradiction c) = foldFrees f c-    foldFrees _ _                 = mempty--    mapFrees f (SolveGoal g)     = SolveGoal <$> mapFrees f g-    mapFrees f (Contradiction c) = Contradiction <$> mapFrees f c-    mapFrees _ method            = pure method----- Proof method execution------------------------------- @execMethod rules method se@ checks first if the @method@ is applicable to--- the sequent @se@. Then, it applies the @method@ to the sequent under the--- assumption that the @rules@ describe all rewriting rules in scope.------ NOTE that the returned systems have their free substitution fully applied--- and all variable indices reset.-execProofMethod :: ProofContext-                -> ProofMethod -> System -> Maybe (M.Map CaseName System)-execProofMethod ctxt method sys =-    M.map cleanupSystem <$>-      case method of-        Sorry _                  -> return M.empty-        Solved-          | null (openGoals sys) -> return M.empty-          | otherwise            -> Nothing-        SolveGoal goal-          | goal `M.member` L.get sGoals sys -> execSolveGoal goal-          | otherwise                      -> Nothing-        Simplify                 -> singleCase (/=) simplifySystem-        Induction                -> execInduction-        Contradiction _-          | null (contradictions ctxt sys) -> Nothing-          | otherwise                      -> Just M.empty-  where-    -- at this point it is safe to remove the free substitution, as all-    -- systems have it fully applied (by the virtue of a call to-    -- simplifySystem). We also reset the variable indices here.-    cleanupSystem =-         (`Precise.evalFresh` Precise.nothingUsed)-       . (`evalBindT` noBindings)-       . someInst-       . set sSubst emptySubst---    -- expect only one or no subcase in the given case distinction-    singleCase check m =-        case map fst $ getDisj $ execReduction m ctxt sys (avoid sys) of-          []                      -> return $ M.empty-          [sys'] | check sys sys' -> return $ M.singleton "" sys'-                 | otherwise      -> mzero-          syss                    ->-               return $ M.fromList (zip (map show [(1::Int)..]) syss)--    -- solve the given goal-    -- PRE: Goal must be valid in this system.-    execSolveGoal goal = do-        return $ makeCaseNames $ map fst $ getDisj $-            runReduction solver ctxt sys (avoid sys)-      where-        ths    = L.get pcCaseDists ctxt-        solver = do name <- maybe (solveGoal goal)-                                  (fmap $ concat . intersperse "_")-                                  (solveWithCaseDistinction ctxt ths goal)-                    simplifySystem-                    return name--        makeCaseNames =-            M.fromListWith (error "case names not unique")-          . uniqueListBy (comparing fst) id distinguish-          where-            distinguish n =-                [ (\(x,y) -> (x ++ "_case_" ++ pad (show i), y))-                | i <- [(1::Int)..] ]-              where-                l      = length (show n)-                pad cs = replicate (l - length cs) '0' ++ cs--    -- Apply induction: possible if the system contains only-    -- a single, last-free, closed formula.-    execInduction-      | sys == sys0 =-          case S.toList $ L.get sFormulas sys of-            [gf] -> case ginduct gf of-                      Right (bc, sc) -> Just $ insCase "empty_trace"     bc-                                             $ insCase "non_empty_trace" sc-                                             $ M.empty-                      _              -> Nothing-            _    -> Nothing--      | otherwise = Nothing-      where-        sys0 = set sFormulas (L.get sFormulas sys)-             $ set sLemmas (L.get sLemmas sys)-             $ emptySystem (L.get sCaseDistKind sys)--        insCase name gf = M.insert name (set sFormulas (S.singleton gf) sys)----------------------------------------------------------------------------------- Heuristics----------------------------------------------------------------------------------- | The different available functions to rank goals with respect to their--- order of solving in a constraint system.-data GoalRanking =-    GoalNrRanking-  | UsefulGoalNrRanking-  | SmartRanking Bool-  deriving( Eq, Ord, Show )---- | The name/explanation of a 'GoalRanking'.-goalRankingName :: GoalRanking -> String-goalRankingName ranking =-    "Goals sorted according to " ++ case ranking of-        GoalNrRanking                -> "their order of creation"-        UsefulGoalNrRanking          -> "their usefulness and order of creation"-        SmartRanking useLoopBreakers -> smart useLoopBreakers-   where-     smart b = "the 'smart' heuristic (loop breakers " ++-               (if b then "allowed" else "delayed") ++ ")."---- | Use a 'GoalRanking' to sort a list of 'AnnotatedGoal's stemming from the--- given constraint 'System'.-rankGoals :: GoalRanking -> System -> [AnnotatedGoal] -> [AnnotatedGoal]-rankGoals ranking = case ranking of-    GoalNrRanking       -> \_sys -> goalNrRanking-    UsefulGoalNrRanking ->-        \_sys -> sortOn (\(_, (nr, useless)) -> (useless, nr))-    SmartRanking useLoopsBreakers -> smartRanking useLoopsBreakers---- | Use a 'GoalRanking' to generate the ranked, list of possible--- 'ProofMethod's and their corresponding results in this 'ProofContext' and--- for this 'System'. If the resulting list is empty, then the constraint--- system is solved.-rankProofMethods :: GoalRanking -> ProofContext -> System-                 -> [(ProofMethod, (M.Map CaseName System, String))]-rankProofMethods ranking ctxt sys = do-    (m, expl) <--            (contradiction <$> contradictions ctxt sys)-        <|> (case L.get pcUseInduction ctxt of-               AvoidInduction -> [(Simplify, ""), (Induction, "")]-               UseInduction   -> [(Induction, ""), (Simplify, "")]-            )-        <|> (solveGoalMethod <$> (rankGoals ranking sys $ openGoals sys))-    case execProofMethod ctxt m sys of-      Just cases -> return (m, (cases, expl))-      Nothing    -> []-  where-    contradiction c                    = (Contradiction (Just c), "")-    solveGoalMethod (goal, (nr, usefulness)) =-      ( SolveGoal goal-      , "nr. " ++ show nr ++ case usefulness of-                               Useful           -> ""-                               LoopBreaker      -> " (loop breaker)"-                               ProbablySolvable -> " (probably solvable)"-      )--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 (snd . snd)--    unmark | allowPremiseGLoopBreakers = map unmarkPremiseG-           | otherwise                 = id--    unmarkPremiseG (goal@(PremiseG _ _), (nr, _)) = (goal, (nr, Useful))-    unmarkPremiseG annGoal                        = annGoal--    solveFirst =-        [ isChainGoal . fst-        , isDisjGoal . fst-        , isNonLoopBreakerProtoFactGoal-        , isStandardActionGoal . fst-        , isFreshKnowsGoal . fst-        , isSplitGoalSmall . fst-        , isDoubleExpGoal . fst-        , isNoLargeSplitGoal . fst ]-        -- move the rest (mostly more expensive KU-goals) before expensive-        -- equation splits--    -- FIXME: This small split goal preferral is quite hacky when using-    -- induction. The problem is that we may end up solving message premise-    -- goals all the time instead performing a necessary split. We should make-    -- sure that a split does not get too old.-    smallSplitGoalSize = 3--    isNonLoopBreakerProtoFactGoal (PremiseG _ fa, (_, Useful)) = not $ isKFact fa-    isNonLoopBreakerProtoFactGoal _                            = False--    msgPremise (ActionG _ fa) = do (UpK, m) <- kFactView fa; return m-    msgPremise _              = Nothing--    isFreshKnowsGoal goal = case msgPremise goal of-        Just (viewTerm -> Lit (Var lv)) | lvarSort lv == LSortFresh -> True-        _                                                           -> False--    isDoubleExpGoal goal = case msgPremise goal of-        Just (viewTerm2 -> FExp  _ (viewTerm2 -> FMult _)) -> True-        _                                                  -> False--    -- Be conservative on splits that don't exist.-    isSplitGoalSmall (SplitG sid) =-        maybe False (<= smallSplitGoalSize) $ splitSize (L.get sEqStore sys) sid-    isSplitGoalSmall _            = False--    isNoLargeSplitGoal goal@(SplitG _) = isSplitGoalSmall goal-    isNoLargeSplitGoal _               = True--    -- | @sortDecisionTree xs ps@ returns a reordering of @xs@-    -- such that the sublist satisfying @ps!!0@ occurs first,-    -- then the sublist satisfying @ps!!1@, and so on.-    sortDecisionTree :: [a -> Bool] -> [a] -> [a]-    sortDecisionTree []     xs = xs-    sortDecisionTree (p:ps) xs = sat ++ sortDecisionTree ps nonsat-      where (sat, nonsat) = partition p xs------------------------------------------------------------------------------------- Pretty printing----------------------------------------------------------------------------------- | Pretty-print a proof method.-prettyProofMethod :: HighlightDocument d => ProofMethod -> d-prettyProofMethod method = case method of-    Solved               -> keyword_ "SOLVED" <-> lineComment_ "trace found"-    Induction            -> keyword_ "induction"-    Sorry reason         ->-        fsep [keyword_ "sorry", maybe emptyDoc lineComment_ reason]-    SolveGoal goal       ->-        keyword_ "solve(" <-> prettyGoal goal <-> keyword_ ")"-    Simplify             -> keyword_ "simplify"-    Contradiction reason ->-        sep [ keyword_ "contradiction"-            , maybe emptyDoc (lineComment . prettyContradiction) reason-            ]------ Derived instances-----------------------$( derive makeBinary ''ProofMethod)-$( derive makeBinary ''GoalRanking)-$( derive makeBinary ''Heuristic)--$( derive makeNFData ''ProofMethod)-$( derive makeNFData ''GoalRanking)-$( derive makeNFData ''Heuristic)
− src/Theory/Constraint/Solver/Reduction.hs 
@@ -1,665 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns  #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ A monad for writing constraint reduction steps together with basic steps--- for inserting nodes, edges, actions, and equations and applying--- substitutions.-module Theory.Constraint.Solver.Reduction (-  -- * The constraint 'Reduction' monad-    Reduction-  , execReduction-  , runReduction--  -- ** Change management-  , ChangeIndicator(..)-  , whenChanged-  , applyChangeList-  , whileChanging--  -- ** Accessing the 'ProofContext'-  , getProofContext-  , getMaudeHandle--  -- ** Inserting nodes, edges, and atoms-  , labelNodeId-  , insertFreshNode-  , insertFreshNodeConc--  , insertGoal-  , insertAtom-  , insertEdges-  , insertChain-  , insertAction-  , insertLess-  , insertFormula-  , reducibleFormula--  -- ** Goal management-  , markGoalAsSolved-  , removeSolvedSplitGoals--  -- ** Substitution application-  , substSystem-  , substNodes-  , substEdges-  , substLastAtom-  , substLessAtoms-  , substFormulas-  , substSolvedFormulas--  -- ** Solving equalities-  , SplitStrategy(..)--  , solveNodeIdEqs-  , solveTermEqs-  , solveFactEqs-  , solveRuleEqs-  , solveSubstEqs--  -- ** Conjunction with another constraint 'System'-  , conjoinSystem--  -- ** Convenience export-  , module Logic.Connectives--  ) where--import           Debug.Trace-import           Prelude                                 hiding (id, (.))--import qualified Data.Foldable                           as F-import qualified Data.Map                                as M-import qualified Data.Set                                as S-import           Data.List                               (mapAccumL)-import           Safe--import           Control.Basics-import           Control.Category-import           Control.Monad.Bind-import           Control.Monad.Disj-import           Control.Monad.Reader-import           Control.Monad.State                     (StateT, execStateT, gets, runStateT)--import           Text.PrettyPrint.Class--import           Extension.Data.Label-import           Extension.Data.Monoid                   (Monoid(..))-import           Extension.Prelude--import           Logic.Connectives--import           Theory.Constraint.Solver.Contradictions-import           Theory.Constraint.Solver.Types-import           Theory.Constraint.System-import           Theory.Model------------------------------------------------------------------------------------ The constraint reduction monad----------------------------------------------------------------------------------- | A constraint reduction step. Its state is the current constraint system,--- it can generate fresh names, split over cases, and access the proof--- context.-type Reduction = StateT System (FreshT (DisjT (Reader ProofContext)))----- Executing reductions---------------------------- | Run a constraint reduction. Returns a list of constraint systems whose--- combined solutions are equal to the solutions of the given system. This--- property is obviously not enforced, but it must be respected by all--- functions of type 'Reduction'.-runReduction :: Reduction a -> ProofContext -> System -> FreshState-             -> Disj ((a, System), FreshState)-runReduction m ctxt se fs =-    Disj $ (`runReader` ctxt) $ runDisjT $ (`runFreshT` fs) $ runStateT m se---- | Run a constraint reduction returning only the updated constraint systems--- and the new freshness states.-execReduction :: Reduction a -> ProofContext -> System -> FreshState-              -> Disj (System, FreshState)-execReduction m ctxt se fs =-    Disj $ (`runReader` ctxt) . runDisjT . (`runFreshT` fs) $ execStateT m se----- Change management------------------------- | Indicate whether the constraint system was changed or not.-data ChangeIndicator = Unchanged | Changed-       deriving( Eq, Ord, Show )--instance Monoid ChangeIndicator where-    mempty = Unchanged--    Changed   `mappend` _         = Changed-    _         `mappend` Changed   = Changed-    Unchanged `mappend` Unchanged = Unchanged---- | Return 'True' iff there was a change.-wasChanged :: ChangeIndicator -> Bool-wasChanged Changed   = True-wasChanged Unchanged = False---- | Only apply a monadic action, if there has been a change.-whenChanged :: Monad m => ChangeIndicator -> m () -> m ()-whenChanged = when . wasChanged---- | Apply a list of changes to the proof state.-applyChangeList :: [Reduction ()] -> Reduction ChangeIndicator-applyChangeList []      = return Unchanged-applyChangeList changes = sequence_ changes >> return Changed---- | Execute a 'Reduction' as long as it results in changes. Indicate whether--- at least one change was performed.-whileChanging :: Reduction ChangeIndicator -> Reduction ChangeIndicator-whileChanging reduction =-    go Unchanged-  where-    go indicator = do indicator' <- reduction-                      case indicator' of-                          Unchanged -> return indicator-                          Changed   -> go     indicator'----- Accessing the proof context----------------------------------- | Retrieve the 'ProofContext'.-getProofContext :: Reduction ProofContext-getProofContext = ask---- | Retrieve the 'MaudeHandle' from the 'ProofContext'.-getMaudeHandle :: Reduction MaudeHandle-getMaudeHandle = askM pcMaudeHandle----- Inserting (fresh) nodes into the constraint system---------------------------------------------------------- | Insert a fresh rule node labelled with a fresh instance of one of the--- rules and return one of the conclusions.-insertFreshNodeConc :: [RuleAC] -> Reduction (RuleACInst, NodeConc, LNFact)-insertFreshNodeConc rules = do-    (i, ru) <- insertFreshNode rules-    (v, fa) <- disjunctionOfList $ enumConcs ru-    return (ru, (i, v), fa)---- | Insert a fresh rule node labelled with a fresh instance of one of the rules--- and solve it's 'Fr', 'In', and 'KU' premises immediatly.-insertFreshNode :: [RuleAC] -> Reduction (NodeId, RuleACInst)-insertFreshNode rules = do-    i <- freshLVar "vr" LSortNode-    (,) i <$> labelNodeId i rules---- | Label a node-id with a fresh instance of one of the rules and--- solve it's 'Fr', 'In', and 'KU' premises immediatly.------ PRE: Node must not yet be labelled with a rule.-labelNodeId :: NodeId -> [RuleAC] -> Reduction RuleACInst-labelNodeId = \i rules -> do-    (ru, mrconstrs) <- importRule =<< disjunctionOfList rules-    solveRuleConstraints mrconstrs-    modM sNodes (M.insert i ru)-    exploitPrems i ru-    return ru-  where-    -- | Import a rule with all its variables renamed to fresh variables.-    importRule ru = someRuleACInst ru `evalBindT` noBindings--    mkISendRuleAC m = return $ Rule (IntrInfo (ISendRule))-                                    [kuFact m] [inFact m] [kLogFact m]---    mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule []))-                           [] [freshFact m] []--    exploitPrems i ru = mapM_ (exploitPrem i ru) (enumPrems ru)--    exploitPrem i ru (v, fa) = case fa of-        -- CR-rule *DG2_2* specialized for *In* facts.-        Fact InFact [m] -> do-            j <- freshLVar "vf" LSortNode-            ruKnows <- mkISendRuleAC m-            modM sNodes (M.insert j ruKnows)-            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v))-            exploitPrems j ruKnows--        -- CR-rule *DG2_2* specialized for *Fr* facts.-        Fact FreshFact [m] -> do-            j <- freshLVar "vf" LSortNode-            modM sNodes (M.insert j (mkFreshRuleAC m))-            unless (isFreshVar m) $ do-                -- 'm' must be of sort fresh ==> enforce via unification-                n <- varTerm <$> freshLVar "n" LSortFresh-                void (solveTermEqs SplitNow [Equal m n])-            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v))--          -- CR-rule *DG2_{2,u}*: solve a KU-premise by inserting the-          -- corresponding KU-actions before this node.-        _ | isKUFact fa -> do-              j <- freshLVar "vk" LSortNode-              insertLess j i-              void (insertAction j fa)--          -- Store premise goal for later processing using CR-rule *DG2_2*-          | otherwise -> insertGoal (PremiseG (i,v) fa) (v `elem` breakers)-      where-        breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru---- | Insert a chain constrain.-insertChain :: NodeConc -> NodePrem -> Reduction ()-insertChain c p = insertGoal (ChainG c p) False---- | Insert an edge constraint. CR-rule *DG1_2* is enforced automatically,--- i.e., the fact equalities are enforced.-insertEdges :: [(NodeConc, LNFact, LNFact, NodePrem)] -> Reduction ()-insertEdges edges = do-    void (solveFactEqs SplitNow [ Equal fa1 fa2 | (_, fa1, fa2, _) <- edges ])-    modM sEdges (\es -> foldr S.insert es [ Edge c p | (c,_,_,p) <- edges])---- | Insert an 'Action' atom. Ensures that (almost all) trivial *KU* actions--- are solved immediately using rule *S_{at,u,triv}*. We currently avoid--- adding intermediate products. Indicates whether nodes other than the given--- action have been added to the constraint system.------ FIXME: Ensure that intermediate products are also solved before stating--- that no rule is applicable.-insertAction :: NodeId -> LNFact -> Reduction ChangeIndicator-insertAction i fa = do-    present <- (goal `M.member`) <$> getM sGoals-    if present-      then do return Unchanged-      else do insertGoal goal False-              case kFactView fa of-                Just (UpK, viewTerm2 -> FPair m1 m2) ->-                    requiresKU m1 *> requiresKU m2 *> return Changed--                Just (UpK, viewTerm2 -> FInv m) ->-                    requiresKU m *> return Changed--                Just (UpK, viewTerm2 -> FMult ms) ->-                    mapM_ requiresKU ms *> return Changed--                _ -> return Unchanged-  where-    goal = ActionG i fa-    -- Here we rely on the fact that the action is new. Otherwise, we might-    -- loop due to generating new KU-nodes that are merged immediately.-    requiresKU t = do-      j <- freshLVar "vk" LSortNode-      let faKU = kuFact t-      insertLess j i-      void (insertAction j faKU)---- | Insert a 'Less' atom. @insertLess i j@ means that *i < j* is added.-insertLess :: NodeId -> NodeId -> Reduction ()-insertLess i j = modM sLessAtoms (S.insert (i, j))---- | Insert a 'Last' atom and ensure their uniqueness.-insertLast :: NodeId -> Reduction ChangeIndicator-insertLast i = do-    lst <- getM sLastAtom-    case lst of-      Nothing -> setM sLastAtom (Just i) >> return Unchanged-      Just j  -> solveNodeIdEqs [Equal i j]---- | Insert an atom. Returns 'Changed' if another part of the constraint--- system than the set of actions was changed.-insertAtom :: LNAtom -> Reduction ChangeIndicator-insertAtom ato = case ato of-    EqE x y       -> solveTermEqs SplitNow [Equal x y]-    Action i fa   -> insertAction (ltermNodeId' i) fa-    Less i j      -> do insertLess (ltermNodeId' i) (ltermNodeId' j)-                        return Unchanged-    Last i        -> insertLast (ltermNodeId' i)---- | Insert a 'Guarded' formula. Ensures that existentials, conjunctions, negated--- last atoms, and negated less atoms, are immediately solved using the rules--- *S_exists*, *S_and*, *S_not,last*, and *S_not,less*. Only the inserted--- formula is marked as solved. Other intermediate formulas are not marked.-insertFormula :: LNGuarded -> Reduction ()-insertFormula = do-    insert True-  where-    insert mark fm = do-        formulas       <- getM sFormulas-        solvedFormulas <- getM sSolvedFormulas-        insert' mark formulas solvedFormulas fm--    insert' mark formulas solvedFormulas fm-      | fm `S.member` formulas       = return ()-      | fm `S.member` solvedFormulas = return ()-      | otherwise = case fm of-          GAto ato -> do-              markAsSolved-              void (insertAtom (bvarToLVar ato))--          -- CR-rule *S_∧*-          GConj fms -> do-              markAsSolved-              mapM_ (insert False) (getConj fms)--          -- Store for later applications of CR-rule *S_∨*-          GDisj disj -> do-              modM sFormulas (S.insert fm)-              insertGoal (DisjG disj) False--          -- CR-rule *S_∃*-          GGuarded Ex ss as gf -> do-              -- must always mark as solved, as we otherwise may repeatedly-              -- introduce fresh variables.-              modM sSolvedFormulas $ S.insert fm-              xs <- mapM (uncurry freshLVar) ss-              let body = gconj (map GAto as ++ [gf])-              insert False (substBound (zip [0..] (reverse xs)) body)--          -- CR-rule *S_{¬,⋖}*-          GGuarded All [] [Less i j] gf  | gf == gfalse -> do-              markAsSolved-              insert False (gdisj [GAto (EqE i j), GAto (Less j i)])--          -- CR-rule: FIXME add this rule to paper-          GGuarded All [] [EqE i@(bltermNodeId -> Just _)-                               j@(bltermNodeId -> Just _) ] gf-            | gf == gfalse -> do-                markAsSolved-                insert False (gdisj [GAto (Less i j), GAto (Less j i)])--          -- CR-rule *S_{¬,last}*-          GGuarded All [] [Last i]   gf  | gf == gfalse -> do-              markAsSolved-              lst <- getM sLastAtom-              j <- case lst of-                     Nothing  -> do j <- freshLVar "last" LSortNode-                                    void (insertLast j)-                                    return (varTerm (Free j))-                     Just j -> return (varTerm (Free j))-              insert False $ gdisj [ GAto (Less j i), GAto (Less i j) ]--          -- Guarded All quantification: store for saturation-          GGuarded All _ _ _ -> modM sFormulas (S.insert fm)-      where-        markAsSolved = when mark $ modM sSolvedFormulas $ S.insert fm---- | 'True' iff the formula can be reduced by one of the rules implemented in--- 'insertFormula'.-reducibleFormula :: LNGuarded -> Bool-reducibleFormula fm = case fm of-    GAto _                        -> True-    GConj _                       -> True-    GGuarded Ex _ _ _             -> True-    GGuarded All [] [Less _ _] gf -> gf == gfalse-    GGuarded All [] [Last _]   gf -> gf == gfalse-    _                             -> False----- Goal management----------------------- | Combine the status of two goals.-combineGoalStatus :: GoalStatus -> GoalStatus -> GoalStatus-combineGoalStatus (GoalStatus solved1 age1 loops1)-                  (GoalStatus solved2 age2 loops2) =-    GoalStatus (solved1 || solved2) (min age1 age2) (loops1 || loops2)---- | Insert a goal and its status with a new age. Merge status if goal exists.-insertGoalStatus :: Goal -> GoalStatus -> Reduction ()-insertGoalStatus goal status = do-    age <- getM sNextGoalNr-    modM sGoals $ M.insertWith' combineGoalStatus goal (set gsNr age status)-    sNextGoalNr =: succ age---- | Insert a 'Goal' and store its age.-insertGoal :: Goal -> Bool -> Reduction ()-insertGoal goal looping = insertGoalStatus goal (GoalStatus False 0 looping)---- | Mark the given goal as solved.-markGoalAsSolved :: String -> Goal -> Reduction ()-markGoalAsSolved how goal =-    case goal of-      ActionG _ _     -> updateStatus-      PremiseG _ fa-        | isKDFact fa -> modM sGoals $ M.delete goal-        | otherwise   -> updateStatus-      ChainG _ _      -> modM sGoals $ M.delete goal-      SplitG _        -> updateStatus-      DisjG disj      -> modM sFormulas       (S.delete $ GDisj disj) >>-                         modM sSolvedFormulas (S.insert $ GDisj disj) >>-                         updateStatus-  where-    updateStatus = do-        mayStatus <- M.lookup goal <$> getM sGoals-        case mayStatus of-          Just status -> trace (msg status) $-              modM sGoals $ M.insert goal $ set gsSolved True status-          Nothing     -> trace ("markGoalAsSolved: inexistent goal " ++ show goal) $ return ()--    msg status = render $ nest 2 $ fsep $-        [ text ("solved goal nr. "++ show (get gsNr status))-          <-> parens (text how) <> colon-        , nest 2 (prettyGoal goal) ]--removeSolvedSplitGoals :: Reduction ()-removeSolvedSplitGoals = do-    goals    <- getM sGoals-    existent <- splitExists <$> getM sEqStore-    sequence_ [ modM sGoals $ M.delete goal-              | goal@(SplitG i) <- M.keys goals, not (existent i) ]----- Substitution-------------------- | Apply the current substitution of the equation store to the remainder of--- the sequent.-substSystem :: Reduction ChangeIndicator-substSystem = do-    c1 <- substNodes-    substEdges-    substLastAtom-    substLessAtoms-    substFormulas-    substSolvedFormulas-    substLemmas-    c2 <- substGoals-    substNextGoalNr-    return (c1 <> c2)---- no invariants to maintain here-substEdges, substLessAtoms, substLastAtom, substFormulas,-  substSolvedFormulas, substLemmas, substNextGoalNr :: Reduction ()--substEdges          = substPart sEdges-substLessAtoms      = substPart sLessAtoms-substLastAtom       = substPart sLastAtom-substFormulas       = substPart sFormulas-substSolvedFormulas = substPart sSolvedFormulas-substLemmas         = substPart sLemmas-substNextGoalNr     = return ()----- | Apply the current substitution of the equation store to a part of the--- sequent. This is an internal function.-substPart :: Apply a => (System :-> a) -> Reduction ()-substPart l = do subst <- getM sSubst-                 modM l (apply subst)---- | Apply the current substitution of the equation store the nodes of the--- constraint system. Indicates whether additional equalities were added to--- the equations store.-substNodes :: Reduction ChangeIndicator-substNodes =-    substNodeIds <* ((modM sNodes . M.map . apply) =<< getM sSubst)---- | @setNodes nodes@ normalizes the @nodes@ such that node ids are unique and--- then updates the @sNodes@ field of the proof state to the corresponding map.--- Return @True@ iff new equalities have been added to the equation store.-setNodes :: [(NodeId, RuleACInst)] -> Reduction ChangeIndicator-setNodes nodes0 = do-    sNodes =: M.fromList nodes-    if null ruleEqs then                                    return Unchanged-                    else solveRuleEqs SplitLater ruleEqs >> return Changed-  where-    -- merge nodes with equal node id-    (ruleEqs, nodes) = first concat $ unzip $ map merge $ groupSortOn fst nodes0--    merge []            = unreachable "setNodes"-    merge (keep:remove) = (map (Equal (snd keep) . snd) remove, keep)---- | Apply the current substitution of the equation store to the node ids and--- ensure uniqueness of the labels, as required by rule *U_lbl*. Indicates--- whether there where new equalities added to the equations store.-substNodeIds :: Reduction ChangeIndicator-substNodeIds =-    whileChanging $ do-        subst <- getM sSubst-        nodes <- gets (map (first (apply subst)) . M.toList . get sNodes)-        setNodes nodes---- | Substitute all goals. Keep the ones with the lower nr.-substGoals :: Reduction ChangeIndicator-substGoals = do-    subst <- getM sSubst-    goals <- M.toList <$> getM sGoals-    sGoals =: M.empty-    changes <- forM goals $ \(goal, status) -> case goal of-        -- Look out for KU-actions that might need to be solved again.-        ActionG i fa@(kFactView -> Just (UpK, m))-          | (isMsgVar m || isProduct m) && (apply subst m /= m) ->-              insertAction i (apply subst fa)-        _ -> do modM sGoals $-                  M.insertWith' combineGoalStatus (apply subst goal) status-                return Unchanged--    return (mconcat changes)----- Conjoining two constraint systems----------------------------------------- | @conjoinSystem se@ conjoins the logical information in @se@ to the--- constraint system. It assumes that the free variables in @se@ are shared--- with the free variables in the proof state.-conjoinSystem :: System -> Reduction ()-conjoinSystem sys = do-    kind <- getM sCaseDistKind-    unless (kind == get sCaseDistKind sys) $-        error "conjoinSystem: typing-kind mismatch"-    joinSets sSolvedFormulas-    joinSets sLemmas-    joinSets sEdges-    F.mapM_ insertLast                 $ get sLastAtom    sys-    F.mapM_ (uncurry insertLess)       $ get sLessAtoms   sys-    -- split-goals are not valid anymore-    mapM_   (uncurry insertGoalStatus) $ filter (not . isSplitGoal . fst) $ M.toList $ get sGoals sys-    F.mapM_ insertFormula $ get sFormulas sys-    -- update nodes-    _ <- (setNodes . (M.toList (get sNodes sys) ++) . M.toList) =<< getM sNodes-    -- conjoin equation store-    eqs <- getM sEqStore-    let (eqs',splitIds) = (mapAccumL addDisj eqs (map snd . getConj $ get sConjDisjEqs sys))-    setM sEqStore eqs'-    -- add split-goals for all disjunctions of sys-    mapM_  (`insertGoal` False) $ SplitG <$> splitIds-    void (solveSubstEqs SplitNow $ get sSubst sys)-    -- Propagate substitution changes. Ignore change indicator, as it is-    -- assumed to be 'Changed' by default.-    void substSystem-  where-    joinSets :: Ord a => (System :-> S.Set a) -> Reduction ()-    joinSets proj = modM proj (`S.union` get proj sys)---- Unification via the equation store------------------------------------------ | 'SplitStrategy' denotes if the equation store should be split into--- multiple equation stores.-data SplitStrategy = SplitNow | SplitLater---- The 'ChangeIndicator' indicates whether at least one non-trivial equality--- was solved.---- | @noContradictoryEqStore@ suceeds iff the equation store is not--- contradictory.-noContradictoryEqStore :: Reduction ()-noContradictoryEqStore = (contradictoryIf . eqsIsFalse) =<< getM sEqStore---- | Add a list of term equalities to the equation store. And---  split resulting disjunction of equations according---  to given split strategy.------ Note that updating the remaining parts of the constraint system with the--- substitution has to be performed using a separate call to 'substSystem'.-solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> Reduction ChangeIndicator-solveTermEqs splitStrat eqs0 =-    case filter (not . evalEqual) eqs0 of-      []  -> do return Unchanged-      eqs1 -> do-        hnd <- getMaudeHandle-        se  <- gets id-        (eqs2, maySplitId) <- addEqs hnd eqs1 =<< getM sEqStore-        setM sEqStore-            =<< simp hnd (substCreatesNonNormalTerms hnd se)-            =<< case (maySplitId, splitStrat) of-                  (Just splitId, SplitNow) -> disjunctionOfList-                                                $ fromJustNote "solveTermEqs"-                                                $ performSplit eqs2 splitId-                  (Just splitId, SplitLater) -> do-                      insertGoal (SplitG splitId) False-                      return eqs2-                  _                        -> return eqs2-        noContradictoryEqStore-        return Changed---- | Add a list of equalities in substitution form to the equation store-solveSubstEqs :: SplitStrategy -> LNSubst -> Reduction ChangeIndicator-solveSubstEqs split subst =-    solveTermEqs split [Equal (varTerm v) t | (v, t) <- substToList subst]---- | Add a list of node equalities to the equation store.-solveNodeIdEqs :: [Equal NodeId] -> Reduction ChangeIndicator-solveNodeIdEqs = solveTermEqs SplitNow . map (fmap varTerm)---- | Add a list of fact equalities to the equation store, if possible.-solveFactEqs :: SplitStrategy -> [Equal LNFact] -> Reduction ChangeIndicator-solveFactEqs split eqs = do-    contradictoryIf (not $ all evalEqual $ map (fmap factTag) eqs)-    solveListEqs (solveTermEqs split) $ map (fmap factTerms) eqs---- | Add a list of rule equalities to the equation store, if possible.-solveRuleEqs :: SplitStrategy -> [Equal RuleACInst] -> Reduction ChangeIndicator-solveRuleEqs split eqs = do-    contradictoryIf (not $ all evalEqual $ map (fmap (get rInfo)) eqs)-    solveListEqs (solveFactEqs split) $-        map (fmap (get rConcs)) eqs ++ map (fmap (get rPrems)) eqs-        ++ map (fmap (get rActs)) eqs---- | Solve a number of equalities between lists interpreted as free terms--- using the given solver for solving the entailed per-element equalities.-solveListEqs :: ([Equal a] -> Reduction b) -> [(Equal [a])] -> Reduction b-solveListEqs solver eqs = do-    contradictoryIf (not $ all evalEqual $ map (fmap length) eqs)-    solver $ concatMap flatten eqs-  where-    flatten (Equal l r) = zipWith Equal l r---- | Solve the constraints associated with a rule.-solveRuleConstraints :: Maybe RuleACConstrs -> Reduction ()-solveRuleConstraints (Just eqConstr) = do-    hnd <- getMaudeHandle-    (eqs, splitId) <- addRuleVariants eqConstr <$> getM sEqStore-    insertGoal (SplitG splitId) False-    -- do not use expensive substCreatesNonNormalTerms here-    setM sEqStore =<< simp hnd (const False) eqs-    noContradictoryEqStore-solveRuleConstraints Nothing = return ()-
− src/Theory/Constraint/Solver/Simplify.hs 
@@ -1,456 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ViewPatterns       #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ This module implements all rules that do not result in case distinctions--- and equation solving. Some additional cases may although result from--- splitting over multiple AC-unifiers. Note that a few of these rules are--- implemented directly in the methods for inserting constraints to the--- constraint system.  These methods are provided by--- "Theory.Constraint.Solver.Reduction".----module Theory.Constraint.Solver.Simplify (--  simplifySystem--  ) where--import           Debug.Trace--import           Prelude                            hiding (id, (.))--import qualified Data.DAG.Simple                    as D-import           Data.Data-import           Data.Either                        (partitionEithers)-import qualified Data.Foldable                      as F-import           Data.List-import qualified Data.Map                           as M-import           Data.Monoid                        (Monoid(..))-import qualified Data.Set                           as S--import           Control.Basics-import           Control.Category-import           Control.Monad.Disj-import           Control.Monad.Fresh-import           Control.Monad.Reader-import           Control.Monad.State                (gets)---import           Extension.Data.Label-import           Extension.Prelude--import           Theory.Constraint.Solver.Goals-import           Theory.Constraint.Solver.Reduction-import           Theory.Constraint.Solver.Types-import           Theory.Constraint.System-import           Theory.Model-import           Theory.Text.Pretty----- | Apply CR-rules that don't result in case splitting until the constraint--- system does not change anymore.-simplifySystem :: Reduction ()-simplifySystem = do-    -- Start simplification, indicating that some change happened-    go (0 :: Int) [Changed]-    -- Add all ordering constraint implied by CR-rule *N6*.-    exploitUniqueMsgOrder-    -- Remove equation split goals that do not exist anymore-    removeSolvedSplitGoals-  where-    go n changes0-      -- We stop as soon as all simplification steps have been run without-      -- reporting any change to the constraint systemm.-      | Unchanged == mconcat changes0 = return ()-      | otherwise                     = do-          -- Store original system for reporting-          se0 <- gets id-          -- Perform one initial substitution. We do not have to consider its-          -- changes as 'substSystem' is idempotent.-          void substSystem-          -- Perform one simplification pass.-          (c1,c2,c3) <- enforceNodeUniqueness-          c4 <- enforceEdgeUniqueness-          c5 <- solveUniqueActions-          c6 <- reduceFormulas-          c7 <- evalFormulaAtoms-          c8 <- insertImpliedFormulas--          -- Report on looping behaviour if necessary-          let changes = filter ((Changed ==) . snd) $-                [ ("unique fresh instances (DG4)",        c1)-                , ("unique K↓-facts (N5↓)",               c2)-                , ("unique K↑-facts (N5↑)",               c3)-                , ("unique (linear) edges (DG2 and DG3)", c4)-                , ("solve unambiguous actions (S_@)",     c5)-                , ("decompose trace formula",             c6)-                , ("propagate atom valuation to formula", c7)-                , ("saturate under ∀-clauses (S_∀)",      c8)-                ]-              traceIfLooping-                | n <= 10   = id-                | otherwise = trace $ render $ vsep-                    [ text "Simplifier iteration" <-> int n <> colon-                    , fsep $ text "The reduction-rules for" :-                             (punctuate comma $ map (text . fst) changes) ++-                             [text "were applied to the following constraint system."]-                    , nest 2 (prettySystem se0)-                    ]--          traceIfLooping $ go (n + 1) (map snd changes)----- | CR-rule *N6*: add ordering constraints between all KU-actions and--- KD-conclusions.-exploitUniqueMsgOrder :: Reduction ()-exploitUniqueMsgOrder = do-    kdConcs   <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKDConcs)-    kuActions <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKUActions)-    -- We can add all elements where we have an intersection-    F.mapM_ (uncurry insertLess) $ M.intersectionWith (,) kdConcs kuActions---- | CR-rules *DG4*, *N5_u*, and *N5_d*: enforcing uniqueness of *Fresh* rule--- instances, *KU*-actions, and *KD*-conclusions.------ Returns 'Changed' if a change was done.-enforceNodeUniqueness :: Reduction (ChangeIndicator, ChangeIndicator, ChangeIndicator)-enforceNodeUniqueness =-    (,,)-      <$> (merge (const $ return Unchanged) freshRuleInsts)-      <*> (merge (solveRuleEqs SplitNow)    kdConcs)-      <*> (merge (solveFactEqs SplitNow)    kuActions)-  where-    -- *DG4*-    freshRuleInsts se = do-        (i, ru) <- M.toList $ get sNodes se-        guard (isFreshRule ru)-        return (ru, ((), i))  -- no need to merge equal rules--    -- *N5_d*-    kdConcs sys = (\(i, ru, m) -> (m, (ru, i))) <$> allKDConcs sys--    -- *N5_u*-    kuActions se = (\(i, fa, m) -> (m, (fa, i))) <$> allKUActions se--    merge :: Ord b-          => ([Equal a] -> Reduction ChangeIndicator)-             -- ^ Equation solver for 'Equal a'-          -> (System -> [(b,(a,NodeId))])-             -- ^ Candidate selector-          -> Reduction ChangeIndicator                  ---    merge solver candidates = do-        changes <- gets (map mergers . groupSortOn fst . candidates)-        mconcat <$> sequence changes-      where-        mergers []                          = unreachable "enforceUniqueness"-        mergers ((_,(xKeep, iKeep)):remove) =-            mappend <$> solver         (map (Equal xKeep . fst . snd) remove)-                    <*> solveNodeIdEqs (map (Equal iKeep . snd . snd) remove)----- | CR-rules *DG2_1* and *DG3*: merge multiple incoming edges to all facts--- and multiple outgoing edges from linear facts.-enforceEdgeUniqueness :: Reduction ChangeIndicator-enforceEdgeUniqueness = do-    se <- gets id-    let edges = S.toList (get sEdges se)-    (<>) <$> mergeNodes eSrc eTgt edges-         <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges)-  where-    -- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th-    -- conclusion of node @v@ is a linear fact.-    proveLinearConc se (v, i) =-        maybe False (isLinearFact . (get (rConc i))) $-            M.lookup v $ get sNodes se--    -- merge the nodes on the 'mergeEnd' for edges that are equal on the-    -- 'compareEnd'-    mergeNodes mergeEnd compareEnd edges-      | null eqs  = return Unchanged-      | otherwise = do-            -- all indices of merged premises and conclusions must be equal-            contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs])-            -- nodes must be equal-            solveNodeIdEqs $ map (fmap fst) eqs-      where-        eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges--        merge _    []            = error "exploitEdgeProps: impossible"-        merge proj (keep:remove) = map (Equal (proj keep) . proj) remove---- | Special version of CR-rule *S_at*, which is only applied to solve actions--- that are guaranteed not to result in case splits.-solveUniqueActions :: Reduction ChangeIndicator-solveUniqueActions = do-    rules       <- nonSilentRules <$> askM pcRules-    actionAtoms <- gets unsolvedActionAtoms--    -- FIXME: We might cache the result of this static computation in the-    -- proof-context, e.g., in the 'ClassifiedRules'.-    let uniqueActions = [ x | [x] <- group (sort ruleActions) ]-        ruleActions   = [ (tag, length ts)-                        | ru <- rules, Fact tag ts <- get rActs ru ]--        isUnique (Fact tag ts) = (tag, length ts) `elem` uniqueActions--        trySolve (i, fa)-          | isUnique fa = solveGoal (ActionG i fa) >> return Changed-          | otherwise   = return Unchanged--    mconcat <$> mapM trySolve actionAtoms---- | Reduce all formulas as far as possible. See 'insertFormula' for the--- CR-rules exploited in this step. Note that this step is normally only--- required to decompose the formula in the initial constraint system.-reduceFormulas :: Reduction ChangeIndicator-reduceFormulas = do-    formulas <- getM sFormulas-    applyChangeList $ do-        fm <- S.toList formulas-        guard (reducibleFormula fm)-        return $ do modM sFormulas $ S.delete fm-                    insertFormula fm---- | Try to simplify the atoms contained in the formulas. See--- 'partialAtomValuation' for an explanation of what CR-rules are exploited--- here.-evalFormulaAtoms :: Reduction ChangeIndicator-evalFormulaAtoms = do-    ctxt      <- ask-    valuation <- gets (partialAtomValuation ctxt)-    formulas  <- getM sFormulas-    applyChangeList $ do-        fm <- S.toList formulas-        case simplifyGuarded valuation fm of-          Just fm' -> return $ do-              case fm of-                GDisj disj -> markGoalAsSolved "simplified" (DisjG disj)-                _          -> return ()-              modM sFormulas       $ S.delete fm-              modM sSolvedFormulas $ S.insert fm-              insertFormula fm'-          Nothing  -> []---- | A partial valuation for atoms. The return value of this function is--- interpreted as follows.------ @partialAtomValuation ctxt sys ato == Just True@ if for every valuation--- @theta@ satisfying the graph constraints and all atoms in the constraint--- system @sys@, the atom @ato@ is also satisfied by @theta@.------ The interpretation for @Just False@ is analogous. @Nothing@ is used to--- represent *unknown*.----partialAtomValuation :: ProofContext -> System -> LNAtom -> Maybe Bool-partialAtomValuation ctxt sys =-    eval-  where-    runMaude   = (`runReader` get pcMaudeHandle ctxt)-    before     = alwaysBefore sys-    lessRel    = rawLessRel sys-    nodesAfter = \i -> filter (i /=) $ S.toList $ D.reachableSet [i] lessRel--    -- | 'True' iff there in every solution to the system the two node-ids are-    -- instantiated to a different index *in* the trace.-    nonUnifiableNodes :: NodeId -> NodeId -> Bool-    nonUnifiableNodes i j = maybe False (not . runMaude) $-        (unifiableRuleACInsts) <$> M.lookup i (get sNodes sys)-                               <*> M.lookup j (get sNodes sys)--    -- | Try to evaluate the truth value of this atom in all models of the-    -- constraint system 'sys'.-    eval ato = case ato of-          Action (ltermNodeId' -> i) fa-            | ActionG i fa `M.member` get sGoals sys -> Just True-            | otherwise ->-                case M.lookup i (get sNodes sys) of-                  Just ru-                    | any (fa ==) (get rActs ru)                                -> Just True-                    | all (not . runMaude . unifiableLNFacts fa) (get rActs ru) -> Just False-                  _                                                             -> Nothing--          Less (ltermNodeId' -> i) (ltermNodeId' -> j)-            | i == j || j `before` i             -> Just False-            | i `before` j                       -> Just True-            | isLast sys i && isInTrace sys j    -> Just False-            | isLast sys j && isInTrace sys i &&-              nonUnifiableNodes i j              -> Just True-            | otherwise                          -> Nothing--          EqE x y-            | x == y                                -> Just True-            | not (runMaude (unifiableLNTerms x y)) -> Just False-            | otherwise                             ->-                case (,) <$> ltermNodeId x <*> ltermNodeId y of-                  Just (i, j)-                    | i `before` j || j `before` i  -> Just False-                    | nonUnifiableNodes i j         -> Just False-                  _                                 -> Nothing--          Last (ltermNodeId' -> i)-            | isLast sys i                       -> Just True-            | any (isInTrace sys) (nodesAfter i) -> Just False-            | otherwise ->-                case get sLastAtom sys of-                  Just j | nonUnifiableNodes i j -> Just False-                  _                              -> Nothing------ | CR-rule *S_∀*: insert all newly implied formulas.-insertImpliedFormulas :: Reduction ChangeIndicator-insertImpliedFormulas = do-    sys <- gets id-    hnd <- getMaudeHandle-    applyChangeList $ do-        clause  <- (S.toList $ get sFormulas sys) ++-                   (S.toList $ get sLemmas sys)-        implied <- impliedFormulas hnd sys clause-        if ( implied `S.notMember` get sFormulas sys &&-             implied `S.notMember` get sSolvedFormulas sys )-          then return (insertFormula implied)-          else []---- | @impliedFormulas se imp@ returns the list of guarded formulas that are--- implied by @se@.-impliedFormulas :: MaudeHandle -> System -> LNGuarded -> [LNGuarded]-impliedFormulas hnd sys gf0 =-    case openGuarded gf `evalFresh` avoid gf of-      Just (All, _vs, antecedent, succedent) -> do-        let (actions, otherAtoms) = partitionEithers $ map prepare antecedent-            succedent'             = gall [] otherAtoms succedent-        subst <- candidateSubsts emptySubst actions-        return $ unskolemizeLNGuarded $ applySkGuarded subst succedent'-      _ -> []-  where-    gf = skolemizeGuarded gf0--    prepare (Action i fa) = Left (i, fa)-    prepare ato           = Right (fmap (fmapTerm (fmap Free)) ato)--    sysActions = do (i, fa) <- allActions sys-                    return (skolemizeTerm (varTerm i), skolemizeFact fa)--    candidateSubsts subst []     = do-        return subst-    candidateSubsts subst (a:as) = do-        sysAct <- sysActions-        subst' <- (`runReader` hnd) $ matchAction sysAct (applySkAction subst a)-        candidateSubsts (compose subst' subst) as------------------------------------------------------------------------------------ Terms, facts, and formulas with skolem constants----------------------------------------------------------------------------------- | A constant type that supports names and skolem constants. We use the--- skolem constants to represent fixed free variables from the constraint--- system during matching the atoms of a guarded clause to the atoms of the--- constraint system.-data SkConst = SkName  Name-             | SkConst LVar-             deriving( Eq, Ord, Show, Data, Typeable )--type SkTerm    = VTerm SkConst LVar-type SkFact    = Fact SkTerm-type SkSubst   = Subst SkConst LVar-type SkGuarded = LGuarded SkConst---- | A term with skolem constants and bound variables-type BSkTerm   = VTerm SkConst BLVar---- | An term with skolem constants and bound variables-type BSkAtom   = Atom BSkTerm--instance IsConst SkConst----- Skolemization of terms without bound variables.-----------------------------------------------------skolemizeTerm :: LNTerm -> SkTerm-skolemizeTerm = fmapTerm conv- where-  conv :: Lit Name LVar -> Lit SkConst LVar-  conv (Var v) = Con (SkConst v)-  conv (Con n) = Con (SkName n)--skolemizeFact :: LNFact -> Fact SkTerm-skolemizeFact = fmap skolemizeTerm--skolemizeAtom :: BLAtom -> BSkAtom-skolemizeAtom = fmap skolemizeBTerm--skolemizeGuarded :: LNGuarded -> SkGuarded-skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom)--applySkTerm :: SkSubst -> SkTerm -> SkTerm-applySkTerm subst t = applyVTerm subst t--applySkFact :: SkSubst -> SkFact -> SkFact-applySkFact subst = fmap (applySkTerm subst)--applySkAction :: SkSubst -> (SkTerm,SkFact) -> (SkTerm,SkFact)-applySkAction subst (t,f) = (applySkTerm subst t, applySkFact subst f)----- Skolemization of terms with bound variables.--------------------------------------------------skolemizeBTerm :: VTerm Name BLVar -> BSkTerm-skolemizeBTerm = fmapTerm conv- where-  conv :: Lit Name BLVar -> Lit SkConst BLVar-  conv (Var (Free x))  = Con (SkConst x)-  conv (Var (Bound b)) = Var (Bound b)-  conv (Con n)         = Con (SkName n)--unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar-unskolemizeBTerm t = fmapTerm conv t- where-  conv :: Lit SkConst BLVar -> Lit Name BLVar-  conv (Con (SkConst x)) = Var (Free x)-  conv (Var (Bound b))   = Var (Bound b)-  conv (Var (Free v))    = error $ "unskolemizeBTerm: free variable " ++-                                   show v++" found in "++show t-  conv (Con (SkName n))  = Con n--unskolemizeBLAtom :: BSkAtom -> BLAtom-unskolemizeBLAtom = fmap unskolemizeBTerm--unskolemizeLNGuarded :: SkGuarded -> LNGuarded-unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom)--applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar-applyBSkTerm subst =-    go-  where-    go t = case viewTerm t of-      Lit l     -> applyBLLit l-      FApp o as -> fApp o (map go as)--    applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar-    applyBLLit l@(Var (Free v)) =-        maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)-    applyBLLit l                = lit l--applyBSkAtom :: SkSubst -> Atom (VTerm SkConst BLVar) -> Atom (VTerm SkConst BLVar)-applyBSkAtom subst = fmap (applyBSkTerm subst)--applySkGuarded :: SkSubst -> LGuarded SkConst -> LGuarded SkConst-applySkGuarded subst = mapGuardedAtoms (const $ applyBSkAtom subst)---- Matching--------------matchAction :: (SkTerm, SkFact) ->  (SkTerm, SkFact) -> WithMaude [SkSubst]-matchAction (i1, fa1) (i2, fa2) =-    solveMatchLTerm sortOfSkol (i1 `matchWith` i2 <> fa1 `matchFact` fa2)-  where-    sortOfSkol (SkName  n) = sortOfName n-    sortOfSkol (SkConst v) = lvarSort v
− src/Theory/Constraint/Solver/Types.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE TypeOperators      #-}-{-# LANGUAGE ViewPatterns       #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Common types for our constraint solver. They must be declared jointly--- because there is a recursive dependency between goals, proof contexts, and--- case distinctions.-module Theory.Constraint.Solver.Types (--  -- * Proof context-    ProofContext(..)-  , InductionHint(..)--  , pcSignature-  , pcRules-  , pcInjectiveFactInsts-  , pcCaseDists-  , pcCaseDistKind-  , pcUseInduction-  , pcTraceQuantifier-  , pcMaudeHandle--  -- ** Classified rules-  , ClassifiedRules(..)-  , emptyClassifiedRules-  , crConstruct-  , crDestruct-  , crProtocol-  , joinAllRules-  , nonSilentRules--  -- * Precomputed case distinctions.-  , CaseDistinction(..)--  , cdGoal-  , cdCases--  ) where--import           Prelude                  hiding (id, (.))--import           Data.Binary-import           Data.DeriveTH-import           Data.Label               hiding (get)-import qualified Data.Label               as L-import           Data.Monoid              (Monoid(..))-import qualified Data.Set                 as S--import           Control.Basics-import           Control.Category-import           Control.DeepSeq--import           Logic.Connectives-import           Theory.Constraint.System-import           Theory.Model---------------------------------------------------------------------------- ClassifiedRules-------------------------------------------------------------------------data ClassifiedRules = ClassifiedRules-     { _crProtocol      :: [RuleAC] -- all protocol rules-     , _crDestruct      :: [RuleAC] -- destruction rules-     , _crConstruct     :: [RuleAC] -- construction rules-     }-     deriving( Eq, Ord, Show )--$(mkLabels [''ClassifiedRules])---- | The empty proof rule set.-emptyClassifiedRules :: ClassifiedRules-emptyClassifiedRules = ClassifiedRules [] [] []---- | @joinAllRules rules@ computes the union of all rules classified in--- @rules@.-joinAllRules :: ClassifiedRules -> [RuleAC]-joinAllRules (ClassifiedRules a b c) = a ++ b ++ c---- | Extract all non-silent rules.-nonSilentRules :: ClassifiedRules -> [RuleAC]-nonSilentRules = filter (not . null . L.get rActs) . joinAllRules------------------------------------------------------------------------------------ Proof Context----------------------------------------------------------------------------------- | A big-step case distinction.-data CaseDistinction = CaseDistinction-     { _cdGoal     :: Goal   -- start goal of case distinction-       -- disjunction of named sequents with premise being solved; each name-       -- being the path of proof steps required to arrive at these cases-     , _cdCases    :: Disj ([String], System)-     }-     deriving( Eq, Ord, Show )--data InductionHint = UseInduction | AvoidInduction-       deriving( Eq, Ord, Show )---- | A proof context contains the globally fresh facts, classified rewrite--- rules and the corresponding precomputed premise case distinction theorems.-data ProofContext = ProofContext-       { _pcSignature          :: SignatureWithMaude-       , _pcRules              :: ClassifiedRules-       , _pcInjectiveFactInsts :: S.Set FactTag-       , _pcCaseDistKind       :: CaseDistKind-       , _pcCaseDists          :: [CaseDistinction]-       , _pcUseInduction       :: InductionHint-       , _pcTraceQuantifier    :: SystemTraceQuantifier-       }-       deriving( Eq, Ord, Show )--$(mkLabels [''ProofContext, ''CaseDistinction])----- | The 'MaudeHandle' of a proof-context.-pcMaudeHandle :: ProofContext :-> MaudeHandle-pcMaudeHandle = sigmMaudeHandle . pcSignature---- Instances---------------instance HasFrees CaseDistinction where-    foldFrees f th =-        foldFrees f (L.get cdGoal th)   `mappend`-        foldFrees f (L.get cdCases th)--    mapFrees f th = CaseDistinction <$> mapFrees f (L.get cdGoal th)-                                    <*> mapFrees f (L.get cdCases th)----- NFData------------$( derive makeBinary ''CaseDistinction)-$( derive makeBinary ''ClassifiedRules)-$( derive makeBinary ''InductionHint)--$( derive makeNFData ''CaseDistinction)-$( derive makeNFData ''ClassifiedRules)-$( derive makeNFData ''InductionHint)
− src/Theory/Constraint/System.hs 
@@ -1,482 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE TypeOperators      #-}-{-# LANGUAGE ViewPatterns       #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ This is the public interface for constructing and deconstructing constraint--- systems. The interface for performing constraint solving provided by--- "Theory.Constraint.Solver".-module Theory.Constraint.System (-  -- * Constraints-    module Theory.Constraint.System.Constraints--  -- * Constraint systems-  , System--  -- ** Construction-  , emptySystem--  , SystemTraceQuantifier(..)-  , formulaToSystem--  -- ** Node constraints-  , sNodes-  , allKDConcs--  , nodeRule-  , nodeConcNode-  , nodePremNode-  , nodePremFact-  , nodeConcFact-  , resolveNodePremFact-  , resolveNodeConcFact--  -- ** Actions-  , allActions-  , allKUActions-  , unsolvedActionAtoms-  -- FIXME: The two functions below should also be prefixed with 'unsolved'-  , kuActionAtoms-  , standardActionAtoms--  -- ** Edge and chain constraints-  , sEdges-  , unsolvedChains--  -- ** Temporal ordering-  , sLessAtoms--  , rawLessRel-  , rawEdgeRel--  , alwaysBefore-  , isInTrace--  -- ** The last node-  , sLastAtom-  , isLast--  -- ** Equations-  , module Theory.Tools.EquationStore-  , sEqStore-  , sSubst-  , sConjDisjEqs--  -- ** Formulas-  , sFormulas-  , sSolvedFormulas--  -- ** Lemmas-  , sLemmas-  , insertLemmas--  -- ** Keeping track of typing assumptions-  , CaseDistKind(..)-  , sCaseDistKind--  -- ** Goals-  , GoalStatus(..)-  , gsSolved-  , gsLoopBreaker-  , gsNr--  , sGoals-  , sNextGoalNr--  -- * Pretty-printing-  , prettySystem-  , prettyNonGraphSystem--  ) where--import           Prelude                              hiding (id, (.))--import           Data.Binary-import qualified Data.DAG.Simple                      as D-import           Data.DeriveTH-import           Data.List                            (foldl', partition)-import qualified Data.Map                             as M-import           Data.Maybe                           (fromMaybe)-import           Data.Monoid                          (Monoid(..))-import qualified Data.Set                             as S--import           Control.Basics-import           Control.Category-import           Control.DeepSeq--import           Data.Label                           ((:->), mkLabels)-import qualified Extension.Data.Label                 as L--import           Logic.Connectives-import           Theory.Constraint.System.Constraints-import           Theory.Model-import           Theory.Text.Pretty-import           Theory.Tools.EquationStore------------------------------------------------------------------------------------- Types----------------------------------------------------------------------------------- | Whether we are checking for the existence of a trace satisfiying a the--- current constraint system or whether we're checking that no traces--- satisfies the current constraint system.-data SystemTraceQuantifier = ExistsSomeTrace | ExistsNoTrace-       deriving( Eq, Ord, Show )---- | Case dinstinction kind that are allowed. The order of the kinds--- corresponds to the subkinding relation: untyped < typed.-data CaseDistKind = UntypedCaseDist | TypedCaseDist-       deriving( Eq )--instance Show CaseDistKind where-    show UntypedCaseDist = "untyped"-    show TypedCaseDist   = "typed"--instance Ord CaseDistKind where-    compare UntypedCaseDist UntypedCaseDist = EQ-    compare UntypedCaseDist TypedCaseDist   = LT-    compare TypedCaseDist   UntypedCaseDist = GT-    compare TypedCaseDist   TypedCaseDist   = EQ---- | The status of a 'Goal'. Use its 'Semigroup' instance to combine the--- status info of goals that collapse.-data GoalStatus = GoalStatus-    { _gsSolved :: Bool-       -- True if the goal has been solved already.-    , _gsNr :: Integer-       -- The number of the goal: we use it to track the creation order of-       -- goals.-    , _gsLoopBreaker :: Bool-       -- True if this goal should be solved with care because it may lead to-       -- non-termination.-    }-    deriving( Eq, Ord, Show )---- | A constraint system.-data System = System-    { _sNodes          :: M.Map NodeId RuleACInst-    , _sEdges          :: S.Set Edge-    , _sLessAtoms      :: S.Set (NodeId, NodeId)-    , _sLastAtom       :: Maybe NodeId-    , _sEqStore        :: EqStore-    , _sFormulas       :: S.Set LNGuarded-    , _sSolvedFormulas :: S.Set LNGuarded-    , _sLemmas         :: S.Set LNGuarded-    , _sGoals          :: M.Map Goal GoalStatus-    , _sNextGoalNr     :: Integer-    , _sCaseDistKind   :: CaseDistKind-    }-    -- NOTE: Don't forget the update 'substSystem' in-    -- "Constraint.Solver.Reduction" when adding further fields to the-    -- constraint system.-    deriving( Eq, Ord )--$(mkLabels [''System, ''GoalStatus])----- Further accessors------------------------- | Label to access the free substitution of the equation store.-sSubst :: System :-> LNSubst-sSubst = eqsSubst . sEqStore---- | Label to access the conjunction of disjunctions of fresh substutitution in--- the equation store.-sConjDisjEqs :: System :-> Conj (SplitId, S.Set (LNSubstVFresh))-sConjDisjEqs = eqsConj . sEqStore------------------------------------------------------------------------------------- Constraint system construction----------------------------------------------------------------------------------- | The empty constraint system, which is logically equivalent to true.-emptySystem :: CaseDistKind -> System-emptySystem = System-    M.empty S.empty S.empty Nothing emptyEqStore-    S.empty S.empty S.empty-    M.empty 0---- | Returns the constraint system that has to be proven to show that given--- formula holds in the context of the given theory.-formulaToSystem :: [LNGuarded]           -- ^ Axioms to add-                -> CaseDistKind          -- ^ Case distinction kind-                -> SystemTraceQuantifier -- ^ Trace quantifier-                -> LNFormula-                -> System-formulaToSystem axioms kind traceQuantifier fm =-      insertLemmas safetyAxioms-    $ L.set sFormulas (S.singleton gf2)-    $ (emptySystem kind)-  where-    (safetyAxioms, otherAxioms) = partition isSafetyFormula axioms-    gf0 = formulaToGuarded_ fm-    gf1 = case traceQuantifier of-      ExistsSomeTrace -> gf0-      ExistsNoTrace   -> gnot gf0-    -- Non-safety axioms must be added to the formula, as they render the set-    -- of traces non-prefix-closed, which makes the use of induction unsound.-    gf2 = gconj $ gf1 : otherAxioms---- | Add a lemma / additional assumption to a constraint system.-insertLemma :: LNGuarded -> System -> System-insertLemma =-    go-  where-    go (GConj conj) = foldr (.) id $ map go $ getConj conj-    go fm           = L.modify sLemmas (S.insert fm)---- | Add lemmas / additional assumptions to a constraint system.-insertLemmas :: [LNGuarded] -> System -> System-insertLemmas fms sys = foldl' (flip insertLemma) sys fms----------------------------------------------------------------------------------- Queries------------------------------------------------------------------------------------ Nodes----------------- | A list of all KD-conclusions in the 'System'.-allKDConcs :: System -> [(NodeId, RuleACInst, LNTerm)]-allKDConcs sys = do-    (i, ru)                            <- M.toList $ L.get sNodes sys-    (_, kFactView -> Just (DnK, m)) <- enumConcs ru-    return (i, ru, m)---- | @nodeRule v@ accesses the rule label of node @v@ under the assumption that--- it is present in the sequent.-nodeRule :: NodeId -> System -> RuleACInst-nodeRule v se =-    fromMaybe errMsg $ M.lookup v $ L.get sNodes se-  where-    errMsg = error $-        "nodeRule: node '" ++ show v ++ "' does not exist in sequent\n" ++-        render (nest 2 $ prettySystem se)----- | @nodePremFact prem se@ computes the fact associated to premise @prem@ in--- sequent @se@ under the assumption that premise @prem@ is a a premise in--- @se@.-nodePremFact :: NodePrem -> System -> LNFact-nodePremFact (v, i) se = L.get (rPrem i) $ nodeRule v se---- | @nodePremNode prem@ is the node that this premise is referring to.-nodePremNode :: NodePrem -> NodeId-nodePremNode = fst---- | All facts associated to this node premise.-resolveNodePremFact :: NodePrem -> System -> Maybe LNFact-resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se)---- | The fact associated with this node conclusion, if there is one.-resolveNodeConcFact :: NodeConc -> System -> Maybe LNFact-resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se)---- | @nodeConcFact (NodeConc (v, i))@ accesses the @i@-th conclusion of the--- rule associated with node @v@ under the assumption that @v@ is labeled with--- a rule that has an @i@-th conclusion.-nodeConcFact :: NodeConc -> System -> LNFact-nodeConcFact (v, i) = L.get (rConc i) . nodeRule v---- | 'nodeConcNode' @c@ compute the node-id of the node conclusion @c@.-nodeConcNode :: NodeConc -> NodeId-nodeConcNode = fst----- Actions--------------- | All actions that hold in a sequent.-unsolvedActionAtoms :: System -> [(NodeId, LNFact)]-unsolvedActionAtoms sys =-      do (ActionG i fa, status) <- M.toList (L.get sGoals sys)-         guard (not $ L.get gsSolved status)-         return (i, fa)---- | All actions that hold in a sequent.-allActions :: System -> [(NodeId, LNFact)]-allActions sys =-      unsolvedActionAtoms sys-  <|> do (i, ru) <- M.toList $ L.get sNodes sys-         (,) i <$> L.get rActs ru---- | All actions that hold in a sequent.-allKUActions :: System -> [(NodeId, LNFact, LNTerm)]-allKUActions sys = do-    (i, fa@(kFactView -> Just (UpK, m))) <- allActions sys-    return (i, fa, m)---- | The standard actions, i.e., non-KU-actions.-standardActionAtoms :: System -> [(NodeId, LNFact)]-standardActionAtoms = filter (not . isKUFact . snd) . unsolvedActionAtoms---- | All KU-actions.-kuActionAtoms :: System -> [(NodeId, LNFact, LNTerm)]-kuActionAtoms sys = do-    (i, fa@(kFactView -> Just (UpK, m))) <- unsolvedActionAtoms sys-    return (i, fa, m)---- Destruction chains-------------------------- | All unsolved destruction chains in the constraint system.-unsolvedChains :: System -> [(NodeConc, NodePrem)]-unsolvedChains sys = do-    (ChainG from to, status) <- M.toList $ L.get sGoals sys-    guard (not $ L.get gsSolved status)-    return (from, to)----- The temporal order-------------------------- | @(from,to)@ is in @rawEdgeRel se@ iff we can prove that there is an--- edge-path from @from@ to @to@ in @se@ without appealing to transitivity.-rawEdgeRel :: System -> [(NodeId, NodeId)]-rawEdgeRel sys = map (nodeConcNode *** nodePremNode) $-     [(from, to) | Edge from to <- S.toList $ L.get sEdges sys]-  ++ unsolvedChains sys---- | @(from,to)@ is in @rawLessRel se@ iff we can prove that there is a path--- (possibly using the 'Less' relation) from @from@ to @to@ in @se@ without--- appealing to transitivity.-rawLessRel :: System -> [(NodeId,NodeId)]-rawLessRel se = S.toList (L.get sLessAtoms se) ++ rawEdgeRel se---- | Returns a predicate that is 'True' iff the first argument happens before--- the second argument in all models of the sequent.-alwaysBefore :: System -> (NodeId -> NodeId -> Bool)-alwaysBefore sys =-    check -- lessRel is cached for partial applications-  where-    lessRel   = rawLessRel sys-    check i j =-         -- speed-up check by first checking less-atoms-         ((i, j) `S.member` L.get sLessAtoms sys)-      || (j `S.member` D.reachableSet [i] lessRel)---- | 'True' iff the given node id is guaranteed to be instantiated to an--- index in the trace.-isInTrace :: System -> NodeId -> Bool-isInTrace sys i =-     i `M.member` L.get sNodes sys-  || isLast sys i-  || any ((i ==) . fst) (unsolvedActionAtoms sys)---- | 'True' iff the given node id is guaranteed to be instantiated to the last--- index of the trace.-isLast :: System -> NodeId -> Bool-isLast sys i = Just i == L.get sLastAtom sys------------------------------------------------------------------------------------- Pretty printing                                                          ------------------------------------------------------------------------------------- | Pretty print a sequent-prettySystem :: HighlightDocument d => System -> d-prettySystem se = vcat $-    map combine-      [ ("nodes",          vcat $ map prettyNode $ M.toList $ L.get sNodes se)-      , ("actions",        fsepList ppActionAtom $ unsolvedActionAtoms se)-      , ("edges",          fsepList prettyEdge   $ S.toList $ L.get sEdges se)-      , ("less",           fsepList prettyLess   $ S.toList $ L.get sLessAtoms se)-      , ("unsolved goals", prettyGoals False se)-      ]-    ++ [prettyNonGraphSystem se]-  where-    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]-    ppActionAtom (i, fa) = prettyNAtom (Action (varTerm i) fa)---- | Pretty print the non-graph part of the sequent; i.e. equation store and--- clauses.-prettyNonGraphSystem :: HighlightDocument d => System -> d-prettyNonGraphSystem se = vsep $ map combine-  [ ("last",            maybe (text "none") prettyNodeId $ L.get sLastAtom se)-  , ("formulas",        vsep $ map prettyGuarded $ S.toList $ L.get sFormulas se)-  , ("equations",       prettyEqStore $ L.get sEqStore se)-  , ("lemmas",          vsep $ map prettyGuarded $ S.toList $ L.get sLemmas se)-  , ("allowed cases",   text $ show $ L.get sCaseDistKind se)-  , ("solved formulas", vsep $ map prettyGuarded $ S.toList $ L.get sSolvedFormulas se)-  , ("solved goals",    prettyGoals True se)-  ]-  where-    combine (header, d)  = fsep [keyword_ header <> colon, nest 2 d]---- | Pretty print solved or unsolved goals.-prettyGoals :: HighlightDocument d => Bool -> System -> d-prettyGoals solved sys = vsep $ do-    (goal, status) <- M.toList $ L.get sGoals sys-    guard (solved == L.get gsSolved status)-    let nr  = L.get gsNr status-        loopBreaker | L.get gsLoopBreaker status = " (loop breaker)"-                    | otherwise                  = ""-    return $ prettyGoal goal <-> lineComment_ ("nr: " ++ show nr ++ loopBreaker)----- Additional instances--------------------------deriving instance Show System--instance Apply CaseDistKind where-    apply = const id--instance HasFrees CaseDistKind where-    foldFrees = const mempty-    mapFrees  = const pure--instance HasFrees GoalStatus where-    foldFrees = const mempty-    mapFrees  = const pure--instance HasFrees System where-    foldFrees fun (System a b c d e f g h i j k) =-        foldFrees fun a `mappend`-        foldFrees fun b `mappend`-        foldFrees fun c `mappend`-        foldFrees fun d `mappend`-        foldFrees fun e `mappend`-        foldFrees fun f `mappend`-        foldFrees fun g `mappend`-        foldFrees fun h `mappend`-        foldFrees fun i `mappend`-        foldFrees fun j `mappend`-        foldFrees fun k--    mapFrees fun (System a b c d e f g h i j k) =-        System <$> mapFrees fun a-               <*> mapFrees fun b-               <*> mapFrees fun c-               <*> mapFrees fun d-               <*> mapFrees fun e-               <*> mapFrees fun f-               <*> mapFrees fun g-               <*> mapFrees fun h-               <*> mapFrees fun i-               <*> mapFrees fun j-               <*> mapFrees fun k---$( derive makeBinary ''CaseDistKind)-$( derive makeBinary ''GoalStatus)-$( derive makeBinary ''System)-$( derive makeBinary ''SystemTraceQuantifier)--$( derive makeNFData ''CaseDistKind)-$( derive makeNFData ''GoalStatus)-$( derive makeNFData ''System)-$( derive makeNFData ''SystemTraceQuantifier)
− src/Theory/Constraint/System/Constraints.hs 
@@ -1,211 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell    #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Types representing constraints.-module Theory.Constraint.System.Constraints (-  -- * Guarded formulas-    module Theory.Constraint.System.Guarded--  -- * Graph constraints-  , NodePrem-  , NodeConc-  , Edge(..)-  , Less--  -- * Goal constraints-  , Goal(..)-  , isActionGoal-  , isStandardActionGoal-  , isPremiseGoal-  , isChainGoal-  , isSplitGoal-  , isDisjGoal--  -- ** Pretty-printing-  , prettyNode-  , prettyNodePrem-  , prettyNodeConc-  , prettyEdge-  , prettyLess-  , prettyGoal-  ) where--import           Data.Binary-import           Data.DeriveTH-import           Data.Generics-import           Extension.Data.Monoid            (Monoid(..))--import           Control.Basics-import           Control.DeepSeq--import           Text.PrettyPrint.Class-import           Text.Unicode--import           Logic.Connectives-import           Theory.Constraint.System.Guarded-import           Theory.Model-import           Theory.Text.Pretty-import           Theory.Tools.EquationStore----------------------------------------------------------------------------------- Graph part of a sequent                                                  ------------------------------------------------------------------------------------- | A premise of a node.-type NodePrem = (NodeId, PremIdx)---- | A conclusion of a node.-type NodeConc = (NodeId, ConcIdx)---- | A labeled edge in a derivation graph.-data Edge = Edge {-      eSrc :: NodeConc-    , eTgt :: NodePrem-    }-  deriving (Show, Ord, Eq, Data, Typeable)---- | A *⋖* constraint between 'NodeId's.-type Less = (NodeId, NodeId)---- Instances---------------instance Apply Edge where-    apply subst (Edge from to) = Edge (apply subst from) (apply subst to)--instance HasFrees Edge where-    foldFrees f (Edge x y) = foldFrees f x `mappend` foldFrees f y-    mapFrees  f (Edge x y) = Edge <$> mapFrees f x <*> mapFrees f y------------------------------------------------------------------------------------ Goals----------------------------------------------------------------------------------- | A 'Goal' denotes that a constraint reduction rule is applicable, which--- might result in case splits. We either use a heuristic to decide what goal--- to solve next or leave the choice to user (in case of the interactive UI).-data Goal =-       ActionG LVar LNFact-       -- ^ An action that must exist in the trace.-     | ChainG NodeConc NodePrem-       -- A destruction chain.-     | PremiseG NodePrem LNFact-       -- ^ A premise that must have an incoming direct edge.-     | SplitG SplitId-       -- ^ A case split over equalities.-     | DisjG (Disj LNGuarded)-       -- ^ A case split over a disjunction.-     deriving( Eq, Ord, Show )---- Indicators----------------isActionGoal :: Goal -> Bool-isActionGoal (ActionG _ _) = True-isActionGoal _             = False--isStandardActionGoal :: Goal -> Bool-isStandardActionGoal (ActionG _ fa) = not (isKUFact fa)-isStandardActionGoal _              = False--isPremiseGoal :: Goal -> Bool-isPremiseGoal (PremiseG _ _) = True-isPremiseGoal _              = False--isChainGoal :: Goal -> Bool-isChainGoal (ChainG _ _) = True-isChainGoal _            = False--isSplitGoal :: Goal -> Bool-isSplitGoal (SplitG _) = True-isSplitGoal _          = False--isDisjGoal :: Goal -> Bool-isDisjGoal (DisjG _) = True-isDisjGoal _         = False------ Instances---------------instance HasFrees Goal where-    foldFrees f goal = case goal of-        ActionG i fa  -> foldFrees f i <> foldFrees f fa-        PremiseG p fa -> foldFrees f p <> foldFrees f fa-        ChainG c p    -> foldFrees f c <> foldFrees f p-        SplitG i      -> foldFrees f i-        DisjG x       -> foldFrees f x--    mapFrees f goal = case goal of-        ActionG i fa  -> ActionG  <$> mapFrees f i <*> mapFrees f fa-        PremiseG p fa -> PremiseG <$> mapFrees f p <*> mapFrees f fa-        ChainG c p    -> ChainG   <$> mapFrees f c <*> mapFrees f p-        SplitG i      -> SplitG   <$> mapFrees f i-        DisjG x       -> DisjG    <$> mapFrees f x--instance Apply Goal where-    apply subst goal = case goal of-        ActionG i fa  -> ActionG  (apply subst i) (apply subst fa)-        PremiseG p fa -> PremiseG (apply subst p) (apply subst fa)-        ChainG c p    -> ChainG   (apply subst c) (apply subst p)-        SplitG i      -> SplitG   (apply subst i)-        DisjG x       -> DisjG    (apply subst x)------------------------------------------------------------------------------------ Pretty printing                                                          ------------------------------------------------------------------------------------- | Pretty print a node.-prettyNode :: HighlightDocument d => (NodeId, RuleACInst) -> d-prettyNode (v,ru) = prettyNodeId v <> colon <-> prettyRuleACInst ru---- | Pretty print a node conclusion.-prettyNodeConc :: HighlightDocument d => NodeConc -> d-prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i)---- | Pretty print a node premise.-prettyNodePrem :: HighlightDocument d => NodePrem -> d-prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i)---- | Pretty print a edge as @src >-i--j-> tgt@.-prettyEdge :: HighlightDocument d => Edge -> d-prettyEdge (Edge c p) =-    prettyNodeConc c <-> operator_ ">-->" <-> prettyNodePrem p---- | Pretty print a less-atom as @src < tgt@.-prettyLess :: HighlightDocument d => Less -> d-prettyLess (i, j) = prettyNAtom $ Less (varTerm i) (varTerm j)---- | Pretty print a goal.-prettyGoal :: HighlightDocument d => Goal -> d-prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa)-prettyGoal (ChainG c p)   =-    prettyNodeConc c <-> operator_ "~~>" <-> prettyNodePrem p-prettyGoal (PremiseG (i, (PremIdx v)) fa) =-    -- Note that we can use "▷" for conclusions once we need them.-    prettyLNFact fa <-> text ("▶" ++ subscript (show v)) <-> prettyNodeId i-    -- prettyNodePrem p <> brackets (prettyLNFact fa)-prettyGoal (DisjG (Disj []))  = text "Disj" <-> operator_ "(⊥)"-prettyGoal (DisjG (Disj gfs)) = fsep $-    punctuate (operator_ "  ∥") (map (nest 1 . parens . prettyGuarded) gfs)-    -- punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs)-prettyGoal (SplitG x) =-    text "splitEqs" <> parens (text $ show (unSplitId x))---- Derived instances-----------------------$( derive makeBinary ''Edge)-$( derive makeBinary ''Goal)--$( derive makeNFData ''Edge)-$( derive makeNFData ''Goal)
− src/Theory/Constraint/System/Dot.hs 
@@ -1,519 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators   #-}--- |--- Copyright   : (c) 2010, 2011 Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Conversion of the graph part of a sequent to a Graphviz Dot file.-module Theory.Constraint.System.Dot (-    nonEmptyGraph-  , dotSystemLoose-  , dotSystemCompact-  , compressSystem-  , BoringNodeStyle(..)-  ) where--import           Data.Char                (isSpace)-import           Data.Color-import qualified Data.DAG.Simple          as D-import qualified Data.Foldable            as F-import           Data.List-import qualified Data.Map                 as M-import           Data.Maybe-import           Data.Monoid              (Any(..))-import qualified Data.Set                 as S-import           Safe--import           Extension.Data.Label-import           Extension.Prelude--import           Control.Basics-import           Control.Monad.Reader-import           Control.Monad.State      (StateT, evalStateT)--import qualified Text.Dot                 as D-import           Text.PrettyPrint.Class--import           Theory.Constraint.System-import           Theory.Model-import           Theory.Text.Pretty       (opAction)---- | 'True' iff the dotted system will be a non-empty graph.-nonEmptyGraph :: System -> Bool-nonEmptyGraph sys = not $-    M.null (get sNodes sys) && null (unsolvedActionAtoms sys) &&-    null (unsolvedChains sys) &&-    S.null (get sEdges sys) && S.null (get sLessAtoms sys)--type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double)-type SeDot = ReaderT (System, NodeColorMap) (StateT DotState D.Dot)---- | State to avoid multiple drawing of the same entity.-data DotState = DotState {-    _dsNodes   :: M.Map NodeId   D.NodeId-  , _dsPrems   :: M.Map NodePrem D.NodeId-  , _dsConcs   :: M.Map NodeConc D.NodeId-  , _dsSingles :: M.Map (NodeConc, NodePrem) D.NodeId-  }--$(mkLabels [''DotState])---- | Lift a 'D.Dot' action.-liftDot :: D.Dot a -> SeDot a-liftDot = lift . lift---- | All edges in a bipartite graph that have neither start point nor endpoint--- in common with any other edge.-singleEdges :: (Ord a, Ord b) => [(a,b)] -> [(a,b)]-singleEdges es =-    singles fst es `intersect` singles snd es-  where-    singles proj = concatMap single . groupOn proj . sortOn proj-    single []  = error "impossible"-    single [x] = return x-    single _   = mzero---- | Get a lighter color.-lighter :: HSV Double -> RGB Double-lighter = hsvToRGB -- fmap (\c -> 1 - 0.3*(1-c)) . hsvToRGB---- | Ensure that a 'SeDot' action is only executed once by querying and--- updating the 'DotState' accordingly.-dotOnce :: Ord k-        => (DotState :-> M.Map k D.NodeId) -- ^ Accessor to map storing this type of actions.-        -> k                               -- ^ Action index.-        -> SeDot D.NodeId                  -- ^ Action to execute only once.-        -> SeDot D.NodeId-dotOnce mapL k dot = do-    i <- join $ (maybe dot return . M.lookup k) `liftM` getM mapL-    modM mapL (M.insert k i)-    return i--dotNode :: NodeId -> SeDot D.NodeId-dotNode v = dotOnce dsNodes v $ do-    (se, colorMap) <- ask-    let nodes = get sNodes se-        dot info moreStyle facts = do-            vId <- liftDot $ D.node $ [("label", show v ++ info),("shape","ellipse")]-                                      ++ moreStyle-            _ <- facts vId-            return vId--    case M.lookup v nodes of-      Nothing -> do-          dot "" [] (const $ return ()) -- \vId -> do-              {--              premIds <- mapM dotPrem-                           [ NodePremFact v fa-                           | SeRequires v' fa <- S.toList $ get sRequires se-                           , v == v' ]-              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]-              -}-      Just ru -> do-          let-              color     = M.lookup (get rInfo ru) colorMap-              nodeColor = maybe "white" (rgbToHex . lighter) color-          dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do-              premIds <- mapM dotPrem-                           [ (v,i) | (i,_) <- enumPrems ru ]-              concIds <- mapM dotConc-                           [ (v,i) | (i,_) <- enumConcs ru ]-              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]-              sequence_ [ dotIntraRuleEdge vId concId | concId <- concIds ]-  where-    label ru = " : " ++ render nameAndActs-      where-        nameAndActs =-            ruleInfo (prettyProtoRuleName . get praciName) prettyIntrRuleACInfo (get rInfo ru) <->-            brackets (vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)---- | An edge from a rule node to its premises or conclusions.-dotIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()-dotIntraRuleEdge from to = liftDot $ D.edge from to [("color","gray")]--{---- | An edge from a rule node to some of its premises or conclusions.-dotNonFixedIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()-dotNonFixedIntraRuleEdge from to =-    liftDot $ D.edge from to [("color","steelblue")]--}---- | The style of a node displaying a fact.-factNodeStyle :: LNFact -> [(String,String)]-factNodeStyle fa-  | isJust (kFactView fa) = []-  | otherwise             = [("fillcolor","gray85"),("style","filled")]---- | An edge that shares no endpoints with another edge and is therefore--- contracted.------ FIXME: There may be too many edges being contracted.-dotSingleEdge :: (NodeConc, NodePrem) -> SeDot D.NodeId-dotSingleEdge edge@(_, to) = dotOnce dsSingles edge $ do-    se <- asks fst-    let fa    = nodePremFact to se-        label = render $ prettyLNFact fa-    liftDot $ D.node $ [("label", label),("shape", "hexagon")]-                       ++ factNodeStyle fa---- | A compressed edge.-dotTrySingleEdge :: Eq c-                 => ((NodeConc, NodePrem) -> c) -> c-                 -> SeDot D.NodeId -> SeDot D.NodeId-dotTrySingleEdge sel x dot = do-    singles <- getM dsSingles-    maybe dot (return . snd) $ find ((x ==) . sel . fst) $ M.toList singles---- | Premises.-dotPrem :: NodePrem -> SeDot D.NodeId-dotPrem prem@(v, i) =-    dotOnce dsPrems prem $ dotTrySingleEdge snd prem $ do-        nodes <- asks (get sNodes . fst)-        let ppPrem = show prem -- FIXME: Use better pretty printing here-            (label, moreStyle) = fromMaybe (ppPrem, []) $ do-                ru <- M.lookup v nodes-                fa <- lookupPrem i ru-                return ( render $ prettyLNFact fa-                       , factNodeStyle fa-                       )-        liftDot $ D.node $ [("label", label),("shape",shape)]-                           ++ moreStyle-  where-    shape = "invtrapezium"---- | Conclusions.-dotConc :: NodeConc -> SeDot D.NodeId-dotConc =-    dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium"-  where-    dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 =-        dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do-            let x = unwrap x0-            nodes <- asks (get sNodes . fst)-            let (label, moreStyle) = fromMaybe (show x, []) $ do-                    ru <- M.lookup (fst x) nodes-                    fa <- (`atMay` snd x) $ get ruleSel ru-                    return ( render $ prettyLNFact fa-                           , factNodeStyle fa-                           )-            liftDot $ D.node $ [("label", label),("shape",shape)]-                               ++ moreStyle------ | Convert the sequent to a 'D.Dot' action representing this sequent as a--- graph in the GraphViz format. The style is loose in the sense that each--- premise and conclusion gets its own node.-dotSystemLoose :: System -> D.Dot ()-dotSystemLoose se =-    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $-    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do-        liftDot $ setDefaultAttributes-        -- draw single edges with matching facts.-        mapM_ dotSingleEdge $ singleEdges $ do-            Edge from to <- S.toList $ get sEdges se-            -- FIXME: ensure that conclusion and premise are equal-            guard (nodeConcFact from se == nodePremFact to se)-            return (from, to)-        sequence_ $ do-            (v, ru) <- M.toList $ get sNodes se-            (i, _)  <- enumConcs ru-            return (dotConc (v, i))-        sequence_ $ do-            (v, ru) <- M.toList $ get sNodes se-            (i, _)  <- enumPrems ru-            return (dotPrem (v,i))-        -- FIXME: Also dot unsolved actions.-        mapM_ dotNode     $ M.keys   $ get sNodes     se-        mapM_ dotEdge     $ S.toList $ get sEdges     se-        mapM_ dotChain    $            unsolvedChains se-        mapM_ dotLess     $ S.toList $ get sLessAtoms se-  where-    dotEdge  (Edge src tgt)  = do-        mayNid <- M.lookup (src,tgt) `liftM` getM dsSingles-        maybe (dotGenEdge [] src tgt) (const $ return ()) mayNid--    dotChain (src, tgt) =-        dotGenEdge [("style","dashed"),("color","green")] src tgt--    dotLess (src, tgt) = do-        srcId <- dotNode src-        tgtId <- dotNode tgt-        liftDot $ D.edge srcId tgtId-            [("color","black"),("style","dotted")] -- FIXME: Reactivate,("constraint","false")]-            -- setting constraint to false ignores less-edges when ranking nodes.--    dotGenEdge style src tgt = do-        srcId <- dotConc src-        tgtId <- dotPrem tgt-        liftDot $ D.edge srcId tgtId style----- | Set default attributes for nodes and edges.-setDefaultAttributes :: D.Dot ()-setDefaultAttributes = do-  D.attribute ("nodesep","0.3")-  D.attribute ("ranksep","0.3")-  D.nodeAttributes [("fontsize","8"),("fontname","Helvetica"),("width","0.3"),("height","0.2")]-  D.edgeAttributes [("fontsize","8"),("fontname","Helvetica")]----- | Compute a color map for nodes labelled with a proof rule info of one of--- the given rules.-nodeColorMap :: [RuleACInst] -> NodeColorMap-nodeColorMap rules =-    M.fromList $-      [ (get rInfo ru, getColor (gIdx, mIdx))-      | (gIdx, grp) <- groups, (mIdx, ru) <- zip [0..] grp ]-  where-    groupIdx ru | isDestrRule ru                   = 0-                | isConstrRule ru                  = 2-                | isFreshRule ru || isISendRule ru = 3-                | otherwise                        = 1--    -- groups of rules labeled with their index in the group-    groups = [ (gIdx, [ ru | ru <- rules, gIdx == groupIdx ru])-             | gIdx <- [0..3]-             ]--    -- color for each member of a group-    colors = M.fromList $ lightColorGroups intruderHue (map (length . snd) groups)-    getColor idx = fromMaybe (HSV 0 1 1) $ M.lookup idx colors--    -- The hue of the intruder rules-    intruderHue :: Double-    intruderHue = 18 / 360----------------------------------------------------------------------------------- Record based dotting----------------------------------------------------------------------------------- | The style for nodes of the intruder.-data BoringNodeStyle = FullBoringNodes | CompactBoringNodes-    deriving( Eq, Ord, Show )----- | Dot a node in record based (compact) format.-dotNodeCompact :: BoringNodeStyle -> NodeId -> SeDot D.NodeId-dotNodeCompact boringStyle v = dotOnce dsNodes v $ do-    (se, colorMap) <- ask-    let hasOutgoingEdge =-            or [ v == v' | Edge (v', _) _ <- S.toList $ get sEdges se ]-    case M.lookup v $ get sNodes se of-      Nothing -> case filter ((v ==) . fst) (unsolvedActionAtoms se) of-        [] -> mkSimpleNode (show v) []-        as -> let lbl = (fsep $ punctuate comma $ map (prettyLNFact . snd) as)-                        <-> opAction <-> text (show v)-                  attrs | any (isKUFact . snd) as = [("color","gray")]-                        | otherwise               = [("color","darkblue")]-              in mkSimpleNode (render lbl) attrs-      Just ru -> do-          let color     = M.lookup (get rInfo ru) colorMap-              nodeColor = maybe "white" (rgbToHex . lighter) color-              attrs     = [("fillcolor", nodeColor),("style","filled")]-          ids <- mkNode ru attrs hasOutgoingEdge-          let prems = [ ((v, i), nid) | (Just (Left i),  nid) <- ids ]-              concs = [ ((v, i), nid) | (Just (Right i), nid) <- ids ]-          modM dsPrems $ M.union $ M.fromList prems-          modM dsConcs $ M.union $ M.fromList concs-          return $ fromJust $ lookup Nothing ids-  where--    mkSimpleNode lbl attrs =-        liftDot $ D.node $ [("label", lbl),("shape","ellipse")] ++ attrs--    mkNode ru attrs hasOutgoingEdge-      -- single node, share node-id for all premises and conclusions-      | boringStyle == CompactBoringNodes &&-        (isIntruderRule ru || isFreshRule ru) = do-            let lbl | hasOutgoingEdge = show v ++ " : " ++ showRuleCaseName ru-                    | otherwise       = concatMap snd as-            nid <- mkSimpleNode lbl []-            return [ (key, nid) | (key, _) <- ps ++ as ++ cs ]-      -- full record syntax-      | otherwise =-            fmap snd $ liftDot $ (`D.record` attrs) $-            D.vcat $ map D.hcat $ map (map (uncurry D.portField)) $-            filter (not . null) [ps, as, cs]-      where-        ps = renderRow [ (Just (Left i),  prettyLNFact p) | (i, p) <- enumPrems ru ]-        as = renderRow [ (Nothing,        ruleLabel ) ]-        cs = renderRow [ (Just (Right i), prettyLNFact c) | (i, c) <- enumConcs ru ]--        ruleLabel =-            prettyNodeId v <-> colon <-> text (showRuleCaseName ru) <>-            (brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)--        renderRow annDocs =-          zipWith (\(ann, _) lbl -> (ann, lbl)) annDocs $-            -- magic factor 1.3 compensates for space gained due to-            -- non-propertional font-            renderBalanced 100 (max 30 . round . (* 1.3)) (map snd annDocs)--        renderBalanced :: Double           -- ^ Total available width-                       -> (Double -> Int)  -- ^ Convert available space to actual line-width.-                       -> [Doc]            -- ^ Initial documents-                       -> [String]         -- ^ Rendered documents-        renderBalanced _          _    []   = []-        renderBalanced totalWidth conv docs =-            zipWith (\w d -> widthRender (conv (ratio * w)) d) usedWidths docs-          where-            oneLineRender  = renderStyle (defaultStyle { mode = OneLineMode })-            widthRender w  = scaleIndent . renderStyle (defaultStyle { lineLength = w })-            usedWidths     = map (fromIntegral . length . oneLineRender) docs-            ratio          = totalWidth / sum usedWidths-            scaleIndent line = case span isSpace line of-              (spaces, rest) ->-                  -- spaces are not wide-enough by default => scale them up-                  let n = (1.5::Double) * fromIntegral (length spaces)-                  in  replicate (round n) ' ' ++ rest------ | Dot a sequent in compact form (one record per rule), if there is anything--- to draw.-dotSystemCompact :: BoringNodeStyle -> System -> D.Dot ()-dotSystemCompact boringStyle se =-    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $-    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do-        liftDot $ setDefaultAttributes-        mapM_ (dotNodeCompact boringStyle) $ M.keys $ get sNodes       se-        mapM_ (dotNodeCompact boringStyle . fst) $ unsolvedActionAtoms se-        F.mapM_ dotEdge                            $ get sEdges        se-        F.mapM_ dotChain                           $ unsolvedChains    se-        F.mapM_ dotLess                            $ get sLessAtoms    se-  where-    missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)]-    dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem-    dotConcC conc = dotOnce dsConcs conc $ missingNode "trapezium" $ prettyNodeConc conc-    dotEdge (Edge src tgt)  = do-        let check p = maybe False p (resolveNodePremFact tgt se) ||-                      maybe False p (resolveNodeConcFact src se)-            attrs | check isProtoFact =-                      [("style","bold"),("weight","10.0")] ++-                      (guard (check isPersistentFact) >> [("color","gray50")])-                  | check isKFact     = [("color","orangered2")]-                  | otherwise         = [("color","gray30")]-        dotGenEdge attrs src tgt--    dotGenEdge style src tgt = do-        srcId <- dotConcC src-        tgtId <- dotPremC tgt-        liftDot $ D.edge srcId tgtId style--    dotChain (src, tgt) =-        dotGenEdge [("style","dashed"),("color","green")] src tgt--    dotLess (src, tgt) = do-        srcId <- dotNodeCompact boringStyle src-        tgtId <- dotNodeCompact boringStyle tgt-        liftDot $ D.edge srcId tgtId-            [("color","black"),("style","dotted")] -- FIXME: reactivate ,("constraint","false")]-            -- setting constraint to false ignores less-edges when ranking nodes.------------------------------------------------------------------------------------ Compressed versions of a sequent----------------------------------------------------------------------------------- | Drop 'Less' atoms entailed by the edges of the 'System'.-dropEntailedOrdConstraints :: System -> System-dropEntailedOrdConstraints se =-    modify sLessAtoms (S.filter (not . entailed)) se-  where-    edges               = rawEdgeRel se-    entailed (from, to) = to `S.member` D.reachableSet [from] edges---- | Unsound compression of the sequent that drops fully connected learns and--- knows nodes.-compressSystem :: System -> System-compressSystem se0 =-    foldl' (flip tryHideNodeId) se (frees (get sLessAtoms se, get sNodes se))-  where-    se = dropEntailedOrdConstraints se0---- | @hideTransferNode v se@ hides node @v@ in sequent @se@ if it is a--- transfer node; i.e., a node annotated with a rule that is one of the--- special intruder rules or a rule with with at most one premise and--- at most one conclusion and both premises and conclusions have incoming--- respectively outgoing edges.------ The compression is chosen such that unly uninteresting nodes are that have--- no open goal are suppressed.-tryHideNodeId :: NodeId -> System -> System-tryHideNodeId v se = fromMaybe se $ do-    guard $  (lvarSort v == LSortNode)-          && notOccursIn unsolvedChains-          && notOccursIn (get sFormulas)-    maybe hideAction hideRule (M.lookup v $ get sNodes se)-  where-    selectPart :: (System :-> S.Set a) -> (a -> Bool) -> [a]-    selectPart l p = filter p $ S.toList $ get l se--    notOccursIn :: HasFrees a => (System -> a) -> Bool-    notOccursIn proj = not $ getAny $ foldFrees (Any . (v ==)) $ proj se--    -- hide KU-actions deducing pairs, inverses, and simple terms-    hideAction = do-        guard $  not (null kuActions)-              && all eligibleTerm kuActions-              && all (\(i, j) -> not (i == j)) lNews-              && notOccursIn (standardActionAtoms)-              && notOccursIn (get sLastAtom)-              && notOccursIn (get sEdges)--        return $ modify sLessAtoms ( (`S.union` S.fromList lNews)-                                   . (`S.difference` S.fromList lIns)-                                   . (`S.difference` S.fromList lOuts)-                                   )-               $ modify sGoals (\m -> foldl' removeAction m kuActions)-               $ se-      where-        kuActions            = [ x | x@(i,_,_) <- kuActionAtoms se, i == v ]-        eligibleTerm (_,_,m) =-            isPair m || isInverse m || sortOfLNTerm m == LSortPub--        removeAction m (i, fa, _) = M.delete (ActionG i fa) m--        lIns  = selectPart sLessAtoms ((v ==) . snd)-        lOuts = selectPart sLessAtoms ((v ==) . fst)-        lNews = [ (i, j) | (i, _) <- lIns, (_, j) <- lOuts ]--    -- hide a rule, if it is not "too complicated"-    hideRule ru = do-        guard $  eligibleRule-              && ( length eIns  == length (get rPrems ru) )-              && ( length eOuts == length (get rConcs ru) )-              && ( all (not . selfEdge) eNews             )-              && notOccursIn (get sLastAtom)-              && notOccursIn (get sLessAtoms)-              && notOccursIn (unsolvedActionAtoms)--        return $ modify sEdges ( (`S.union` S.fromList eNews)-                               . (`S.difference` S.fromList eIns)-                               . (`S.difference` S.fromList eOuts)-                               )-               $ modify sNodes (M.delete v)-               $ se-      where-        eIns  = selectPart sEdges ((v ==) . nodePremNode . eTgt)-        eOuts = selectPart sEdges ((v ==) . nodeConcNode . eSrc)-        eNews = [ Edge cIn pOut | Edge cIn _ <- eIns, Edge _ pOut <- eOuts ]--        selfEdge (Edge cIn pOut) = nodeConcNode cIn == nodePremNode pOut--        eligibleRule =-             any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule]-          || ( null (get rActs ru) &&-               all (\l -> length (get l ru) <= 1) [rPrems, rConcs]-             )--{---- | Try to hide a 'NodeId'. This only works if it has only action and either--- edge or less constraints associated.-tryHideNodeId :: NodeId -> System -> System--}-
− src/Theory/Constraint/System/Guarded.hs 
@@ -1,650 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeSynonymInstances       #-}--- |--- Copyright   : (c) 2011 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Guarded formulas.-module Theory.Constraint.System.Guarded (--  -- * Guarded formulas-    Guarded(..)-  , LGuarded-  , LNGuarded--  -- ** Smart constructors-  , gfalse-  , gtrue-  , gdisj-  , gconj-  , gex-  , gall-  , gnot-  , ginduct--  , formulaToGuarded-  , formulaToGuarded_--  -- ** Transformation-  , simplifyGuarded--  , mapGuardedAtoms--  -- ** Queries-  , isConjunction-  , isDisjunction-  , isAllGuarded-  , isExGuarded-  , isSafetyFormula--  , guardFactTags--  -- ** Conversions to non-bound representations-  , bvarToLVar-  , openGuarded--  -- ** Substitutions-  , substBound-  , substBoundAtom-  , substFree-  , substFreeAtom--  -- ** Pretty-printing-  , prettyGuarded--  ) where--import           Control.Applicative-import           Control.Arrow-import           Control.DeepSeq-import           Control.Monad.Error-import           Control.Monad.Fresh              (MonadFresh, scopeFreshness)-import qualified Control.Monad.Trans.PreciseFresh as Precise (Fresh, evalFresh, evalFreshT)--import           Debug.Trace--import           Data.Binary-import           Data.DeriveTH-import           Data.Either                      (partitionEithers)-import           Data.Foldable                    (Foldable(..), foldMap)-import           Data.List-import qualified Data.DList as D-import           Data.Monoid                      (Monoid(..))-import           Data.Traversable                 hiding (mapM, sequence)--import           Logic.Connectives--import           Text.PrettyPrint.Highlight--import           Theory.Model------------------------------------------------------------------------------------ Types---------------------------------------------------------------------------------data Guarded s c v = GAto  (Atom (VTerm c (BVar v)))-                   | GDisj (Disj (Guarded s c v))-                   | GConj (Conj (Guarded s c v))-                   | GGuarded Quantifier [s] [Atom (VTerm c (BVar v))] (Guarded s c v)-                    -- ^ Denotes @ALL xs. as => gf@ or @Ex xs. as & gf&-                    -- depending on the 'Quantifier'.-                    -- We assume that all bound variables xs occur in-                    -- f@i atoms in as.-                   deriving (Eq, Ord, Show)--isConjunction :: Guarded s c v -> Bool-isConjunction (GConj _)  = True-isConjunction _          = False--isDisjunction :: Guarded s c v -> Bool-isDisjunction (GDisj _)  = True-isDisjunction _          = False--isExGuarded :: Guarded s c v -> Bool-isExGuarded (GGuarded Ex _ _ _) = True-isExGuarded _                   = False--isAllGuarded :: Guarded s c v -> Bool-isAllGuarded (GGuarded All _ _ _) = True-isAllGuarded _                    = False---- | Check whether the guarded formula is closed and does not contain an--- existential quantifier. This under-approximates the question whether the--- formula is a safety formula. A safety formula @phi@ has the property that a--- trace violating it can never be extended to a trace satisfying it.-isSafetyFormula :: HasFrees (Guarded s c v) => Guarded s c v -> Bool-isSafetyFormula gf0 =-    null (frees [gf0]) && noExistential gf0-  where-    noExistential (GAto _ )             = True-    noExistential (GGuarded Ex _ _ _)   = False-    noExistential (GGuarded All _ _ gf) = noExistential gf-    noExistential (GDisj disj)          = all noExistential $ getDisj disj-    noExistential (GConj conj)          = all noExistential $ getConj conj---- | All 'FactTag's that are used in guards.-guardFactTags :: Guarded s c v -> [FactTag]-guardFactTags =-    D.toList .-    foldGuarded mempty (mconcat . getDisj) (mconcat . getConj) getTags-  where-    getTags _qua _ss atos inner =-        mconcat [ D.singleton tag | Action _ (Fact tag _) <- atos ] <> inner----------------------------------------------------------------------------------- Folding------------------------------------------------------------------------------------ | Fold a guarded formula.-foldGuarded :: (Atom (VTerm c (BVar v)) -> b)-            -> (Disj b -> b)-            -> (Conj b -> b)-            -> (Quantifier -> [s] -> [Atom (VTerm c (BVar v))] -> b -> b)-            -> Guarded s c v-            -> b-foldGuarded fAto fDisj fConj fGuarded =-  go- where-  go (GAto a)                = fAto a-  go (GDisj disj)            = fDisj $ fmap go disj-  go (GConj conj)            = fConj $ fmap go conj-  go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf)---- | Fold a guarded formula with scope info.--- The Integer argument denotes the number of--- quantifiers that have been encountered so far.-foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b)-                 -> (Disj b -> b)-                 -> (Conj b -> b)-                 -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b)-                 -> Guarded s c v-                 -> b-foldGuardedScope fAto fDisj fConj fGuarded =-  go 0- where-  go !i (GAto a)            = fAto i a-  go !i (GDisj disj)        = fDisj $ fmap (go i) disj-  go !i (GConj conj)        = fConj $ fmap (go i) conj-  go !i (GGuarded qua ss as gf) =-    fGuarded qua ss i' as (go i' gf)-   where-    i' = i + fromIntegral (length ss)----- | Map a guarded formula with scope info.--- The Integer argument denotes the number of--- quantifiers that have been encountered so far.-mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v))-                -> Atom (VTerm d (BVar w)))-                -> Guarded s c v-                -> Guarded s d w-mapGuardedAtoms f =-    foldGuardedScope (\i a -> GAto $ f i a) GDisj GConj-                     (\qua ss i as gf -> GGuarded qua ss (map (f i) as) gf)----------------------------------------------------------------------------------- Instances---------------------------------------------------------------------------------{--instance Functor (Guarded s c) where-    fmap f = foldGuarded (GAto . fmap (fmapTerm (fmap (fmap f)))) GDisj GConj-                         (\qua ss as gf -> GGuarded qua ss (map (fmap (fmapTerm (fmap (fmap f)))) as) gf)--}--instance Foldable (Guarded s c) where-    foldMap f = foldGuarded (foldMap (foldMap (foldMap (foldMap f))))-                            (mconcat . getDisj)-                            (mconcat . getConj)-                            (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b)--traverseGuarded :: (Applicative f, Ord c, Ord v, Ord a)-                => (a -> f v) -> Guarded s c a -> f (Guarded s c v)-traverseGuarded f = foldGuarded (liftA GAto . traverse (traverseTerm (traverse (traverse f))))-                                (liftA GDisj . sequenceA)-                                (liftA GConj . sequenceA)-                                (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverseTerm (traverse (traverse f)))) as <*> gf)--instance Ord c => HasFrees (Guarded (String, LSort) c LVar) where-    foldFrees f = foldMap  (foldFrees f)-    mapFrees  f = traverseGuarded (mapFrees f)----- FIXME: remove name hints for variables for saturation?-type LGuarded c = Guarded (String, LSort) c LVar----------------------------------------------------------------------------------- Substitutions of bound for free and vice versa----------------------------------------------------------------------------------- | @substBoundAtom s a@ substitutes each occurence of a bound variables @i@--- in @dom(s)@ with the corresponding free variable @x=s(i)@ in the atom @a@.-substBoundAtom :: Ord c => [(Integer,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))-substBoundAtom s = fmap (fmapTerm (fmap subst))- where subst bv@(Bound i') = case lookup i' s of-                               Just x -> Free x-                               Nothing -> bv-       subst fv            = fv---- | @substBound s gf@ substitutes each occurence of a bound--- variable @i@ in @dom(s)@ with the corresponding free variable--- @s(i)=x@ in all atoms in @gf@.-substBound :: Ord c => [(Integer,LVar)] -> LGuarded c -> LGuarded c-substBound s = mapGuardedAtoms (\j a -> substBoundAtom [(i+j,v) | (i,v) <- s] a)----- | @substFreeAtom s a@ substitutes each occurence of a free variables @v@--- in @dom(s)@ with the bound variables @i=s(v)@ in the atom @a@.-substFreeAtom :: Ord c-              => [(LVar,Integer)]-              -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))-substFreeAtom s = fmap (fmapTerm (fmap subst))- where subst fv@(Free x) = case lookup x s of-                               Just i -> Bound i-                               Nothing -> fv-       subst bv          = bv---- | @substFreeAtom s gf@ substitutes each occurence of a free variables--- @v in dom(s)@ with the correpsonding bound variables @i=s(v)@--- in all atoms in  @gf@.-substFree :: Ord c => [(LVar,Integer)] -> LGuarded c -> LGuarded c-substFree s = mapGuardedAtoms (\j a -> substFreeAtom [(v,i+j) | (v,i) <- s] a)---- | Assuming that there are no more bound variables left in an atom of a--- formula, convert it to an atom with free variables only.-bvarToLVar :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar)-bvarToLVar =-    fmap (fmapTerm (fmap (foldBVar boundError id)))-  where-    boundError v = error $ "bvarToLVar: left-over bound variable '"-                           ++ show v ++ "'"---- | Provided an 'Atom' does not contain a bound variable, it is converted to--- the type of atoms without bound varaibles.-unbindAtom :: (Ord c, Ord v) => Atom (VTerm c (BVar v)) -> Maybe (Atom (VTerm c v))-unbindAtom = traverse (traverseTerm (traverse (foldBVar (const Nothing) Just)))------------------------------------------------------------------------------------ Opening and Closing----------------------------------------------------------------------------------- | @openGuarded gf@ returns @Just (qua,vs,ats,gf')@ if @gf@ is a guarded--- clause and @Nothing@ otherwise. In the first case, @quao@ is the quantifier,--- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is the--- succedent. In both antecedent and succedent, the bound variables are--- replaced by @vs@.-openGuarded :: (Ord c, MonadFresh m)-            => LGuarded c -> m (Maybe (Quantifier, [LVar], [Atom (VTerm c LVar)], LGuarded c))-openGuarded (GGuarded qua vs as gf) = do-    xs <- mapM (\(n,s) -> freshLVar n s) vs-    return $ Just (qua, xs, openas xs, opengf xs)-  where-    openas xs = map (bvarToLVar . substBoundAtom (subst xs)) as-    opengf xs = substBound (subst xs) gf-    subst xs  = zip [0..] (reverse xs)-openGuarded _ = return Nothing---- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@.-closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)]-             -> LGuarded c -> LGuarded c-closeGuarded qua vs as gf =-   (case qua of Ex -> gex; All -> gall) vs' as' gf'- where-   as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as-   gf' = substFree s gf-   s   = zip (reverse vs) [0..]-   vs' = map (lvarName &&& lvarSort) vs------------------------------------------------------------------------------------ Conversion and negation---------------------------------------------------------------------------------type LNGuarded = Guarded (String,LSort) Name LVar--instance Apply LNGuarded where-  apply subst = mapGuardedAtoms (const $ apply subst)----- | @gtf b@ returns the guarded formula f with @b <-> f@.-gtf :: Bool -> Guarded s c v-gtf False = GDisj (Disj [])-gtf True  = GConj (Conj [])---- | @gfalse@ returns the guarded formula f with @False <-> f@.-gfalse :: Guarded s c v-gfalse = gtf False---- | @gtrue@ returns the guarded formula f with @True <-> f@.-gtrue :: Guarded s c v-gtrue = gtf True---- | @gnotAtom a@ returns the guarded formula f with @not a <-> f@.-gnotAtom :: Atom (VTerm c (BVar v)) -> Guarded s c v-gnotAtom a  = GGuarded All [] [a] gfalse---- | @gconj gfs@ smart constructor for the conjunction of gfs.-gconj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v-gconj gfs0 = case concatMap flatten gfs0 of-    [gf]                      -> gf-    gfs | any (gfalse ==) gfs -> gfalse-        -- FIXME: See 'sortednub' below.-        | otherwise           -> GConj $ Conj $ nub gfs-  where-    flatten (GConj conj) = concatMap flatten $ getConj conj-    flatten gf           = [gf]---- | @gdisj gfs@ smart constructor for the disjunction of gfs.-gdisj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v-gdisj gfs0 = case concatMap flatten gfs0 of-    [gf]                     -> gf-    gfs | any (gtrue ==) gfs -> gtrue-        -- FIXME: Consider using 'sortednub' here. This yields stronger-        -- normalizaton for formulas. However, it also means that we loose-        -- invariance under renaming free variables, as the order changes,-        -- when they are renamed.-        | otherwise          -> GDisj $ Disj $ nub gfs-  where-    flatten (GDisj disj) = concatMap flatten $ getDisj disj-    flatten gf           = [gf]---- @ A smart constructor for @GGuarded Ex@ that removes empty quantifications--- and conjunctions with 'gfalse'.-gex :: (Ord s, Ord c, Ord v)-    => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v-gex [] as gf                = gconj (map GAto as ++ [gf])-gex _  _  gf | gf == gfalse = gfalse-gex ss as gf                = GGuarded Ex ss as gf---- @ A smart constructor for @GGuarded All@ that drops implications to 'gtrue'--- and removes empty premises.-gall :: (Eq s, Eq c, Eq v)-     => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v-gall _  []   gf               = gf-gall _  _    gf | gf == gtrue = gtrue-gall ss atos gf               = GGuarded All ss atos gf----- Conversion of formulas to guarded formulas-------------------------------------------------- | Local newtype to avoid orphan instance.-newtype ErrorDoc d = ErrorDoc { unErrorDoc :: d }-    deriving( Monoid, NFData, Document, HighlightDocument )--instance Document d => Error (ErrorDoc d) where-    noMsg  = emptyDoc-    strMsg = text----- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is--- equivalent to @fm@ under the assumption that this is possible.--- If not, then 'error' is called.-formulaToGuarded_ :: LNFormula  -> LNGuarded-formulaToGuarded_ = either (error . render) id . formulaToGuarded---- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is--- equivalent to @fm@ if possible.-formulaToGuarded :: HighlightDocument d => LNFormula  -> Either d LNGuarded-formulaToGuarded fmOrig =-      either (Left . ppError . unErrorDoc) Right-    $ Precise.evalFreshT (convert False fmOrig) (avoidPrecise fmOrig)-  where-    ppFormula :: HighlightDocument a => LNFormula -> a-    ppFormula = nest 2 . doubleQuotes . prettyLNFormula--    ppError d = d $-$ text "in the formula" $-$ ppFormula fmOrig--    convert True  (Ato a) = pure $ gnotAtom a-    convert False (Ato a) = pure $ GAto a--    convert polarity (Not f) = convert (not polarity) f--    convert True  (Conn And f g) = gdisj <$> mapM (convert True)  [f, g]-    convert False (Conn And f g) = gconj <$> mapM (convert False) [f, g]--    convert True  (Conn Or f g)  = gconj <$> mapM (convert True)  [f, g]-    convert False (Conn Or f g)  = gdisj <$> mapM (convert False) [f, g]--    convert True  (Conn Imp f g         ) =-        gconj <$> sequence [convert False f, convert True  g]-    convert False (Conn Imp f g         ) =-        gdisj <$> sequence [convert True  f, convert False g]--    convert polarity    (TF b) = pure $ gtf (polarity /= b)--    convert polarity f0@(Qua qua0 _ _) =-        -- The quantifier switch stems from our implicit negation of the formula.-        case (qua0, polarity) of-          (All, True ) -> convAll Ex-          (All, False) -> convAll All-          (Ex,  True ) -> convEx  All-          (Ex,  False) -> convEx  Ex-      where-        noUnguardedVars []        = return ()-        noUnguardedVars unguarded = throwError $ vcat-          [ fsep $   text "unguarded variable(s)"-                   : (punctuate comma $-                      map (quotes . text . show) unguarded)-                  ++ map text ["in", "the", "subformula"]-          , ppFormula f0-          ]--        conjActions (Conn And f1 f2)     = conjActions f1 ++ conjActions f2-        conjActions (Ato a@(Action _ _)) = [Left $ bvarToLVar a]-        conjActions f                    = [Right f]--        convEx qua = do-            (xs,_,f) <- openFormulaPrefix f0-            case partitionEithers $ conjActions f of-              (as, fs) -> do-                -- all existentially quantified variables must be guarded-                noUnguardedVars (xs \\ frees as)-                -- convert all other formulas-                gf <- (if polarity then gdisj else gconj)-                        <$> mapM (convert polarity) fs-                return $ closeGuarded qua xs as gf-          where--        convAll qua = do-            (xs,_,f) <- openFormulaPrefix f0-            case f of-              Conn Imp ante suc -> case partitionEithers $ conjActions ante of-                (as, fs) -> do-                  -- all universally quantified variables must be guarded-                  noUnguardedVars (xs \\ frees as)-                  -- negate formulas in antecedent and combine with body-                  gf <- (if polarity then gconj else gdisj)-                          <$> sequence ( map (convert (not polarity)) fs ++-                                         [convert polarity suc] )--                  return $ closeGuarded qua xs as gf--              _ -> throwError $-                     text "universal quantifier without toplevel implication" $-$-                     ppFormula f0--    convert polarity (Conn Iff f1 f2) =-        gconj <$> mapM (convert polarity) [Conn Imp f1 f2, Conn Imp f2 f1]------------------------------------------------------------------------------------ Induction over the trace----------------------------------------------------------------------------------- | Negate a guarded formula.-gnot :: (Ord s, Ord c, Ord v)-              => Guarded s c v -> Guarded s c v-gnot =-    go-  where-    go (GGuarded All ss as gf) = gex  ss as $ go gf-    go (GGuarded Ex ss as gf)  = gall ss as $ go gf-    go (GAto ato)              = gnotAtom ato-    go (GDisj disj)            = gconj $ map go (getDisj disj)-    go (GConj conj)            = gdisj $ map go (getConj conj)----- | Checks if a doubly guarded formula is satisfied by the empty trace;--- returns @'Left' errMsg@ if the formula is not doubly guarded.-satisfiedByEmptyTrace :: Guarded s c v -> Either String Bool-satisfiedByEmptyTrace =-  foldGuarded-    (\_ato -> throwError "atom outside the scope of a quantifier")-    (liftM or  . sequence . getDisj)-    (liftM and . sequence . getConj)-    (\qua _ss _as _gf -> return $ qua == All)-    -- the empty trace always satisfies guarded all-quantification-    -- and always dissatisfies guarded ex-quantification---- | Tries to convert a doubly guarded formula to an induction hypothesis.--- Returns @'Left' errMsg@ if the formula is not last-free or not doubly--- guarded.-toInductionHypothesis :: Ord c => LGuarded c -> Either String (LGuarded c)-toInductionHypothesis =-    go-  where-    go (GGuarded qua ss as gf)-      | any isLastAtom as = throwError "formula not last-free"-      | otherwise         = do-          gf' <- go gf-          return $ case qua of-            All -> gex  ss as (gconj $ (gnotAtom <$> lastAtos) ++ [gf'])-            Ex  -> gall ss as (gdisj $ (GAto <$> lastAtos) ++ [gf'])-      where-        lastAtos :: [Atom (VTerm c (BVar LVar))]-        lastAtos = do-            (j, (_, LSortNode)) <- zip [0..] $ reverse ss-            return $ Last (varTerm (Bound j))--    go (GAto (Less i j)) = return $ gdisj [GAto (EqE i j), GAto (Less j i)]-    go (GAto (Last _))   = throwError "formula not last-free"-    go (GAto ato)        = return $ gnotAtom ato-    go (GDisj disj)      = gconj <$> traverse go (getDisj disj)-    go (GConj conj)      = gdisj <$> traverse go (getConj conj)---- | Try to prove the formula by applying induction over the trace.--- Returns @'Left' errMsg@ if this is not possible. Returns a tuple of--- formulas: one formalzing the proof obligation of the base-case and one--- formalizing the proof obligation of the step-case.-ginduct :: Ord c => LGuarded c -> Either String (LGuarded c, LGuarded c)-ginduct gf = do-    unless (null $ frees gf)   (throwError "formula not closed")-    unless (containsAction gf) (throwError "formula contains no action atom")-    baseCase <- satisfiedByEmptyTrace gf-    gfIH     <- toInductionHypothesis gf-    return (gtf baseCase, gconj [gf, gfIH])-  where-    containsAction = foldGuarded (const True) (or . getDisj) (or . getConj)-                                 (\_ _ as body -> not (null as) || body)----------------------------------------------------------------------------------- Formula Simplification----------------------------------------------------------------------------------- | Simplify a 'Guarded' formula by replacing atoms with their truth value,--- if it can be determined.-simplifyGuarded :: (LNAtom -> Maybe Bool)-                -- ^ Partial assignment for truth value of atoms.-                -> LNGuarded-                -- ^ Original formula-                -> Maybe LNGuarded-                -- ^ Simplified formula, provided some simplification was-                -- performed.-simplifyGuarded valuation fm0-    | fm1 /= fm0 = trace (render ppMsg) (Just fm1)-    | otherwise  = Nothing-  where-    ppFm  = nest 2 . doubleQuotes . prettyGuarded-    ppMsg = nest 2 $ text "simplified formula:" $-$-                     nest 2 (vcat [ ppFm fm0, text "to", ppFm fm1])--    fm1 = simp fm0--    simp fm@(GAto ato)         = maybe fm gtf (valuation =<< unbindAtom ato)-    simp (GDisj fms)           = gdisj $ map simp $ getDisj fms-    simp (GConj fms)           = gconj $ map simp $ getConj fms-    simp (GGuarded All [] atos gf)-      | any ((Just False ==) . snd) annAtos = gtrue-      | otherwise                           =-          -- keep all atoms that we cannot evaluate yet.-          -- NOTE: Here we are missing the opportunity to change the valuation-          -- for evaluating the body 'gf'. We could add all atoms that we have-          -- as a premise.-          gall [] (fst <$> filter ((Nothing ==) . snd) annAtos) (simp gf)-      where-        -- cache the possibly expensive evaluation of the valuation-        annAtos = (\x -> (x, valuation =<< unbindAtom x)) <$> atos--    -- Note that existentials without quantifiers are already eliminated by-    -- 'gex'. Moreover, we dealay simplification inside guarded all-    -- quantification and guarded existential quantifiers. Their body will be-    -- simplified once the quantifiers are gone.-    simp fm@(GGuarded _ _ _ _) = fm------------------------------------------------------------------------------------ Pretty Printing----------------------------------------------------------------------------------- | Pretty print a formula.-prettyGuarded :: HighlightDocument d-              => LNGuarded      -- ^ Guarded Formula.-              -> d              -- ^ Pretty printed formula.-prettyGuarded fm =-    Precise.evalFresh (pp fm) (avoidPrecise fm)-  where-    pp :: HighlightDocument d => LNGuarded -> Precise.Fresh d-    pp (GAto a) = return $ prettyNAtom $ bvarToLVar a--    pp (GDisj (Disj [])) = return $ operator_  "⊥"  -- "F"--    pp (GDisj (Disj xs)) = do-        ps <- mapM (\x -> opParens <$> pp x) xs-        return $ sep $ punctuate (operator_ " ∨") ps-        -- return $ sep $ punctuate (operator_ " |") ps--    pp (GConj (Conj [])) = return $ operator_ "⊤"  -- "T"--    pp (GConj (Conj xs)) = do-        ps <- mapM (\x -> opParens <$> pp x) xs-        return $ sep $ punctuate (operator_ " ∧") ps --- " &") ps--    pp gf0@(GGuarded _ _ _ _) =-      -- variable names invented here can be reused otherwise-      scopeFreshness $ do-          Just (qua, vs, atoms, gf) <- openGuarded gf0-          let antecedent = (GAto . fmap (fmapTerm (fmap Free))) <$> atoms-              connective = operator_ (case qua of All -> "⇒"; Ex -> "∧")-                            -- operator_ (case qua of All -> "==>"; Ex -> "&")-              quantifier = operator_ (ppQuant qua) <-> ppVars vs <> operator_ "."-          dante <- nest 1 <$> pp (GConj (Conj antecedent))-          case (qua, vs, gf) of-            (Ex,  _,  GConj (Conj [])) ->-                return $ sep $ [ quantifier, dante ]-            (All, [], GDisj (Disj [])) | gf == gfalse ->-                return $ operator_ "¬" <> dante-            _  -> do-                dsucc <- nest 1 <$> pp gf-                return $ sep [ quantifier, sep [dante, connective, dsucc] ]-      where-        ppVars      = fsep . map (text . show)-        ppQuant All = "∀"  -- "All "-        ppQuant Ex  = "∃"  -- "Ex "----- Derived instances-----------------------$( derive makeBinary ''Guarded)-$( derive makeNFData ''Guarded)
− src/Theory/Model.hs 
@@ -1,25 +0,0 @@--- |--- Copyright   : (c) 2011-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Security protocol model.-module Theory.Model (-    module Term.Unification-  , module Theory.Model.Atom-  , module Theory.Model.Fact-  , module Theory.Model.Formula-  , module Theory.Model.Rule-  , module Theory.Model.Signature-  )-  where--import           Term.LTerm-import           Term.Unification-import           Theory.Model.Atom-import           Theory.Model.Fact-import           Theory.Model.Formula-import           Theory.Model.Rule-import           Theory.Model.Signature
− src/Theory/Model/Atom.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE DeriveDataTypeable   #-}--- {-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}--- {-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}--- {-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns         #-}--- {-# OPTIONS_GHC -fno-warn-orphans #-}--- {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-  -- spurious warnings for view patterns--- |--- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Formulas that represent security properties.-module Theory.Model.Atom(--  -- * Atoms-    Atom(..)-  , NAtom-  , LNAtom--  , isActionAtom-  , isLastAtom-  , isLessAtom-  , isEqAtom--  -- * LFormula-  , BLAtom--  -- * Pretty-Printing-  , prettyNAtom-  )-where--import           Control.Basics-import           Control.DeepSeq--import           Data.Binary-import           Data.DeriveTH-import           Data.Foldable      (Foldable, foldMap)-import           Data.Generics-import           Data.Monoid        (mappend)-import           Data.Traversable--import           Term.LTerm-import           Term.Unification-import           Theory.Model.Fact-import           Theory.Text.Pretty------------------------------------------------------------------------------------ Atoms----------------------------------------------------------------------------------- | @Atom@'s are the atoms of trace formulas parametrized over arbitrary--- terms.-data Atom t = Action   t (Fact t)-            | EqE  t t-            | Less t t-            | Last t-            deriving( Eq, Ord, Show, Data, Typeable )---- | @LAtom@ are the atoms we actually use in graph formulas input by the user.-type NAtom v = Atom (VTerm Name v)---- | @LAtom@ are the atoms we actually use in graph formulas input by the user.-type LNAtom = Atom LNTerm---- | Atoms built over 'BLTerm's.-type BLAtom = Atom BLTerm----- Instances---------------instance Functor Atom where-    fmap f (Action   i fa) = Action    (f i) (fmap f fa)-    fmap f (EqE l r)       = EqE       (f l) (f r)-    fmap f (Less v u)      = Less      (f v) (f u)-    fmap f (Last i)        = Last      (f i)--instance Foldable Atom where-    foldMap f (Action i fa)   =-        f i `mappend` (foldMap f fa)-    foldMap f (EqE l r)       = f l `mappend` f r-    foldMap f (Less i j)      = f i `mappend` f j-    foldMap f (Last i)        = f i--instance Traversable Atom where-    traverse f (Action i fa)   =-        Action <$> f i <*> traverse f fa-    traverse f (EqE l r)       = EqE <$> f l <*> f r-    traverse f (Less v u)      = Less <$> f v <*> f u-    traverse f (Last i)        = Last <$> f i--instance HasFrees t => HasFrees (Atom t) where-    foldFrees f = foldMap (foldFrees f)-    mapFrees  f = traverse (mapFrees f)--instance Apply LNAtom where-    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)-    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)-    apply subst (Less i j)        = Less (apply subst i) (apply subst j)-    apply subst (Last i)          = Last (apply subst i)--instance Apply BLAtom where-    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)-    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)-    apply subst (Less i j)        = Less (apply subst i) (apply subst j)-    apply subst (Last i)          = Last (apply subst i)----- Queries--------------- | True iff the atom is an action atom.-isActionAtom :: Atom t -> Bool-isActionAtom ato = case ato of Action _ _ -> True; _ -> False---- | True iff the atom is a last atom.-isLastAtom :: Atom t -> Bool-isLastAtom ato = case ato of Last _ -> True; _ -> False---- | True iff the atom is a temporal ordering atom.-isLessAtom :: Atom t -> Bool-isLessAtom ato = case ato of Less _ _ -> True; _ -> False---- | True iff the atom is an equality atom.-isEqAtom :: Atom t -> Bool-isEqAtom ato = case ato of EqE _ _ -> True; _ -> False------------------------------------------------------------------------------------ Pretty-Printing---------------------------------------------------------------------------------prettyNAtom :: (Show v, HighlightDocument d) => NAtom v -> d-prettyNAtom (Action v fa) =-    prettyFact prettyNTerm fa <-> opAction <-> text (show v)-prettyNAtom (EqE l r) =-    sep [prettyNTerm l <-> opEqual, prettyNTerm r]-    -- sep [prettyNTerm l <-> text "≈", prettyNTerm r]-prettyNAtom (Less u v) = text (show u) <-> opLess <-> text (show v)-prettyNAtom (Last i)   = operator_ "last" <> parens (text (show i))----- derived instances-----------------------$( derive makeNFData ''Atom)-$( derive makeBinary ''Atom)
− src/Theory/Model/Fact.hs 
@@ -1,353 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE ViewPatterns       #-}--- |--- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Facts used to formulate and reason about protocol execution.-module Theory.Model.Fact (--  -- * Fact-    Fact(..)-  , Multiplicity(..)-  , FactTag(..)--  , matchFact--  -- ** Queries-  , isLinearFact-  , isPersistentFact-  , isProtoFact--  , factTagName-  , showFactTag-  , showFactTagArity-  , factTagArity-  , factTagMultiplicity-  , factArity-  , factMultiplicity--  , DirTag(..)-  , kuFact-  , kdFact-  , kFactView-  , dedFactView--  , isKFact-  , isKUFact-  , isKDFact--  -- ** Construction-  , freshFact-  , outFact-  , inFact-  , kLogFact-  , dedLogFact-  , protoFact--  -- * NFact-  , NFact--  -- * LFact-  , LFact-  , LNFact-  , unifyLNFactEqs-  , unifiableLNFacts--  -- * Pretty-Printing--  , prettyFact-  , prettyNFact-  , prettyLNFact--  ) where--import           Control.Basics-import           Control.DeepSeq--import           Data.Binary-import           Data.DeriveTH-import           Data.Foldable          (Foldable(..))-import           Data.Generics-import           Data.Maybe             (isJust)-import           Data.Monoid-import           Data.Traversable       (Traversable(..))--import           Term.Unification--import           Text.PrettyPrint.Class------------------------------------------------------------------------------------ Fact---------------------------------------------------------------------------------data Multiplicity = Persistent | Linear-                  deriving( Eq, Ord, Show, Typeable, Data )---- | Fact tags/symbols-data FactTag = ProtoFact Multiplicity String Int-               -- ^ A protocol fact together with its arity and multiplicity.-             | FreshFact  -- ^ Freshly generated value.-             | OutFact    -- ^ Sent by the protocol-             | InFact     -- ^ Officially known by the intruder/network.-             | KUFact     -- ^ Up-knowledge fact in messsage deduction.-             | KDFact     -- ^ Down-knowledge fact in message deduction.-             | DedFact    -- ^ Log-fact denoting that the intruder deduced-                          -- a message using a construction rule.-    deriving( Eq, Ord, Show, Typeable, Data )---- | Facts.-data Fact t = Fact-    { factTag   :: FactTag-    , factTerms :: [t]-    }-    deriving( Eq, Ord, Show, Typeable, Data )----- Instances---------------instance Functor Fact where-    fmap f (Fact tag ts) = Fact tag (fmap f ts)--instance Foldable Fact where-    foldMap f (Fact _ ts) = foldMap f ts--instance Traversable Fact where-    sequenceA (Fact tag ts) = Fact tag <$> sequenceA ts-    traverse f (Fact tag ts) = Fact tag <$> traverse f ts--instance Sized t => Sized (Fact t) where-  size (Fact _ args) = size args--instance HasFrees t => HasFrees (Fact t) where-    foldFrees  f = foldMap  (foldFrees f)-    mapFrees   f = traverse (mapFrees f)--instance Apply t => Apply (Fact t) where-    apply subst = fmap (apply subst)----- KU and KD facts----------------------- | A direction tag-data DirTag = UpK | DnK-            deriving( Eq, Ord, Show )--kdFact, kuFact :: t -> Fact t-kdFact = Fact KDFact . return-kuFact = Fact KUFact . return---- | View a message-deduction fact.-kFactView :: LNFact -> Maybe (DirTag, LNTerm)-kFactView fa = case fa of-    Fact KUFact [m] -> Just (UpK, m)-    Fact KUFact _   -> errMalformed "kFactView" fa-    Fact KDFact [m] -> Just (DnK, m)-    Fact KDFact _   -> errMalformed "kFactView" fa-    _               -> Nothing---- | View a deduction logging fact.-dedFactView :: LNFact -> Maybe LNTerm-dedFactView fa = case fa of-    Fact DedFact [m] -> Just m-    Fact DedFact _   -> errMalformed "dedFactView" fa-    _                -> Nothing---- | True if the fact is a message-deduction fact.-isKFact :: LNFact -> Bool-isKFact = isJust . kFactView---- | True if the fact is a KU-fact.-isKUFact :: LNFact -> Bool-isKUFact (Fact KUFact _) = True-isKUFact _               = False---- | True if the fact is a KD-fact.-isKDFact :: LNFact -> Bool-isKDFact (Fact KDFact _) = True-isKDFact _               = False---- | Mark a fact as malformed.-errMalformed :: String -> LNFact -> a-errMalformed caller fa =-    error $ caller ++ show ": malformed fact: " ++ show fa---- Constructing facts-------------------------- | A fact denoting a message sent by the protocol to the intruder.-outFact :: t -> Fact t-outFact = Fact OutFact . return---- | A fresh fact denotes a fresh unguessable name.-freshFact :: t -> Fact t-freshFact = Fact FreshFact . return---- | A fact denoting that the intruder sent a message to the protocol.-inFact :: t -> Fact t-inFact = Fact InFact . return---- | A fact logging that the intruder knows a message.-kLogFact :: t -> Fact t-kLogFact = protoFact Linear "K" . return---- | A fact logging that the intruder deduced a message using a construction--- rule. We use this to formulate invariants over normal dependency graphs.-dedLogFact :: t -> Fact t-dedLogFact = Fact DedFact . return---- | A protocol fact denotes a fact generated by a protocol rule.-protoFact :: Multiplicity -> String -> [t] -> Fact t-protoFact multi name ts = Fact (ProtoFact multi name (length ts)) ts----- Queries on facts------------------------ | True iff the fact is a non-special protocol fact.-isProtoFact :: Fact t -> Bool-isProtoFact (Fact (ProtoFact _ _ _) _) = True-isProtoFact _                          = False---- | True if the fact is a linear fact.-isLinearFact :: Fact t -> Bool-isLinearFact = (Linear ==) . factMultiplicity---- | True if the fact is a persistent fact.-isPersistentFact :: Fact t -> Bool-isPersistentFact = (Persistent ==) . factMultiplicity---- | The multiplicity of a 'FactTag'.-factTagMultiplicity :: FactTag -> Multiplicity-factTagMultiplicity tag = case tag of-    ProtoFact multi _ _ -> multi-    KUFact              -> Persistent-    KDFact              -> Persistent-    _                   -> Linear---- | The arity of a 'FactTag'.-factTagArity :: FactTag -> Int-factTagArity tag = case  tag of-    ProtoFact _ _ k -> k-    KUFact          -> 1-    KDFact          -> 1-    DedFact         -> 1-    FreshFact       -> 1-    InFact          -> 1-    OutFact         -> 1---- | The arity of a 'Fact'.-factArity :: Fact t -> Int-factArity (Fact tag ts)-  | length ts == k = k-  | otherwise      = error $ "factArity: tag of arity " ++ show k ++-                             " applied to " ++ show (length ts) ++ " terms"-  where-    k = factTagArity tag---- | The multiplicity of a 'Fact'.-factMultiplicity :: Fact t -> Multiplicity-factMultiplicity = factTagMultiplicity . factTag------------------------------------------------------------------------------------ NFact----------------------------------------------------------------------------------- | Facts with literals containing names and arbitrary variables.-type NFact v = Fact (NTerm v)------------------------------------------------------------------------------------ LFact----------------------------------------------------------------------------------- | Facts with literals arbitrary constants and logical variables.-type LFact c = Fact (LTerm c)---- | Facts used for proving; i.e. variables fixed to logical variables--- and constant fixed to names.-type LNFact = Fact LNTerm---- | Unify a list of @LFact@ equalities.-unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh]-unifyLNFactEqs eqs-  | all (evalEqual . fmap factTag) eqs =-      unifyLNTerm (map (fmap (fAppList . factTerms)) eqs)-  | otherwise = return []---- | 'True' iff the two facts are unifiable.-unifiableLNFacts :: LNFact -> LNFact -> WithMaude Bool-unifiableLNFacts fa1 fa2 = (not . null) <$> unifyLNFactEqs [Equal fa1 fa2]---- | @matchLFact t p@ is a complete set of AC matchers for the term fact @t@--- and the pattern fact @p@.-matchFact :: Fact t -- ^ Term-            -> Fact t -- ^ Pattern-            -> Match t-matchFact t p =-    matchOnlyIf (factTag t == factTag p &&-                 length (factTerms t) == length (factTerms p))-    <> mconcat (zipWith matchWith (factTerms t) (factTerms p))----------------------------------------------------------------------------------- Pretty Printing----------------------------------------------------------------------------------- | The name of a fact tag, e.g., @factTagName KUFact = "KU"@.-factTagName :: FactTag -> String-factTagName tag = case tag of-    KUFact            -> "KU"-    KDFact            -> "KD"-    DedFact           -> "Ded"-    InFact            -> "In"-    OutFact           -> "Out"-    FreshFact         -> "Fr"-    (ProtoFact _ n _) -> n---- | Show a fact tag as a 'String'. This is the 'factTagName' prefixed with--- the multiplicity.-showFactTag :: FactTag -> String-showFactTag tag =-    (++ factTagName tag) $ case factTagMultiplicity tag of-                             Linear     -> ""-                             Persistent -> "!"---- | Show a fact tag together with its aritiy.-showFactTagArity :: FactTag -> String-showFactTagArity tag = showFactTag tag ++ "/" ++ show (factTagArity tag)---- | Pretty print a fact.-prettyFact :: Document d => (t -> d) -> Fact t -> d-prettyFact ppTerm (Fact tag ts)-  | factTagArity tag /= length ts = ppFact ("MALFORMED-" ++ show tag) ts-  | otherwise                     = ppFact (showFactTag tag) ts-  where-    ppFact n = nestShort' (n ++ "(") ")" . fsep . punctuate comma . map ppTerm---- | Pretty print a 'NFact'.-prettyNFact :: Document d => LNFact -> d-prettyNFact = prettyFact prettyNTerm---- | Pretty print a 'LFact'.-prettyLNFact :: Document d => LNFact -> d-prettyLNFact fa = prettyFact prettyNTerm fa---- derived instances-----------------------$( derive makeBinary ''Multiplicity)-$( derive makeBinary ''FactTag)-$( derive makeBinary ''Fact)--$( derive makeNFData ''Multiplicity)-$( derive makeNFData ''FactTag)-$( derive makeNFData ''Fact)
− src/Theory/Model/Formula.hs 
@@ -1,324 +0,0 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns         #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Types and operations for handling sorted first-order logic-module Theory.Model.Formula (--   -- * Formulas-    Connective(..)-  , Quantifier(..)-  , Formula(..)-  , LNFormula-  , LFormula--  , quantify-  , openFormula-  , openFormulaPrefix---  , unquantify--  -- ** More convenient constructors-  , lfalse-  , ltrue-  , (.&&.)-  , (.||.)-  , (.==>.)-  , (.<=>.)-  , exists-  , forall--  -- ** General Transformations-  , mapAtoms-  , foldFormula--  -- ** Pretty-Printing-  , prettyLNFormula--  ) where--import           Prelude                          hiding (negate)--import           Data.Binary-import           Data.DeriveTH-import           Data.Foldable                    (Foldable, foldMap)-import           Data.Generics-import           Data.Monoid                      hiding (All)-import           Data.Traversable--import           Control.Basics-import           Control.DeepSeq-import           Control.Monad.Fresh-import qualified Control.Monad.Trans.PreciseFresh as Precise--import           Theory.Model.Atom--import           Text.PrettyPrint.Highlight--import           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' <-> operator_ (ppOp op), opParens q']-      where-        ppOp And = "∧" -- "&"-        ppOp Or  = "∨" -- "|"-        ppOp Imp = "⇒" -- "==>"-        ppOp Iff = "⇔" -- "<=>"--    pp fm@(Qua _ _ _) =-        scopeFreshness $ do-            (vs,qua,fm') <- openFormulaPrefix fm-            d' <- pp fm'-            return $ sep-                     [ operator_ (ppQuant qua) <> ppVars vs <> operator_ "."-                     , nest 1 d']-      where-        ppVars       = fsep . map (text . show)--        ppQuant All = "∀ " -- "All "-        ppQuant Ex  = "∃ " -- "Ex "----- | Pretty print a logical formula-prettyLNFormula :: HighlightDocument d => LNFormula -> d-prettyLNFormula fm =-    Precise.evalFresh (prettyLFormula prettyNAtom fm) (avoidPrecise fm)----- Derived instances-----------------------$( derive makeBinary ''Connective)-$( derive makeBinary ''Quantifier)-$( derive makeBinary ''Formula)--$( derive makeNFData ''Connective)-$( derive makeNFData ''Quantifier)-$( derive makeNFData ''Formula)
− src/Theory/Model/Rule.hs 
@@ -1,632 +0,0 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeSynonymInstances       #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Rewriting rules representing protocol execution and intruder deduction. Once--- modulo the full Diffie-Hellman equational theory and once modulo AC.-module Theory.Model.Rule (-  -- * General Rules-    Rule(..)-  , PremIdx(..)-  , ConcIdx(..)--  -- ** Accessors-  , rInfo-  , rPrems-  , rConcs-  , rActs-  , rPrem-  , rConc-  , lookupPrem-  , lookupConc-  , enumPrems-  , enumConcs--  -- ** Genereal protocol and intruder rules-  , RuleInfo(..)-  , ruleInfo--  -- * Protocol Rule Information-  , ProtoRuleName(..)-  , ProtoRuleACInfo(..)-  , pracName-  , pracVariants-  , pracLoopBreakers-  , ProtoRuleACInstInfo(..)-  , praciName-  , praciLoopBreakers-  , RuleACConstrs--  -- * Intruder Rule Information-  , IntrRuleACInfo(..)--  -- * Concrete Rules-  , ProtoRuleE-  , ProtoRuleAC-  , IntrRuleAC-  , RuleAC-  , RuleACInst--  -- ** Queries-  , HasRuleName(..)-  , isIntruderRule-  , isDestrRule-  , isConstrRule-  , isFreshRule-  , isIRecvRule-  , isISendRule-  , isCoerceRule-  , nfRule-  , isTrivialProtoVariantAC--  -- ** Conversion-  , ruleACToIntrRuleAC-  , ruleACIntrToRuleAC--  -- ** Construction-  , someRuleACInst--  -- ** Unification-  , unifyRuleACInstEqs-  , unifiableRuleACInsts--  -- * Pretty-Printing-  , 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.-prefixIfReserved :: String -> String-prefixIfReserved n-  | n `elem` reserved  = "_" ++ n-  | "_" `isPrefixOf` n = "_" ++ n-  | otherwise          = n-  where-    reserved = ["Fresh", "irecv", "isend", "coerce", "fresh", "pub"]--prettyProtoRuleName :: Document d => ProtoRuleName -> d-prettyProtoRuleName rn = text $ case rn of-    FreshRule   -> "Fresh"-    StandRule n -> prefixIfReserved n--prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d-prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName---- | Pretty print the rule name such that it can be used as a case name-showRuleCaseName :: HasRuleName (Rule i) => Rule i -> String-showRuleCaseName =-    render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName--prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d-prettyIntrRuleACInfo rn = text $ case rn of-    IRecvRule       -> "irecv"-    ISendRule       -> "isend"-    CoerceRule      -> "coerce"-    FreshConstrRule -> "fresh"-    PubConstrRule   -> "pub"-    ConstrRule name -> prefixIfReserved ('c' : BC.unpack name)-    DestrRule name  -> prefixIfReserved ('d' : BC.unpack name)--prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i))-                => d           -- ^ Prefix.-                -> (i -> d)    -- ^ Rule info pretty printing.-                -> Rule i -> d-prettyNamedRule prefix ppInfo ru =-    prefix <-> prettyRuleName ru <> colon $-$-    nest 2 (sep [ nest 1 $ ppFactsList rPrems-                , if null (L.get rActs ru)-                    then operator_ "-->"-                    else fsep [operator_ "--[", ppFacts rActs, operator_ "]->"]-                , nest 1 $ ppFactsList rConcs]) $-$-    nest 2 (ppInfo $ L.get rInfo ru)-  where-    ppList pp        = fsep . punctuate comma . map pp-    ppFacts proj     = ppList prettyLNFact $ L.get proj ru-    ppFactsList proj = fsep [operator_ "[", ppFacts proj, operator_ "]"]--prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d-prettyProtoRuleACInfo i =-    (ppVariants $ L.get pracVariants i) $-$-    prettyLoopBreakers i-  where-    ppVariants (Disj [subst]) | subst == emptySubstVFresh = emptyDoc-    ppVariants substs = kwVariantsModulo "AC" $-$ prettyDisjLNSubstsVFresh substs--prettyLoopBreakers :: HighlightDocument d => ProtoRuleACInfo -> d-prettyLoopBreakers i = case breakers of-    []  -> emptyDoc-    [_] -> lineComment_ $ "loop breaker: "  ++ show breakers-    _   -> lineComment_ $ "loop breakers: " ++ show breakers-  where-    breakers = getPremIdx <$> L.get pracLoopBreakers i--prettyProtoRuleE :: HighlightDocument d => ProtoRuleE -> d-prettyProtoRuleE = prettyNamedRule (kwRuleModulo "E") (const emptyDoc)--prettyRuleAC :: HighlightDocument d => RuleAC -> d-prettyRuleAC =-    prettyNamedRule (kwRuleModulo "AC")-        (ruleInfo prettyProtoRuleACInfo (const emptyDoc))--prettyIntrRuleAC :: HighlightDocument d => IntrRuleAC -> d-prettyIntrRuleAC = prettyNamedRule (kwRuleModulo "AC") (const emptyDoc)--prettyProtoRuleAC :: HighlightDocument d => ProtoRuleAC -> d-prettyProtoRuleAC = prettyNamedRule (kwRuleModulo "AC") prettyProtoRuleACInfo--prettyRuleACInst :: HighlightDocument d => RuleACInst -> d-prettyRuleACInst = prettyNamedRule (kwInstanceModulo "AC") (const emptyDoc)---- derived instances-----------------------$( derive makeBinary ''Rule)-$( derive makeBinary ''ProtoRuleName)-$( derive makeBinary ''ProtoRuleACInfo)-$( derive makeBinary ''ProtoRuleACInstInfo)-$( derive makeBinary ''RuleInfo)-$( derive makeBinary ''IntrRuleACInfo)--$( derive makeNFData ''Rule)-$( derive makeNFData ''ProtoRuleName)-$( derive makeNFData ''ProtoRuleACInfo)-$( derive makeNFData ''ProtoRuleACInstInfo)-$( derive makeNFData ''RuleInfo)-$( derive makeNFData ''IntrRuleACInfo)
− src/Theory/Model/Signature.hs 
@@ -1,172 +0,0 @@-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE DeriveFunctor        #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE TypeSynonymInstances #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Signatures for the terms and multiset rewriting rules used to model and--- reason about a security protocol.--- modulo the full Diffie-Hellman equational theory and once modulo AC.-module Theory.Model.Signature (--  -- * Signature type-    Signature(..)--  -- ** Pure signatures-  , SignaturePure-  , emptySignaturePure-  , sigpMaudeSig--  -- ** Using Maude to handle operations relative to a 'Signature'-  , SignatureWithMaude-  , toSignatureWithMaude-  , toSignaturePure-  , sigmMaudeHandle--  -- ** Pretty-printing-  , prettySignaturePure-  , prettySignatureWithMaude--  ) where--import           Data.Binary-import qualified Data.Label           as L--import           Control.Applicative-import           Control.DeepSeq--import           System.IO.Unsafe     (unsafePerformIO)--import           Term.Maude.Process   (MaudeHandle, mhFilePath, mhMaudeSig, startMaude)-import           Term.Maude.Signature (MaudeSig, minimalMaudeSig, prettyMaudeSig)-import           Theory.Text.Pretty----- | A theory signature.-data Signature a = Signature-       { -- The signature of the message algebra-         _sigMaudeInfo  :: a-       }--$(L.mkLabels [''Signature])------------------------------------------------------------------------------------ Pure Signatures----------------------------------------------------------------------------------- | A 'Signature' without an associated Maude process.-type SignaturePure = Signature MaudeSig---- | Access the maude signature.-sigpMaudeSig:: SignaturePure L.:-> MaudeSig-sigpMaudeSig = sigMaudeInfo---- | The empty pure signature.-emptySignaturePure :: SignaturePure-emptySignaturePure = Signature minimalMaudeSig---- Instances---------------deriving instance Eq       SignaturePure-deriving instance Ord      SignaturePure-deriving instance Show     SignaturePure--instance Binary SignaturePure where-    put sig =  put (L.get sigMaudeInfo sig)-    get     = Signature <$> get--instance NFData SignaturePure where-  rnf (Signature y) = rnf y----------------------------------------------------------------------------------- Signatures with an attached Maude process----------------------------------------------------------------------------------- | A 'Signature' with an associated, running Maude process.-type SignatureWithMaude = Signature MaudeHandle---- | Access the maude handle in a signature.-sigmMaudeHandle :: SignatureWithMaude L.:-> MaudeHandle-sigmMaudeHandle = sigMaudeInfo---- | Ensure that maude is running and configured with the current signature.-toSignatureWithMaude :: FilePath            -- ^ Path to Maude executable.-                     -> SignaturePure-                     -> IO (SignatureWithMaude)-toSignatureWithMaude maudePath sig = do-    hnd <- startMaude maudePath (L.get sigMaudeInfo sig)-    return $ sig { _sigMaudeInfo = hnd }----- | The pure signature of a 'SignatureWithMaude'.-toSignaturePure :: SignatureWithMaude -> SignaturePure-toSignaturePure sig = sig { _sigMaudeInfo = mhMaudeSig $ L.get sigMaudeInfo sig }--{- TODO: There should be a finalizer in place such that as soon as the-   MaudeHandle is garbage collected, the appropriate command is sent to Maude--  The code below is a crutch and leads to unnecessary complication.----- | Stop the maude process. This operation is unsafe, as there still might be--- thunks that rely on the MaudeHandle to refer to a running Maude process.-unsafeStopMaude :: SignatureWithMaude -> IO (SignaturePure)-unsafeStopMaude = error "unsafeStopMaude: implement"---- | Run an IO action with maude running and configured with a specific--- signature. As there must not be any part of the return value that depends--- on unevaluated calls to the Maude process provided to the inner IO action.-unsafeWithMaude :: FilePath      -- ^ Path to Maude executable-                -> SignaturePure -- ^ Signature to use-                -> (SignatureWithMaude -> IO a) -> IO a-unsafeWithMaude maudePath sig  =-    bracket (startMaude maudePath sig) unsafeStopMaude---}---- Instances---------------instance Eq SignatureWithMaude where-  x == y = toSignaturePure x == toSignaturePure y--instance Ord SignatureWithMaude where-  compare x y = compare (toSignaturePure x) (toSignaturePure y)--instance Show SignatureWithMaude where-  show = show . toSignaturePure--instance Binary SignatureWithMaude where-    put sig@(Signature maude) = do-        put (mhFilePath maude)-        put (toSignaturePure sig)-    -- FIXME: reload the right signature-    get = unsafePerformIO <$> (toSignatureWithMaude <$> get <*> get)--instance NFData SignatureWithMaude where-  rnf (Signature _maude) = ()----------------------------------------------------------------------------------- Pretty-printing----------------------------------------------------------------------------------- | Pretty-print a signature with maude.-prettySignaturePure :: HighlightDocument d => SignaturePure -> d-prettySignaturePure sig =-    prettyMaudeSig $ L.get sigpMaudeSig sig---- | Pretty-print a pure signature.-prettySignatureWithMaude :: HighlightDocument d => SignatureWithMaude -> d-prettySignatureWithMaude sig =-    prettyMaudeSig $ mhMaudeSig $ L.get sigmMaudeHandle sig-
− src/Theory/Proof.hs 
@@ -1,654 +0,0 @@-{-# LANGUAGE BangPatterns    #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections   #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Types to represent proofs.-module Theory.Proof (-  -- * Utilities-    LTree(..)-  , mergeMapsWith--  -- * Types-  , ProofStep(..)-  , Proof--  -- ** Paths inside proofs-  , ProofPath-  , atPath-  , insertPaths--  -- ** Folding/modifying proofs-  , mapProofInfo-  , foldProof-  , annotateProof-  , ProofStatus(..)-  , proofStepStatus--  -- ** Unfinished proofs-  , sorry-  , unproven--  -- ** Incremental proof construction-  , IncrementalProof-  , Prover-  , runProver-  , mapProverProof--  , orelse-  , tryProver-  , sorryProver-  , oneStepProver-  , focus-  , checkAndExtendProver-  , replaceSorryProver-  , contradictionProver--  -- ** Explicit representation of a fully automatic prover-  , SolutionExtractor(..)-  , AutoProver(..)-  , runAutoProver--  -- ** Pretty Printing-  , prettyProof-  , prettyProofWith--  , showProofStatus--  -- ** Parallel Strategy for exploring a proof-  , parLTreeDFS--  -- ** Small-step interface to the constraint solver-  , module Theory.Constraint.Solver--) where--import           Data.Binary-import           Data.DeriveTH-import           Data.Foldable                    (Foldable, foldMap)-import           Data.List-import qualified Data.Map                         as M-import           Data.Maybe-import           Data.Monoid-import           Data.Traversable--import           Debug.Trace--import           Control.Basics-import           Control.DeepSeq-import qualified Control.Monad.State              as S-import           Control.Parallel.Strategies--import           Theory.Constraint.Solver-import           Theory.Model-import           Theory.Text.Pretty------------------------------------------------------------------------------------ Utility: Trees with uniquely labelled edges.----------------------------------------------------------------------------------- | Trees with uniquely labelled edges.-data LTree l a = LNode-     { root     :: a-     , children :: M.Map l (LTree l a)-     }-     deriving( Eq, Ord, Show )--instance Functor (LTree l) where-    fmap f (LNode r cs) = LNode (f r) (M.map (fmap f) cs)--instance Foldable (LTree l) where-    foldMap f (LNode x cs) = f x `mappend` foldMap (foldMap f) cs--instance Traversable (LTree l) where-    traverse f (LNode x cs) = LNode <$> f x <*> traverse (traverse f) cs---- | A parallel evaluation strategy well-suited for DFS traversal: As soon as--- a node is forced it sparks off the computation of the number of case-maps--- of all its children. This way most of the data is already evaulated, when--- the actual DFS traversal visits it.------ NOT used for now. It sometimes required too much memory.-parLTreeDFS :: Strategy (LTree l a)-parLTreeDFS (LNode x0 cs0) = do-    cs0' <- (`parTraversable` cs0) $ \(LNode x cs) -> LNode x <$> rseq cs-    return $ LNode x0 (M.map (runEval . parLTreeDFS) cs0')----------------------------------------------------------------------------------- Utility: Merging maps----------------------------------------------------------------------------------- | /O(n+m)/. A generalized union operator for maps with differing types.-mergeMapsWith :: Ord k-              => (a -> c) -> (b -> c) -> (a -> b -> c)-              -> M.Map k a -> M.Map k b -> M.Map k c-mergeMapsWith leftOnly rightOnly combine l r =-    M.map extract $ M.unionWith combine' l' r'-  where-    l' = M.map (Left . Left)  l-    r' = M.map (Left . Right) r--    combine' (Left (Left a)) (Left (Right b)) = Right $ combine a b-    combine' _ _ = error "mergeMapsWith: impossible"--    extract (Left (Left  a)) = leftOnly  a-    extract (Left (Right b)) = rightOnly b-    extract (Right c)        = c------------------------------------------------------------------------------------ Proof Steps----------------------------------------------------------------------------------- | A proof steps is a proof method together with additional context-dependent--- information.-data ProofStep a = ProofStep-     { psMethod :: ProofMethod-     , psInfo   :: a-     }-     deriving( Eq, Ord, Show )--instance Functor ProofStep where-    fmap f (ProofStep m i) = ProofStep m (f i)--instance Foldable ProofStep where-    foldMap f = f . psInfo--instance Traversable ProofStep where-    traverse f (ProofStep m i) = ProofStep m <$> f i--instance HasFrees a => HasFrees (ProofStep a) where-    foldFrees f (ProofStep m i) = foldFrees f m `mappend` foldFrees f i-    mapFrees f (ProofStep m i)  = ProofStep <$> mapFrees f m <*> mapFrees f i----------------------------------------------------------------------------------- Proof Trees----------------------------------------------------------------------------------- | A path to a subproof.-type ProofPath = [CaseName]---- | A proof is a tree of proof steps whose edges are labelled with case names.-type Proof a = LTree CaseName (ProofStep a)---- Unfinished proofs------------------------- | A proof using the 'sorry' proof method.-sorry :: Maybe String -> a -> Proof a-sorry reason ann = LNode (ProofStep (Sorry reason) ann) M.empty---- | A proof denoting an unproven part of the proof.-unproven :: a -> Proof a-unproven = sorry Nothing----- Paths in proofs----------------------- | @prf `atPath` path@ returns the subproof at the @path@ in @prf@.-atPath :: Proof a -> ProofPath -> Maybe (Proof a)-atPath = foldM (flip M.lookup . children)---- | @modifyAtPath f path prf@ applies @f@ to the subproof at @path@,--- if there is one.-modifyAtPath :: (Proof a -> Maybe (Proof a)) -> ProofPath-             -> Proof a -> Maybe (Proof a)-modifyAtPath f =-    go-  where-    go []     prf = f prf-    go (l:ls) prf = do-        let cs = children prf-        prf' <- go ls =<< M.lookup l cs-        return (prf { children = M.insert l prf' cs })---- | @insertPaths prf@ inserts the path to every proof node.-insertPaths :: Proof a -> Proof (a, ProofPath)-insertPaths =-    insertPath []-  where-    insertPath path (LNode ps cs) =-        LNode (fmap (,reverse path) ps)-              (M.mapWithKey (\n prf -> insertPath (n:path) prf) cs)----- Utilities for dealing with proofs------------------------------------------ | Apply a function to the information of every proof step.-mapProofInfo :: (a -> b) -> Proof a -> Proof b-mapProofInfo = fmap . fmap---- | @boundProofDepth bound prf@ bounds the depth of the proof @prf@ using--- 'Sorry' steps to replace the cut sub-proofs.-boundProofDepth :: Int -> Proof a -> Proof a-boundProofDepth bound =-    go bound-  where-    go n (LNode ps@(ProofStep _ info) cs)-      | 0 < n     = LNode ps                     $ M.map (go (pred n)) cs-      | otherwise = sorry (Just $ "bound " ++ show bound ++ " hit") info---- | Fold a proof.-foldProof :: Monoid m => (ProofStep a -> m) -> Proof a -> m-foldProof f =-    go-  where-    go (LNode step cs) = f step `mappend` foldMap go (M.elems cs)---- | Annotate a proof in a bottom-up fashion.-annotateProof :: (ProofStep a -> [b] -> b) -> Proof a -> Proof b-annotateProof f =-    go-  where-    go (LNode step@(ProofStep method _) cs) =-        LNode (ProofStep method info') cs'-      where-        cs' = M.map go cs-        info' = f step (map (psInfo . root . snd) (M.toList cs'))---- Proof cutting--------------------- | The status of a 'Proof'.-data ProofStatus =-         UndeterminedProof  -- ^ All steps are unannotated-       | CompleteProof      -- ^ The proof is complete: no annotated sorry,-                            --  no annotated solved step-       | IncompleteProof    -- ^ There is a annotated sorry,-                            --   but no annotatd solved step.-       | TraceFound         -- ^ There is an annotated solved step--instance Monoid ProofStatus where-    mempty = CompleteProof--    mappend TraceFound _                        = TraceFound-    mappend _ TraceFound                        = TraceFound-    mappend IncompleteProof _                   = IncompleteProof-    mappend _ IncompleteProof                   = IncompleteProof-    mappend _ CompleteProof                     = CompleteProof-    mappend CompleteProof _                     = CompleteProof-    mappend UndeterminedProof UndeterminedProof = UndeterminedProof---- | The status of a 'ProofStep'.-proofStepStatus :: ProofStep (Maybe a) -> ProofStatus-proofStepStatus (ProofStep _         Nothing ) = UndeterminedProof-proofStepStatus (ProofStep Solved    (Just _)) = TraceFound-proofStepStatus (ProofStep (Sorry _) (Just _)) = IncompleteProof-proofStepStatus (ProofStep _         (Just _)) = CompleteProof---{- TODO: Test and probably improve---- | @proveSystem rules se@ tries to construct a proof that @se@ is valid.--- This proof may contain 'Sorry' steps, if the prover is stuck. It can also be--- of infinite depth, if the proof strategy loops.-proveSystemIterDeep :: ProofContext -> System -> Proof System-proveSystemIterDeep rules se0 =-    fromJust $ asum $ map (prove se0 . round) $ iterate (*1.5) (3::Double)-  where-    prove :: System -> Int -> Maybe (Proof System)-    prove se bound-      | bound < 0 = Nothing-      | otherwise =-          case next of-            [] -> pure $ sorry "prover stuck => possible attack found" se-            xs -> asum $ map mkProof xs-      where-        next = do m <- possibleProofMethods se-                  (m,) <$> maybe mzero return (execProofMethod rules m se)-        mkProof (method, cases) =-            LNode (ProofStep method se) <$> traverse (`prove` (bound - 1)) cases--}---- | @checkProof rules se prf@ replays the proof @prf@ against the start--- sequent @se@. A failure to apply a proof method is denoted by a resulting--- proof step without an annotated sequent. An unhandled case is denoted using--- the 'Sorry' proof method.-checkProof :: ProofContext-           -> (Int -> System -> Proof (Maybe System)) -- prover for new cases in depth-           -> Int         -- ^ Original depth-           -> System-           -> Proof a-           -> Proof (Maybe a, Maybe System)-checkProof ctxt prover d sys prf@(LNode (ProofStep method info) cs) =-    case (method, execProofMethod ctxt method sys) of-        (Sorry reason, _         ) -> sorryNode reason cs-        (_           , Just cases) -> node method $ checkChildren cases-        (_           , Nothing   ) ->-            sorryNode (Just "invalid proof step encountered")-                      (M.singleton "" prf)-  where-    node m                 = LNode (ProofStep m (Just info, Just sys))-    sorryNode reason cases = node (Sorry reason) (M.map noSystemPrf cases)-    noSystemPrf            = mapProofInfo (\i -> (Just i, Nothing))--    checkChildren cases = mergeMapsWith-        unhandledCase noSystemPrf (checkProof ctxt prover (d + 1)) cases cs-      where-        unhandledCase = mapProofInfo ((,) Nothing) . prover d---- | Annotate a proof with the constraint systems of all intermediate steps--- under the assumption that all proof steps are valid. If some proof steps--- might be invalid, then you must use 'checkProof', which handles them--- gracefully.-annotateWithSystems :: ProofContext -> System -> Proof () -> Proof System-annotateWithSystems ctxt =-    go-  where-    -- Here we are careful to construct the result such that an inspection of-    -- the proof does not force the recomputed constraint systems.-    go sysOrig (LNode (ProofStep method _) csOrig) =-      LNode (ProofStep method sysOrig) $ M.fromList $ do-          (name, prf) <- M.toList csOrig-          let sysAnn = extract ("case '" ++ name ++ "' non-existent") $-                       M.lookup name csAnn-          return (name, go sysAnn prf)-      where-        extract msg = fromMaybe (error $ "annotateWithSystems: " ++ msg)-        csAnn       = extract "proof method execution failed" $-                      execProofMethod ctxt method sysOrig------------------------------------------------------------------------------------ Provers: the interface to the outside world.----------------------------------------------------------------------------------- | Incremental proofs are used to represent intermediate results of proof--- checking/construction.-type IncrementalProof = Proof (Maybe System)---- | Provers whose sequencing is handled via the 'Monoid' instance.------ > p1 `mappend` p2------ Is a prover that first runs p1 and then p2 on the resulting proof.-newtype Prover =  Prover-          { runProver-              :: ProofContext              -- proof rules to use-              -> Int                       -- proof depth-              -> System                    -- original sequent to start with-              -> IncrementalProof          -- original proof-              -> Maybe IncrementalProof    -- resulting proof-          }--instance Monoid Prover where-    mempty          = Prover $ \_  _ _ -> Just-    p1 `mappend` p2 = Prover $ \ctxt d se ->-        runProver p1 ctxt d se >=> runProver p2 ctxt d se---- | Map the proof generated by the prover.-mapProverProof :: (IncrementalProof -> IncrementalProof) -> Prover -> Prover-mapProverProof f p = Prover $ \ ctxt d se prf -> f <$> runProver p ctxt d se prf---- | Prover that always fails.-failProver :: Prover-failProver = Prover (\ _ _ _ _ -> Nothing)---- | Resorts to the second prover, if the first one is not successful.-orelse :: Prover -> Prover -> Prover-orelse p1 p2 = Prover $ \ctxt d se prf ->-    runProver p1 ctxt d se prf `mplus` runProver p2 ctxt d se prf---- | Try to apply a prover. If it fails, just return the original proof.-tryProver :: Prover -> Prover-tryProver =  (`orelse` mempty)---- | Try to execute one proof step using the given proof method.-oneStepProver :: ProofMethod -> Prover-oneStepProver method = Prover $ \ctxt _ se _ -> do-    cases <- execProofMethod ctxt method se-    return $ LNode (ProofStep method (Just se)) (M.map (unproven . Just) cases)---- | Replace the current proof with a sorry step and the given reason.-sorryProver :: Maybe String -> Prover-sorryProver reason = Prover $ \_ _ se _ -> return $ sorry reason (Just se)---- | Apply a prover only to a sub-proof, fails if the subproof doesn't exist.-focus :: ProofPath -> Prover -> Prover-focus []   prover = prover-focus path prover =-    Prover $ \ctxt d _ prf ->-        modifyAtPath (prover' ctxt (d + length path)) path prf-  where-    prover' ctxt d prf = do-        se <- psInfo (root prf)-        runProver prover ctxt d se prf---- | Check the proof and handle new cases using the given prover.-checkAndExtendProver :: Prover -> Prover-checkAndExtendProver prover0 = Prover $ \ctxt d se prf ->-    return $ mapProofInfo snd $ checkProof ctxt (prover ctxt) d se prf-  where-    unhandledCase   = sorry (Just "unhandled case") Nothing-    prover ctxt d se =-        fromMaybe unhandledCase $ runProver prover0 ctxt d se unhandledCase---- | Replace all annotated sorry steps using the given prover.-replaceSorryProver :: Prover -> Prover-replaceSorryProver prover0 = Prover prover-  where-    prover ctxt d _ = return . replace-      where-        replace prf@(LNode (ProofStep (Sorry _) (Just se)) _) =-            fromMaybe prf $ runProver prover0 ctxt d se prf-        replace (LNode ps cases) =-            LNode ps $ M.map replace cases----- | Use the first prover that works.-firstProver :: [Prover] -> Prover-firstProver = foldr orelse failProver---- | Prover that does one contradiction step.-contradictionProver :: Prover-contradictionProver = Prover $ \ctxt d sys prf ->-    runProver-        (firstProver $ map oneStepProver $-            (Contradiction . Just <$> contradictions ctxt sys))-        ctxt d sys prf----------------------------------------------------------------------------------- Automatic Prover's---------------------------------------------------------------------------------data SolutionExtractor = CutDFS | CutBFS | CutNothing-    deriving( Eq, Ord, Show, Read )--data AutoProver = AutoProver-    { apHeuristic :: Heuristic-    , apBound     :: Maybe Int-    , apCut       :: SolutionExtractor-    }--runAutoProver :: AutoProver -> Prover-runAutoProver (AutoProver heuristic bound cut) =-    mapProverProof cutSolved $ maybe id boundProver bound autoProver-  where-    cutSolved = case cut of-      CutDFS     -> cutOnSolvedDFS-      CutBFS     -> cutOnSolvedBFS-      CutNothing -> id--    -- | The standard automatic prover that ignores the existing proof and-    -- tries to find one by itself.-    autoProver :: Prover-    autoProver = Prover $ \ctxt depth sys _ ->-        return $ fmap (fmap Just)-               $ annotateWithSystems ctxt sys-               $ proveSystemDFS heuristic ctxt depth sys--    -- | Bound the depth of proofs generated by the given prover.-    boundProver :: Int -> Prover -> Prover-    boundProver b p = Prover $ \ctxt d se prf ->-        boundProofDepth b <$> runProver p ctxt d se prf----- | The result of one pass of iterative deepening.-data IterDeepRes = NoSolution | MaybeNoSolution | Solution ProofPath--instance Monoid IterDeepRes where-    mempty = NoSolution--    x@(Solution _)   `mappend` _                = x-    _                `mappend` y@(Solution _)   = y-    MaybeNoSolution  `mappend` _                = MaybeNoSolution-    _                `mappend` MaybeNoSolution  = MaybeNoSolution-    NoSolution       `mappend` NoSolution       = NoSolution---- | @cutOnSolvedDFS prf@ removes all other cases if an attack is found. The--- attack search is performed using a parallel DFS traversal with iterative--- deepening.------ FIXME: Note that this function may use a lot of space, as it holds onto the--- whole proof tree.-cutOnSolvedDFS :: Proof (Maybe a) -> Proof (Maybe a)-cutOnSolvedDFS prf0 =-    go (4 :: Integer) $ insertPaths prf0-  where-    go dMax prf = case findSolved 0 prf of-        NoSolution      -> prf0-        MaybeNoSolution -> go (2 * dMax) prf-        Solution path   -> extractSolved path prf0-      where-        findSolved d node-          | d >= dMax = MaybeNoSolution-          | otherwise = case node of-              -- do not search in nodes that are not annotated-              LNode (ProofStep _      (Nothing, _   )) _  -> NoSolution-              LNode (ProofStep Solved (Just _ , path)) _  -> Solution path-              LNode (ProofStep _      (Just _ , _   )) cs ->-                  foldMap (findSolved (succ d))-                      (cs `using` parTraversable nfProofMethod)--        nfProofMethod node = do-            void $ rseq (psMethod $ root node)-            void $ rseq (psInfo   $ root node)-            void $ rseq (children node)-            return node--    extractSolved []         p               = p-    extractSolved (label:ps) (LNode pstep m) = case M.lookup label m of-        Just subprf ->-          LNode pstep (M.fromList [(label, extractSolved ps subprf)])-        Nothing     ->-          error "Theory.Constraint.cutOnSolvedDFS: impossible, extractSolved failed, invalid path"---- | Search for attacks in a BFS manner.-cutOnSolvedBFS :: Proof (Maybe a) -> Proof (Maybe a)-cutOnSolvedBFS =-    go (1::Int)-  where-    go l prf =-      -- FIXME: See if that poor man's logging could be done better.-      trace ("searching for attacks at depth: " ++ show l) $-        case S.runState (checkLevel l prf) CompleteProof of-          (_, UndeterminedProof) -> error "cutOnSolvedBFS: impossible"-          (_, CompleteProof)     -> prf-          (_, IncompleteProof)   -> go (l+1) prf-          (prf', TraceFound)     ->-              trace ("attack found at depth: " ++ show l) prf'--    checkLevel 0 (LNode  step@(ProofStep Solved (Just _)) _) =-        S.put TraceFound >> return (LNode step M.empty)-    checkLevel 0 prf@(LNode (ProofStep _ x) cs)-      | M.null cs = return prf-      | otherwise = do-          st <- S.get-          msg <- case st of-              TraceFound -> return $ "ignored (attack exists)"-              _           -> S.put IncompleteProof >> return "bound reached"-          return $ LNode (ProofStep (Sorry (Just msg)) x) M.empty-    checkLevel l prf@(LNode step cs)-      | isNothing (psInfo step) = return prf-      | otherwise               = LNode step <$> traverse (checkLevel (l-1)) cs----- | @proveSystemDFS rules se@ explores all solutions of the initial--- constraint system using a depth-first-search strategy to resolve the--- non-determinism wrt. what goal to solve next.  This proof can be of--- infinite depth, if the proof strategy loops.------ Use 'annotateWithSystems' to annotate the proof tree with the constraint--- systems.-proveSystemDFS :: Heuristic -> ProofContext -> Int -> System -> Proof ()-proveSystemDFS heuristic ctxt d0 sys0 =-    prove d0 sys0-  where-    prove !depth sys =-        case rankProofMethods (useHeuristic heuristic depth) ctxt sys of-          []                         -> node Solved M.empty-          (method, (cases, _expl)):_ -> node method cases-      where-        node method cases =-          LNode (ProofStep method ()) (M.map (prove (succ depth)) cases)------------------------------------------------------------------------------------ Pretty printing----------------------------------------------------------------------------------prettyProof :: HighlightDocument d => Proof a -> d-prettyProof = prettyProofWith (prettyProofMethod . psMethod) (const id)--prettyProofWith :: HighlightDocument d-                => (ProofStep a -> d)      -- ^ Make proof step pretty-                -> (ProofStep a -> d -> d) -- ^ Make whole case pretty-                -> Proof a                 -- ^ The proof to prettify-                -> d-prettyProofWith prettyStep prettyCase =-    ppPrf-  where-    ppPrf (LNode ps cs) = ppCases ps (M.toList cs)--    ppCases ps@(ProofStep Solved _) [] = prettyStep ps-    ppCases ps []                      = prettyCase ps (kwBy <> text " ")-                                           <> prettyStep ps-    ppCases ps [("", prf)]             = prettyStep ps $-$ ppPrf prf-    ppCases ps cases                   =-        prettyStep ps $-$-        (vcat $ intersperse (prettyCase ps kwNext) $ map ppCase cases) $-$-        prettyCase ps kwQED--    ppCase (name, prf) = nest 2 $-      (prettyCase (root prf) $ kwCase <-> text name) $-$-      ppPrf prf---- | Convert a proof status to a redable string.-showProofStatus :: SystemTraceQuantifier -> ProofStatus -> String-showProofStatus ExistsNoTrace   TraceFound        = "falsified - found trace"-showProofStatus ExistsNoTrace   CompleteProof     = "verified"-showProofStatus ExistsSomeTrace CompleteProof     = "falsified - no trace found"-showProofStatus ExistsSomeTrace TraceFound        = "verified"-showProofStatus _               IncompleteProof   = "analysis incomplete"-showProofStatus _               UndeterminedProof = "analysis undetermined"----- Derived instances-----------------------$( derive makeBinary ''ProofStep)-$( derive makeBinary ''ProofStatus)-$( derive makeBinary ''SolutionExtractor)-$( derive makeBinary ''AutoProver)--$( derive makeNFData ''ProofStep)-$( derive makeNFData ''ProofStatus)-$( derive makeNFData ''SolutionExtractor)-$( derive makeNFData ''AutoProver)--instance (Ord l, NFData l, NFData a) => NFData (LTree l a) where-  rnf (LNode r m) = rnf r `seq` rnf  m--instance (Ord l, Binary l, Binary a) => Binary (LTree l a) where-  put (LNode r m) = put r >> put m-  get = LNode <$> get <*> get
− src/Theory/Text/Parser.hs 
@@ -1,668 +0,0 @@--- |--- Copyright   : (c) 2010-2012 Simon Meier, Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Parsing protocol theories. See the MANUAL for a high-level description of--- the syntax.-module Theory.Text.Parser (-    parseOpenTheory-  , parseOpenTheoryString-  , parseLemma-  , parseIntruderRulesDH--  -- * Cached Message Deduction Rule Variants-  , intruderVariantsFile-  , addMessageDeductionRuleVariants-  ) 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           Extension.Prelude          (ifM)--import           Text.Parsec                hiding ((<|>))-import           Text.PrettyPrint.Class     (render)--import           Paths_tamarin_prover-import           System.Directory--import           Term.Substitution-import           Term.SubtermRule-import           Theory-import           Theory.Text.Parser.Token-import           Theory.Tools.IntruderRules---------------------------------------------------------------------------------------- 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)-    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------------------------------------------------------------------------------------ Message deduction variants cached in files----------------------------------------------------------------------------------- | The name of the intruder variants file.-intruderVariantsFile :: FilePath-intruderVariantsFile = "intruder_variants_dh.spthy"---- | Add the variants of the message deduction rule. Uses the cached version--- of the @"intruder_variants_dh.spthy"@ file for the variants of the message--- deduction rules for Diffie-Hellman exponentiation.-addMessageDeductionRuleVariants :: OpenTheory -> IO OpenTheory-addMessageDeductionRuleVariants thy0-  | enableDH msig = do-      variantsFile <- getDataFileName intruderVariantsFile-      ifM (doesFileExist variantsFile)-          (do dhVariants <- parseIntruderRulesDH variantsFile-              return $ addIntrRuleACs dhVariants thy-          )-          (error $ "could not find intruder message deduction theory '"-                     ++ variantsFile ++ "'")-  | otherwise = return thy-  where-    msig         = get (sigpMaudeSig . thySignature) thy0-    rules        = subtermIntruderRules msig ++ specialIntruderRules-    thy          = addIntrRuleACs rules thy0
− src/Theory/Text/Parser/Token.hs 
@@ -1,398 +0,0 @@-{-# LANGUAGE TupleSections #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier, Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Tokenizing infrastructure-module Theory.Text.Parser.Token (-  -- * Symbols-    symbol-  , symbol_-  , dot-  , comma-  , colon--  , natural-  , naturalSubscript--  -- ** Formal comments-  , formalComment--  -- * Identifiers and Variables-  , identifier-  , indexedIdentifier--  , freshName-  , pubName--  , sortedLVar-  , lvar-  , msgvar-  , nodevar--  -- * Operators-  , opExp-  , opMult--  , opEqual-  , opLess-  , opAt-  , opForall-  , opExists-  , opImplies-  , opLEquiv-  , opLAnd-  , opLOr-  , opLNot-  , opLFalse-  , opLTrue--  , opRequires-  , opChain--  -- ** Pseudo operators-  , equalSign-  , opSharp-  , opBang-  , opSlash-  , opMinus-  , opLeftarrow-  , opRightarrow-  , opLongleftarrow-  , opLongrightarrow--  -- * Parentheses/quoting-  , braced-  , parens-  , angled-  , brackets-  , singleQuoted-  , doubleQuoted--  -- * List parsing-  , commaSep-  , commaSep1-  , list--    -- * Basic Parsing-  , Parser-  , parseFile-  , parseFromString-  ) where--import           Prelude             hiding (id, (.))--import           Data.Foldable       (asum)-import           Data.List (foldl')--import           Control.Applicative hiding (empty, many, optional)-import           Control.Category-import           Control.Monad--import           Text.Parsec         hiding ((<|>))-import qualified Text.Parsec.Token   as T--import           Theory---------------------------------------------------------------------------------------- Parser----------------------------------------------------------------------------------- | A parser for a stream of tokens.-type Parser a = Parsec String MaudeSig a---- Use Parsec's support for defining token parsers.-spthy :: T.TokenParser MaudeSig-spthy =-    T.makeTokenParser spthyStyle-  where-    spthyStyle = T.LanguageDef-      { T.commentStart   = "/*"-      , T.commentEnd     = "*/"-      , T.commentLine    = "//"-      , T.nestedComments = True-      , T.identStart     = alphaNum-      , T.identLetter    = alphaNum <|> oneOf "_"-      , T.reservedNames  = ["in","let","rule"]-      , T.opStart        = oneOf ":!$%&*+./<=>?@\\^|-"-      , T.opLetter       = oneOf ":!$%&*+./<=>?@\\^|-"-      , T.reservedOpNames= []-      , T.caseSensitive  = True-      }---- | Parse a file.-parseFile :: Parser a -> FilePath -> IO a-parseFile parser f = do-  s <- readFile f-  case runParser (T.whiteSpace spthy *> parser) minimalMaudeSig f s of-    Right p -> return p-    Left err -> error $ show err---- | Run a given parser on a given string.-parseFromString :: Parser a -> String -> Either ParseError a-parseFromString parser =-    runParser (T.whiteSpace spthy *> parser) minimalMaudeSig dummySource-  where-    dummySource = "<interactive>"----- Token parsers--------------------- | Parse a symbol.-symbol :: String -> Parser String-symbol sym = try (T.symbol spthy sym) <?> ("\"" ++ sym ++ "\"")---- | Parse a symbol without returning the parsed string.-symbol_ :: String -> Parser ()-symbol_ = void . symbol---- | Between braces.-braced :: Parser a -> Parser a-braced = T.braces spthy---- | Between brackets.-brackets :: Parser a -> Parser a-brackets = T.brackets spthy---- | Between parentheses.-parens :: Parser a -> Parser a-parens = T.parens spthy---- | Between angular brackets.-angled :: Parser a -> Parser a-angled = T.angles spthy---- | Between single quotes.-singleQuoted :: Parser a -> Parser a-singleQuoted = between (symbol "'") (symbol "'")---- | Between double quotes.-doubleQuoted :: Parser a -> Parser a-doubleQuoted = between (symbol "\"") (symbol "\"")---- | A dot @.@.-dot :: Parser ()-dot = void $ T.dot spthy---- | A comma @,@.-comma :: Parser ()-comma = void $ T.comma spthy---- | A colon @:@.-colon :: Parser ()-colon = void $ T.colon spthy---- | Parse an natural.-natural :: Parser Integer-natural = T.natural spthy---- | Parse a Unicode-subscripted natural number.-naturalSubscript :: Parser Integer-naturalSubscript = T.lexeme spthy $ do-    digits <- many1 (oneOf "₀₁₂₃₄₅₆₇₈₉")-    let n = foldl' (\x d -> 10*x + subscriptDigitToInteger d) 0 digits-    seq n (return n)-  where-    subscriptDigitToInteger d = toInteger $ fromEnum d - fromEnum '₀'---- | A comma separated list of elements.-commaSep :: Parser a -> Parser [a]-commaSep = T.commaSep spthy---- | A comma separated non-empty list of elements.-commaSep1 :: Parser a -> Parser [a]-commaSep1 = T.commaSep1 spthy---- | Parse a list of items '[' item ',' ... ',' item ']'-list :: Parser a -> Parser [a]-list = brackets . commaSep---- | A formal comment; i.e., (header, body)-formalComment :: Parser (String, String)-formalComment = T.lexeme spthy $ do-    header <- try (many1 letter <* string "{*")-    body   <- many bodyChar <* string "*}"-    return (header, body)-  where-    bodyChar = try $ do-      c <- anyChar-      case c of-        '\\' -> char '\\' <|> char '*'-        '*'  -> mzero-        _    -> return c---- Identifiers and Variables--------------------------------- | Parse an identifier as a string-identifier :: Parser String-identifier = T.identifier spthy---- | Parse an identifier possibly indexed with a number.-indexedIdentifier :: Parser (String, Integer)-indexedIdentifier = do-    (,) <$> identifier-        <*> option 0 (try (dot *> (fromIntegral <$> natural)))---- | Parse a logical variable with the given sorts allowed.-sortedLVar :: [LSort] -> Parser LVar-sortedLVar ss =-    asum $ map (try . mkSuffixParser) ss ++ map mkPrefixParser ss-  where-    mkSuffixParser s = do-        (n, i) <- indexedIdentifier <* colon-        symbol_ (sortSuffix s)-        return (LVar n s i)--    mkPrefixParser s = do-        case s of-          LSortMsg   -> pure ()-          LSortPub   -> void $ char '$'-          LSortFresh -> void $ char '~'-          LSortNode  -> void $ char '#'-          LSortMSet  -> void $ char '%'-        (n, i) <- indexedIdentifier-        return (LVar n s i)---- | An arbitrary logical variable.-lvar :: Parser LVar-lvar = sortedLVar [minBound..]---- | Parse a non-node variable.-msgvar :: Parser LVar-msgvar = sortedLVar [LSortFresh, LSortPub, LSortMsg, LSortMSet]---- | Parse a graph node variable.-nodevar :: Parser NodeId-nodevar = asum-  [ sortedLVar [LSortNode]-  , (\(n, i) -> LVar n LSortNode i) <$> indexedIdentifier ]-  <?> "timepoint variable"---- | Parse a literal fresh name, e.g., @~'n'@.-freshName :: Parser String-freshName = try (symbol "~" *> singleQuoted identifier)---- | Parse a literal public name, e.g., @'n'@.-pubName :: Parser String-pubName = singleQuoted identifier----- Term Operators----------------- | The exponentiation operator @^@.-opExp :: Parser ()-opExp = symbol_ "^"---- | The multiplication operator @*@.-opMult :: Parser ()-opMult = symbol_ "*"---- | The timepoint comparison operator @<@.-opLess :: Parser ()-opLess = symbol_ "<"---- | The action-at-timepoint operator \@.-opAt :: Parser ()-opAt = symbol_ "@"---- | The equality operator @=@.-opEqual :: Parser ()-opEqual = symbol_ "="---- | The logical-forall operator @All@ or @∀@.-opForall :: Parser ()-opForall = symbol_ "All" <|> symbol_ "∀"---- | The logical-exists operator @Ex@ or @∃@.-opExists :: Parser ()-opExists = symbol_ "Ex" <|> symbol_ "∃"---- | The logical-implies operator @==>@.-opImplies :: Parser ()-opImplies = symbol_ "==>" <|> symbol_ "⇒"---- | The logical-equivalence operator @<=>@.-opLEquiv :: Parser  ()-opLEquiv = symbol_ "<=>" <|> symbol_ "⇔"---- | The logical-and operator @&@ or @∧@.-opLAnd :: Parser ()-opLAnd = symbol_ "&" <|> symbol_ "∧"---- | The logical-or operator @|@ or @∨@.-opLOr :: Parser ()-opLOr = symbol_ "|" <|> symbol_ "∨"---- | The logical not operator @not@ or @¬@.-opLNot :: Parser  ()-opLNot = symbol_ "¬" <|> symbol_ "not"---- | A logical false, @F@ or @⊥@.-opLFalse :: Parser  ()-opLFalse = symbol_ "⊥" <|> T.reserved spthy "F"---- | A logical false, @T@ or @⊥@.-opLTrue :: Parser  ()-opLTrue = symbol_ "⊤" <|> T.reserved spthy "T"---- Operators for constraints--------------------------------- | The requires-a-premise operator, @▶ subscript-idx@.-opRequires :: Parser PremIdx-opRequires = (PremIdx . fromIntegral) <$> (symbol "▶" *> naturalSubscript)---- | The chain operator @~~>@.-opChain :: Parser ()-opChain = symbol_ "~~>"----- Pseudo operators (to be replaced by usage of proper tokens)------------------------------------------------------------------- | The equal sign @=@.-equalSign :: Parser ()-equalSign = symbol_ "="---- | The slash operator @/@.-opSlash :: Parser ()-opSlash = symbol_ "/"---- | The bang operator @!@.-opBang :: Parser ()-opBang = symbol_ "!"---- | The sharp operator @#@.-opSharp :: Parser ()-opSharp = symbol_ "#"---- | The minus operator @-@.-opMinus :: Parser ()-opMinus = symbol_ "-"---- | The leftarrow operator @<--@.-opLeftarrow :: Parser ()-opLeftarrow = symbol_ "<-"---- | The rightarrow operator @-->@.-opRightarrow :: Parser ()-opRightarrow = symbol_ "->"---- | The longleftarrow operator @<--@.-opLongleftarrow :: Parser ()-opLongleftarrow = symbol_ "<--"---- | The longrightarrow operator @-->@.-opLongrightarrow :: Parser ()-opLongrightarrow = symbol_ "-->"
− src/Theory/Text/Parser/UnitTests.hs 
@@ -1,91 +0,0 @@--- |--- Copyright   : (c) 2012 Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>------ Unit tests for checking that all examples parse properly.-module Theory.Text.Parser.UnitTests (--   testParseFile- , testParseDirectory- ) where--import           Test.HUnit--import           Control.Basics--import           System.Directory-import           System.FilePath--import           Theory-import           Theory.Text.Parser-import           Theory.Text.Pretty (render)---- | Test wether a given file exists, can be parsed, and can still be parsed--- after being pretty printed.-testParseFile :: Maybe (FilePath, Prover)-              -- ^ Path to maude and prover for testing whether proof parsing-              -- works properly.-              -> FilePath-              -- ^ File on which to test parsing (and proving)-              -> Test-testParseFile optionalProver inpFile = TestLabel inpFile $ TestCase $ do-    thyString <- readFile inpFile-    thy0      <- parse "original file:" thyString-    -- add proofs and pretty print closed theory, if desired-    (thy, thyPretty) <- case optionalProver of-        Nothing                  ->-            return  (thy0, prettyOpenTheory thy0)-        Just (maudePath, prover) -> do-            closedThy <- proveTheory prover <$> closeTheory maudePath thy0-            return $ ( normalizeTheory $ openTheory closedThy-                     , prettyClosedTheory closedThy)-    thy' <- parse "pretty printed theory:" (render thyPretty)-    unless (thy == thy') $ do-        let (diff1, diff2) =-                unzip $ dropWhile (uncurry (==)) $ zip (show thy) (show thy')-        assertFailure $ unlines-          [ "Original theory",            "",  render (prettyOpenTheory thy), ""-          , "Pretty printed and parsed" , "", render (prettyOpenTheory thy'), ""-          , "Original theory (diff)",            "", indent diff1, ""-          , "Pretty printed and parsed (diff)" , "", indent diff2, "", "DIFFER"-          ]-    return ()-  where-    indent = unlines . map (' ' :) . lines--    parse msg str = case parseOpenTheoryString [] str  of-        Left err  -> do assertFailure $ withLineNumbers $ indent $ show err-                        return (error "testParseFile: dead code")-        Right thy -> normalizeTheory <$> addMessageDeductionRuleVariants thy-      where-        withLineNumbers err =-            unlines $ zipWith (\i l -> nr (show i) ++ l) [(1::Int)..] ls-                      ++ ["", "Parse error when parsing the " ++ msg, err]-          where-            ls   = lines str-            n    = length (show (length ls))-            nr i = replicate (1 + max 0 (n - length i)) ' ' ++ i ++ ": "---- | Create the test whether 'testParseFile' succeeds on all @*.spthy@ files--- in a given directory and all its subdirectories of depth n.-testParseDirectory :: (FilePath -> Test)  -- ^ Test creation function.-                   -> Int                 -- ^ Maximal depth of traversal.-                   -> FilePath            -- ^ Starting directory.-                   -> IO [Test]-testParseDirectory mkTest n dir-  | n < 0     = return []-  | otherwise = do-      rawContents <- getDirectoryContents dir-      let contents = [ dir </> content-                     | content <- rawContents-                     , content /= ".", content /= ".." ]-      subDirs     <- filterM doesDirectoryExist contents-      innerTests  <- mapM (testParseDirectory mkTest (n - 1)) subDirs-      let tests = [ file-                  | file <- contents, takeExtension file == ".spthy" ]-      mapM_ (putStrLn . (" peparing: " ++)) tests-      return $ map mkTest tests ++ map TestList innerTests--
− src/Theory/Text/Pretty.hs 
@@ -1,130 +0,0 @@--- |--- Copyright   : (c) 2011 Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ General support for pretty printing theories.-module Theory.Text.Pretty (-  -- * General highlighters-    module Text.PrettyPrint.Highlight--  -- * Additional combinators-  , vsep-  , fsepList--  -- * Comments-  , lineComment-  , multiComment--  , lineComment_-  , multiComment_--  -- * Keywords-  , kwTheoryHeader-  , kwEnd-  , kwModulo-  , kwBy-  , kwCase-  , kwNext-  , kwQED-  , kwLemma-  , kwAxiom--  -- ** Composed forms-  , kwRuleModulo-  , kwInstanceModulo-  , kwVariantsModulo-  , kwTypesModulo--  -- * Operators-  , opProvides-  , opRequires-  , opAction-  , opPath-  , opLess-  , opEqual-  , opDedBefore-  , opEdge--  ) 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-  :: HighlightDocument d => d-opProvides  = operator_ ":>"-opRequires  = operator_ "<:"-opAction    = operator_ "@"-opPath      = operator_ ">+>"-opLess      = operator_ "<"-opEqual     = operator_ "="-opDedBefore = operator_ "--|"-opEdge      = operator_ ">->"-
− src/Theory/Tools/AbstractInterpretation.hs 
@@ -1,147 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}--- |--- Copyright   : (c) 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>------ Abstract intepretation for partial evaluation of multiset rewriting--- systems.-module Theory.Tools.AbstractInterpretation (-  -- * Combinator to define abstract interpretations-    interpretAbstractly--  -- ** Actual interpretations-  , EvaluationStyle(..)-  , partialEvaluation--  ) where--import           Debug.Trace--import           Control.Basics-import           Control.Monad.Bind-import           Control.Monad.Reader--import           Data.Label-import           Data.List-import qualified Data.Set             as S-import           Data.Traversable     (traverse)--import           Term.Substitution-import           Theory.Model-import           Theory.Text.Pretty------------------------------------------------------------------------------------ Abstract enough versions of builtin rules for computing------------------------------------------------------------------------------------ | Higher-order combinator to construct abstract interpreters.-interpretAbstractly-    :: (Eq s, HasFrees i, Apply i)-    => ([Equal LNFact] -> [LNSubstVFresh])-    -- ^ Unification  of equalities over facts. We assume that facts with-    -- different tags are never unified.-    -> s                  -- ^ Initial abstract state.-    -> (LNFact -> s -> s) -- ^ Add a fact to the abstract state-    -> (s -> [LNFact])    -- ^ Facts of a state.-    -> [Rule i]-    -- ^ Multiset rewriting rules to apply abstractly.-    -> [(s, [Rule i])]-    -- ^ Sequence of abstract states and refined versions of all given-    -- multiset rewriting rules.-interpretAbstractly unifyFactEqs initState addFact stateFacts rus =-    go st0-  where-    st0 = addFact (freshFact (varTerm (LVar "z" LSortFresh 0))) $-          addFact (inFact (varTerm (LVar "z" LSortMsg   0))) $-          initState--    -- Repeatedly refine all rules and add all their conclusions until the-    -- state doesn't change anymore.-    go st =-        (st, rus') : if st == st' then [] else go st'-      where-        rus' = concatMap refineRule rus-        st'  = foldl' (flip addFact) st $ concatMap (get rConcs) rus'--        -- Refine a rule in the context of an abstract state: for all premise-        -- to state facts combinations, try to solve the corresponding-        -- E-unification problem. If successful, return the rule with the-        -- unifier applied.-        refineRule ru = (`evalFreshT` avoid ru) $ do-            eqs <- forM (get rPrems ru) $ \prem -> msum $ do-                fa <- stateFacts st-                guard (factTag prem == factTag fa)-                -- we compute a list of 'FreshT []' actions for the outer msum-                return (Equal prem <$> rename fa)-            subst <- msum $ freshToFree <$> unifyFactEqs eqs-            return $ apply subst ru---- | How to report on performing a partial evaluation.-data EvaluationStyle = Silent | Summary | Tracing---- | Concrete partial evaluator activated with flag: --partial-evaluation-partialEvaluation :: EvaluationStyle-                  -> [ProtoRuleE] -> WithMaude (S.Set LNFact, [ProtoRuleE])-partialEvaluation evalStyle ruEs = reader $ \hnd ->-    consumeEvaluation $ interpretAbstractly-        ((`runReader` hnd) . unifyLNFactEqs)  -- FIXME: Use E-unification here-        S.empty-        (S.insert . absFact)-        S.toList-        ruEs-  where-    consumeEvaluation [] = error "partialEvaluation: impossible"-    consumeEvaluation ((st0, rus0) : rest0) =-        go (0 :: Int) st0 rus0 rest0-      where-        go _ st rus [] =-          ( st-          , nubBy eqModuloFreshnessNoAC $                 -- remove duplicates-            map ((`evalFresh` nothingUsed) . rename) rus-          )-        go i st _   ((st', rus') : rest) =-            withTrace (go (i + 1) st' rus' rest)-          where-            incDesc = " partial evaluation: step " ++ show i ++ " added " ++-                      show (S.size st' - S.size st) ++ " facts"-            withTrace = case evalStyle of-              Silent  -> id-              Summary -> trace incDesc-              Tracing -> trace $ incDesc ++ "\n\n" ++-                ( render $ nest 2 $ numbered' $ map prettyLNFact $-                  S.toList $ st' `S.difference` st ) ++ "\n"---    -- NOTE: We should use an abstract state that identifies all variables at-    -- the same position provided they have the same sort.-    absFact :: LNFact -> LNFact-    absFact fa = case fa of-        Fact OutFact _ -> outFact (varTerm (LVar "z" LSortMsg 0))-        Fact tag ts    -> Fact tag $ evalAbstraction $ traverse absTerm ts-      where-        evalAbstraction = (`evalBind` noBindings) . (`evalFreshT` nothingUsed)--        absTerm t = case viewTerm t of-          Lit (Con _)                   -> pure t-          FApp (sym@(NonAC (_f,_k))) ts-                                        -> fApp sym <$> traverse absTerm ts-          -- | "p" `isPrefixOf` f        -> FApp sym <$> traverse absTerm ts-          _                             -> importBinding mkVar t (varName t)-          where-            mkVar name idx        = varTerm (LVar name (sortOfLNTerm t) idx)-            varName (viewTerm -> Lit (Var v)) = lvarName v-            varName _                         = "z"--{- FIXME: Implement---- | Perform a simple propagation of sorts at the fact level.-propagateSorts :: [ProtoRuleE]-               -> WithMaude (M.Map FactTag [LSort], [ProtoRuleE])-propagateSorts ruEs = reader $ \hnd ->---}
− src/Theory/Tools/EquationStore.hs 
@@ -1,566 +0,0 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ViewPatterns               #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt, Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Support for reasoning with and about disjunctions of substitutions.-module Theory.Tools.EquationStore (-  -- * Equations-    SplitId(..)--  , EqStore(..)-  , emptyEqStore-  , eqsSubst-  , eqsConj--  -- ** Equalitiy constraint conjunctions-  , falseEqConstrConj--  -- ** Queries-  , eqsIsFalse---  -- ** Adding equalities-  , addEqs-  , addRuleVariants-  , addDisj--  -- ** Case splitting-  , performSplit--  , splits-  , splitSize-  , splitExists--  -- * Simplification-  , simp-  , simpDisjunction--  -- ** Pretty printing-  , prettyEqStore-) where--import           Logic.Connectives-import           Term.Unification-import           Theory.Text.Pretty--import           Control.Monad.Fresh-import           Control.Monad.Reader-import           Extension.Prelude-import           Utils.Misc--import           Debug.Trace.Ignore--import           Control.Basics-import           Control.DeepSeq-import           Control.Monad.State   hiding (get, modify, put)-import qualified Control.Monad.State   as MS--import           Data.Binary-import           Data.DeriveTH-import qualified Data.Foldable         as F-import           Data.List-import           Data.Maybe-import qualified Data.Set              as S-import           Extension.Data.Label  hiding (for, get)-import qualified Extension.Data.Label  as L-import           Extension.Data.Monoid----------------------------------------------------------------------------------- Equation Store                                                ------------------------------------------------------------------------------------- | Index of disjunction in equation store-newtype SplitId = SplitId { unSplitId :: Integer }-  deriving( Eq, Ord, Show, Enum, Binary, NFData, HasFrees )---- FIXME: Make comment parse.------ The semantics of an equation store--- > EqStore sigma_free--- >         [ [sigma_i1,..,sigma_ik_i] | i <- [1..l] ]--- where sigma_free = {t1/x1, .., tk/xk} is--- >    (x1 = t1 /\ .. /\ xk = tk)--- > /\_{i in [1..l]}--- >    ([|sigma_i1|] \/ .. \/ [|sigma_ik_1|] \/ [|mtinfo_i|]--- where @[|{t_1/x_1,..,t_l/x_l}|] = EX vars(t1,..,tl). x_1 = t1 /\ .. /\ x_l = t_l@.--- Note that the 'LVar's in the range of a substitution are interpreted as--- fresh variables, i.e., different by construction from the x_i which are--- free variables.------ The variables in the domain of the substitutions sigma_ij and all--- variables in sigma_free are free (usually globally existentially quantified).--- We use Conj [] as a normal form to denote True and Conj [Disj []]--- as a normal form to denote False.--- We say a variable @x@ is constrained by a disjunction if there is a substition--- @s@ in the disjunction with @x `elem` dom s@.-data EqStore = EqStore {-      _eqsSubst       :: LNSubst-    , _eqsConj        :: Conj (SplitId, S.Set LNSubstVFresh)-    , _eqsNextSplitId :: SplitId-    }-  deriving( Eq, Ord )--$(mkLabels [''EqStore])---- | @emptyEqStore@ is the empty equation store.-emptyEqStore :: EqStore-emptyEqStore = EqStore emptySubst (Conj []) (SplitId 0)---- | @True@ iff the 'EqStore' is contradictory.-eqsIsFalse :: EqStore -> Bool-eqsIsFalse = any ((S.empty == ) . snd) . getConj . L.get eqsConj---- | The false conjunction. It is always identified with split number -1.-falseEqConstrConj :: Conj (SplitId, S.Set (LNSubstVFresh))-falseEqConstrConj = Conj [ (SplitId (-1), S.empty) ]----- Instances---------------instance Apply SplitId where-    apply _ = id--instance HasFrees EqStore where-    foldFrees f (EqStore subst substs nextSplitId) =-        foldFrees f subst <> foldFrees f substs <> foldFrees f nextSplitId-    mapFrees f (EqStore subst substs nextSplitId) =-        EqStore <$> mapFrees f subst-                <*> mapFrees f substs-                <*> mapFrees f nextSplitId------ Equation Store--------------------------------------------------------------------------- | We use the empty set (disjunction) to denote false.-falseDisj :: S.Set LNSubstVFresh-falseDisj = S.empty----- Dealing with equations--------------------------------------------------------------------------- | Returns the list of all @SplitId@s valid for the given equation store--- sorted by the size of the disjunctions.-splits :: EqStore -> [SplitId]-splits eqs = map fst $ nub $ sortOn snd-    [ (idx, S.size conj) | (idx, conj) <- getConj $ L.get eqsConj eqs ]---- | Returns 'True' if the 'SplitId' is valid.-splitExists :: EqStore -> SplitId -> Bool-splitExists eqs = isJust . splitSize eqs---- | Returns the number of cases for a given 'SplitId'.-splitSize :: EqStore -> SplitId -> Maybe Int-splitSize eqs sid =-    (S.size . snd) <$> (find ((sid ==) . fst) $ getConj $ L.get eqsConj $ eqs)---- | Add a disjunction to the equation store at the beginning-addDisj :: EqStore -> (S.Set LNSubstVFresh) -> (EqStore, SplitId)-addDisj eqStore disj =-    (   modify eqsConj ((Conj [(sid, disj)]) `mappend`)-      $ modify eqsNextSplitId succ-      $ eqStore-    , sid-    )-  where-    sid = L.get eqsNextSplitId eqStore---- | @performSplit eqs i@ performs a case-split on the first disjunction--- with the given 'SplitId'.-performSplit :: EqStore -> SplitId -> Maybe [EqStore]-performSplit eqStore idx =-    case break ((idx ==) . fst) (getConj $ L.get eqsConj eqStore) of-        (_, [])                   -> Nothing-        (before, (_, disj):after) -> Just $-            mkNewEqStore before after <$> S.toList disj-  where-    mkNewEqStore before after subst =-        fst $ addDisj (set eqsConj (Conj (before ++ after)) eqStore)-                      (S.singleton subst)---- | Add a list of term equalities to the equation store. Returns the split--- identifier of the disjunction in resulting equation store.-addEqs :: MonadFresh m-       => MaudeHandle -> [Equal LNTerm] -> EqStore -> m (EqStore, Maybe SplitId)-addEqs hnd eqs0 eqStore =-    case unifyLNTermFactored eqs `runReader` hnd of-        (_, []) ->-            return (set eqsConj falseEqConstrConj eqStore, Nothing)-        (subst, [substFresh]) | substFresh == emptySubstVFresh ->-            return (applyEqStore hnd subst eqStore, Nothing)-        (subst, substs) -> do-            let (eqStore', sid) = addDisj (applyEqStore hnd subst eqStore)-                                          (S.fromList substs)-            return (eqStore', Just sid)-            {--            case splitStrat of-                SplitLater ->-                    return [ addDisj (applyEqStore hnd subst eqStore) (S.fromList substs) ]-                SplitNow ->-                    addEqsAC (modify eqsSubst (compose subst) eqStore)-                        <$> simpDisjunction hnd (const False) (Disj substs)-            -}-  where-    eqs = apply (L.get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0-    {--    addEqsAC eqSt (sfree, Nothing)   = [ applyEqStore hnd sfree eqSt ]-    addEqsAC eqSt (sfree, Just disj) =-      fromMaybe (error "addEqsSplit: impossible, splitAtPos failed")-                (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (S.fromList disj))) 0)--}---- | Apply a substitution to an equation store and bring resulting equations into---   normal form again by using unification.-applyEqStore :: MaudeHandle -> LNSubst -> EqStore -> EqStore-applyEqStore hnd asubst eqStore-    | dom asubst `intersect` varsRange asubst /= [] || trace (show ("applyEqStore", asubst, eqStore)) False-    = error $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'"-    | otherwise-    = modify eqsConj (fmap (second (S.fromList . concatMap applyBound  . S.toList))) $-          set eqsSubst newsubst eqStore-  where-    newsubst = asubst `compose` L.get eqsSubst eqStore-    applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $-        (`runReader` hnd) $ unifyLNTerm-          [ Equal (apply newsubst (varTerm lv)) t-          | let slist = substToListVFresh s,-            -- variables in the range are fresh, so we have to rename-            -- them away from all other variables in unification problem-            -- NOTE: these variables never enter the global context-            let ran = renameAvoiding (map snd slist)-                                     (domVFresh s ++ varsRange newsubst),-            (lv,t) <- zip (map fst slist) ran-          ]--{- NOTES for @applyEqStore tau@ to a fresh substitution sigma:-[ FIXME: extend explanation to multiple unifiers ]-Let dom(sigma) = x1,..,xk, vrange(sigma) = y1, .. yl, vrange(tau) = z1,..,zn-Fresh substitution denotes formula-  exists #y1, .., #yl. x1 = t1 /\ .. /\ xk = tk-for variables #yi that do not clash with xi and zi [renameAwayFrom]-and with vars(ti) `subsetOf` [#y1, .. #yl].-We apply tau with vrange(tau) = z1,..,zn to the formula to obtain-  exists ##y1, .., ##yl. tau(x1) = t1 /\ .. /\ tau(xk) = tk-unification then yields a lemma-  forall xi zi #yi.-    tau(x1) = t1 /\ .. /\ tau(xk) = tk-    <-> exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..-So we have-  exists #y1, .., #yl.-    exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..-<=>-  exists vars(s1,..sm). x1 = .. /\ z1 = ..-      /\  (exists #y1, .., #yl. #y1 = ..)-<=> [restric]-  exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ True--}---- | Add the given rule variants.-addRuleVariants :: Disj LNSubstVFresh -> EqStore -> (EqStore, SplitId)-addRuleVariants (Disj substs) eqStore-    | dom freeSubst `intersect` concatMap domVFresh substs /= []-    = error $ "addRuleVariants: Nonempty intersection between domain of variants and free substitution. "-              ++"This case has not been implemented, add rule variants earlier."-    | otherwise = addDisj eqStore (S.fromList substs)-  where-    freeSubst = L.get eqsSubst eqStore---{---- | Return the set of variables that is constrained by disjunction at give position.-constrainedVarsPos :: EqStore -> Int -> [LVar]-constrainedVarsPos eqStore k-    | k < length conj = frees (conj!!k)-    | otherwise       = []-  where-    conj = getConj . L.get eqsConj $ eqStore--}---- Simplifying disjunctions--------------------------------------------------------------------------- | Simplify given disjunction via EqStore simplification. Obtains fresh---   names for variables from the underlying 'MonadFresh'.-simpDisjunction :: MonadFresh m-                => MaudeHandle-                -> (LNSubstVFresh -> Bool)-                -> Disj LNSubstVFresh-                -> m (LNSubst, Maybe [LNSubstVFresh])-simpDisjunction hnd isContr disj0 = do-    eqStore' <- simp hnd isContr eqStore-    return (L.get eqsSubst eqStore', wrap $ L.get eqsConj eqStore')-  where-    eqStore = fst $ addDisj emptyEqStore (S.fromList $ getDisj $ disj0)-    wrap (Conj [])          = Nothing-    wrap (Conj [(_, disj)]) = Just $ S.toList disj-    wrap conj               =-        error ("simplifyDisjunction: imposible, unexpected conjunction `"-               ++ show conj ++ "'")----- Simplification--------------------------------------------------------------------------- | @simp eqStore@ simplifies the equation store.-simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore-simp hnd isContr eqStore =-    execStateT (whileTrue (simp1 hnd isContr))-               (trace (show ("eqStore", eqStore)) eqStore)----- | @simp1@ tries to execute one simplification step---   for the equation store. It returns @True@ if---   the equation store was modified.-simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool-simp1 hnd isContr = do-    s <- MS.get-    if eqsIsFalse s-        then return False-        else do-          b1 <- simpMinimize isContr-          b2 <- simpRemoveRenamings-          b3 <- simpEmptyDisj-          b4 <- foreachDisj hnd simpSingleton-          b5 <- foreachDisj hnd simpAbstractSortedVar-          b6 <- foreachDisj hnd simpIdentify-          b7 <- foreachDisj hnd simpAbstractFun-          b8 <- foreachDisj hnd simpAbstractName-          (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8]))) $-              return $ (or [b1, b2, b3, b4, b5, b6, b7, b8])----- | Remove variable renamings in fresh substitutions.-simpRemoveRenamings :: MonadFresh m => StateT EqStore m Bool-simpRemoveRenamings = do-    conj <- gets (L.get eqsConj)-    if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False . snd) conj-      then modM eqsConj (fmap (second $ S.map removeRenamings)) >> return True-      else return False----- | If empty disjunction is found, the whole conjunct---   can be simplified to False.-simpEmptyDisj :: MonadFresh m => StateT EqStore m Bool-simpEmptyDisj = do-    conj <- getM eqsConj-    if (F.any ((== falseDisj) . snd) conj && conj /= falseEqConstrConj)-      then eqsConj =: falseEqConstrConj >> return True-      else return False----- | If there is a singleton disjunction, it can be---   composed with the free substitution.-simpSingleton :: MonadFresh m-              => [LNSubstVFresh]-              -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpSingleton [subst0] = do-        subst <- freshToFree subst0-        return (Just (Just subst, []))-simpSingleton _        = return Nothing----- | If all substitutions @si@ map a variable @v@ to terms with the same---   outermost function symbol @f@, then they all contain the common factor---   @{v |-> f(x1,..,xk)}@ for fresh variables xi and we can replace---   @x |-> ..@ by @{x1 |-> ti1, x2 |-> ti2, ..}@ in all substitutions @si@.-simpAbstractFun :: MonadFresh m-                => [LNSubstVFresh]-                -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpAbstractFun []             = return Nothing-simpAbstractFun (subst:others) = case commonOperators of-    [] -> return Nothing-    -- abstract all arguments-    (v, o, argss@(args:_)):_ | all ((==length args) . length) argss -> do-        fvars <- mapM (\_ -> freshLVar "x" LSortMsg) args-        let substs' = zipWith (abstractAll v fvars) (subst:others) argss-            fsubst  = substFromList [(v, fApp o (map varTerm fvars))]-        return $ Just (Just fsubst, [S.fromList substs'])-    -- abstract first two arguments-    (v, o@(AC _), argss):_ -> do-        fv1 <- freshLVar "x" LSortMsg-        fv2 <- freshLVar "x" LSortMsg-        let substs' = zipWith (abstractTwo o v fv1 fv2) (subst:others) argss-            fsubst  = substFromList [(v, fApp o (map varTerm [fv1,fv2]))]-        return $ Just (Just fsubst, [S.fromList substs'])-    (_, _ ,_):_ ->-        error "simpAbstract: impossible, invalid arities or List operator encountered."-  where-    commonOperators = do-        (v, viewTerm -> FApp o args) <- substToListVFresh subst-        let images = map (\s -> imageOfVFresh s v) others-            argss  = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ]-        guard (length argss == length others)-        return (v, o, args:argss)--    abstractAll v freshVars s args = substFromListVFresh $-        filter ((/= v) . fst) (substToListVFresh s) ++ zip freshVars args--    abstractTwo o v fv1 fv2 s args = substFromListVFresh $-        filter ((/= v) . fst) (substToListVFresh s) ++ newMappings args-      where-        newMappings []      =-            error "simpAbstract: impossible, AC symbols must have arity >= 2."-        newMappings [a1,a2] = [(fv1, a1), (fv2, a2)]-        -- here we always abstract from left to right and do not-        -- take advantage of the AC property of o-        newMappings (a:as)  = [(fv1, a),  (fv2, fApp o as)]----- | If all substitutions @si@ map a variable @v@ to the same name @n@,---   then they all contain the common factor---   @{v |-> n}@ and we can remove @{v -> n} from all substitutions @si@-simpAbstractName :: MonadFresh m-                 => [LNSubstVFresh]-                 -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpAbstractName []             = return Nothing-simpAbstractName (subst:others) = case commonNames of-    []           -> return Nothing-    (v, c):_     ->-        return $ Just (Just $ substFromList [(v, c)]-                      , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))])-  where-    commonNames = do-        (v, c@(viewTerm -> Lit (Con _))) <- substToListVFresh subst-        let images = map (\s -> imageOfVFresh s v) others-        guard (length images == length [ () | Just c' <- images, c' == c])-        return (v, c)----- | If all substitutions @si@ map a variable @v@ to variables @xi@ of the same---   sort @s@ then they all contain the common factor---   @{v |-> y}@ for a fresh variable of sort @s@---   and we can replace @{v -> xi}@ by @{y -> xi} in all substitutions @si@-simpAbstractSortedVar :: MonadFresh m-                      => [LNSubstVFresh]-                      -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpAbstractSortedVar []             = return Nothing-simpAbstractSortedVar (subst:others) = case commonSortedVar of-    []            -> return Nothing-    (v, s, lvs):_ -> do-        fv <- freshLVar (lvarName v) s-        return $ Just (Just $ substFromList [(v, varTerm fv)]-                      , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))])-  where-    commonSortedVar = do-        (v, (viewTerm -> Lit (Var lx))) <- substToListVFresh subst-        guard (sortCompare (lvarSort v)  (lvarSort lx) == Just GT)-        let images = map (\s -> imageOfVFresh s v) others-            -- FIXME: could be generalized to choose topsort s of all images if s < sortOf v-            --        could also be generalized to terms of a given sort-            goodImages = [ ly | Just (viewTerm -> Lit (Var ly)) <- images, lvarSort lx == lvarSort ly]-        guard (length images == length goodImages)-        return (v, lvarSort lx, (lx:goodImages))-    replaceMapping v fv lv sigma =-        substFromListVFresh $ (filter ((/=v) . fst) $ substToListVFresh sigma) ++ [(fv, varTerm lv)]---- | If all substitutions @si@ map two variables @x@ and @y@ to identical terms @ti@,---   then they all contain the common factor @{x |-> y} for a fresh variable @z@---   and we can remove @{x |-> ti}@ from all @si@.-simpIdentify :: MonadFresh m-             => [LNSubstVFresh]-             -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpIdentify []             = return Nothing-simpIdentify (subst:others) = case equalImgPairs of-    []         -> return Nothing-    ((v,v'):_) -> do-        let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of-                                 Just GT -> (v', v)-                                 Just _  -> (v, v')-                                 Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: "-                                                    ++ show v ++" and "++ show v'-        return $ Just (Just  (substFromList [(vremove, varTerm vkeep)]),-                       [S.fromList (map (removeMappings [vkeep]) (subst:others))])-  where-    equalImgPairs = do-        (v,t)    <- substToListVFresh subst-        (v', t') <- substToListVFresh subst-        guard (t == t' && v < v' && all (agrees_on v v') others)-        return (v,v')-    agrees_on v v' s =-        imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v)-    removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s----- | Simplify by removing substitutions that occur twice in a disjunct.---   We could generalize this function by using AC-equality or subsumption.-simpMinimize :: MonadFresh m => (LNSubstVFresh -> Bool) -> StateT EqStore m Bool-simpMinimize isContr = do-    conj <- MS.gets (L.get eqsConj)-    if F.any (F.any check . snd) conj-      then MS.modify (set eqsConj (fmap (second minimize) conj)) >> return True-      else return False-  where-    minimize substs-      | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh-      | otherwise                          = S.filter (not . isContr) substs--    check subst = subst == emptySubstVFresh || isContr subst----- | Traverse disjunctions and execute @f@ until it returns---   @Just (mfreeSubst, disjs)@.---   Then the @disjs@ is inserted at the current position, if @mfreeSubst@ is---   @Just freesubst@, then it is applied to the equation store. @True@ is---   returned if any modifications took place.-foreachDisj :: MonadFresh m-            => MaudeHandle-            -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])))-            -> StateT EqStore m Bool-foreachDisj hnd f =-    go [] =<< gets (getConj . L.get eqsConj)-  where-    go _     []               = return False-    go lefts ((idx,d):rights) = do-        b <- lift $ f (S.toList d)-        case b of-          Nothing              -> go ((idx,d):lefts) rights-          Just (msubst, disjs) -> do-              eqsConj =: Conj (reverse lefts ++ ((,) idx <$> disjs) ++ rights)-              maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst-              return True----------------------------------------------------------------------------------- Pretty printing----------------------------------------------------------------------------------- | Pretty print an 'EqStore'.-prettyEqStore :: HighlightDocument d => EqStore -> d-prettyEqStore eqs@(EqStore subst (Conj disjs) _nextSplitId) = vcat $-  [if eqsIsFalse eqs then text "CONTRADICTORY" else emptyDoc] ++-  map combine-    [ ("subst", vcat $ prettySubst (text . show) (text . show) subst)-    , ("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 ppConj (S.toList substs)-        ppConj = vcat . map prettyEq . substToListVFresh-        prettyEq (a,b) =-          prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b)------ Derived and delayed instances-----------------------------------instance Show EqStore where-    show = render . prettyEqStore--$( derive makeBinary ''EqStore)-$( derive makeNFData ''EqStore)
− src/Theory/Tools/InjectiveFactInstances.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- |--- Copyright   : (c) 2012 Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Computate an under-approximation to the set of all facts with unique--- instances, i.e., fact whose instances never occur more than once in a--- state. We use this information to reason about protocols that exploit--- exclusivity of linear facts.-module Theory.Tools.InjectiveFactInstances (--  -- * Computing injective fact instances.-  simpleInjectiveFactInstances-  ) where--import           Extension.Prelude   (sortednub)--import           Control.Applicative-import           Control.Monad.Fresh-import           Data.Label-import qualified Data.Set            as S-import           Safe                (headMay)--import           Theory.Model---- | Compute a simple under-approximation to the set of facts with injective--- instances. A fact-tag is has injective instances, if there is no state of--- the protocol with more than one instance with the same term as a first--- argument of the fact-tag.------ We compute the under-approximation by checking that--- (1) the fact-tag is linear,--- (2) every introduction of such a fact-tag is protected by a Fr-fact of the---     first term, and--- (3) every rule has at most one copy of this fact-tag in the conlcusion and---     the first term arguments agree.------ We exclude facts that are not copied in a rule, as they are already handled--- properly by the naive backwards reasoning.-simpleInjectiveFactInstances :: [ProtoRuleE] -> S.Set FactTag-simpleInjectiveFactInstances rules = S.fromList $ do-    tag <- candidates-    guard (all (guardedSingletonCopy tag) rules)-    return tag-  where-    candidates = sortednub $ do-        ru  <- rules-        tag <- factTag <$> get rConcs ru-        guard $    (factTagMultiplicity tag == Linear)-                && (tag `elem` (factTag <$> get rPrems ru))-        return tag--    guardedSingletonCopy tag ru =-        length copies <= 1 && all guardedCopy copies-      where-        prems              = get rPrems ru-        copies             = filter ((tag ==) . factTag) (get rConcs ru)-        firstTerm          = headMay . factTerms--        -- True if there is a first term and a premise guarding it-        guardedCopy faConc = case firstTerm faConc of-            Nothing    -> False-            Just tConc -> freshFact tConc `elem` prems || guardedInPrems tConc--        -- True if there is a premise with the same tag and first term-        guardedInPrems tConc = (`any` prems) $ \faPrem ->-            factTag faPrem == tag && maybe False (tConc ==) (firstTerm faPrem)-
− src/Theory/Tools/IntruderRules.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns     #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-  -- spurious warnings for view patterns--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only----module Theory.Tools.IntruderRules (-    subtermIntruderRules-  , dhIntruderRules-  , specialIntruderRules-  ) where--import           Control.Basics-import           Control.Monad.Reader--import           Data.List-import qualified Data.Set                        as S--import           Extension.Data.Label--import           Utils.Misc--import           Term.Maude.Signature-import           Term.Narrowing.Variants.Compute-import           Term.Rewriting.Norm-import           Term.SubtermRule-import           Term.Positions--import           Theory.Model------ Variants of intruder deduction rules----------------------------------------------------------------------------------------------------------------------------------------------------------- Special Intruder rules---------------------------------------------------------------------------------{--These are the special intruder that are always included.--rule (modulo AC) coerce:-   [ KD( f_, x ) ] --[ KU( f_, x) ]-> [ KU( f_, x ) ]--rule (modulo AC) pub:-   [ ] --[ KU( f_, $x) ]-> [ KU( f_, $x ) ]--rule (modulo AC) gen_fresh:-   [ Fr( ~x ) ] --[ KU( 'noexp', ~x ) ]-> [ KU( 'noexp', ~x ) ]--rule (modulo AC) isend:-   [ KU( f_, x) ] --[ K(x) ]-> [ In(x) ]--rule (modulo AC) irecv:-   [ Out( x) ] --> [ KD( 'exp', x) ]---}--- | @specialIntruderRules@ returns the special intruder rules that are---   included independently of the message theory-specialIntruderRules :: [IntrRuleAC]-specialIntruderRules =-    [ kuRule CoerceRule      [kdFact x_var]                 (x_var)-    , kuRule PubConstrRule   []                             (x_pub_var)-    , kuRule FreshConstrRule [Fact FreshFact [x_fresh_var]] (x_fresh_var)-    , Rule ISendRule [kuFact x_var]  [Fact InFact [x_var]] [kLogFact x_var]-    , Rule IRecvRule [Fact OutFact [x_var]] [Fact KDFact [x_var]] []-    ]-  where-    kuRule name prems t = Rule name prems [kuFact t] [kuFact t]--    x_var       = varTerm (LVar "x"  LSortMsg   0)-    x_pub_var   = varTerm (LVar "x"  LSortPub   0)-    x_fresh_var = varTerm (LVar "x"  LSortFresh 0)------------------------------------------------------------------------------------ Subterm Intruder theory----------------------------------------------------------------------------------- | @destuctionRules st@ returns the destruction rules for the given--- subterm rule @st@-destructionRules :: StRule -> [IntrRuleAC]-destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) =-    go [] lhs pos-  where-    rhs = lhs `atPos` pos-    go _      _                       []     = []-    -- term already in premises-    go _      (viewTerm -> FApp _ _)  (_:[]) = []-    go uprems (viewTerm -> FApp _ as) (i:p)  =-        irule ++ go uprems' t' p-      where-        uprems' = uprems++[ t | (j, t) <- zip [0..] as, i /= j ]-        t'      = as!!i-        irule = if (t' /= rhs && rhs `notElem` uprems')-                then [ Rule (DestrRule f)-                            ((kdFact  t'):(map kuFact uprems'))-                            [kdFact rhs] [] ]-                else []-    go _      (viewTerm -> Lit _)     (_:_)  =-        error "IntruderRules.destructionRules: impossible, position invalid"--destructionRules _ = []---- | Simple removal of subsumed rules for auto-generated subterm intruder rules.-minimizeIntruderRules :: [IntrRuleAC] -> [IntrRuleAC]-minimizeIntruderRules rules =-    go [] rules-  where-    go checked [] = reverse checked-    go checked (r@(Rule _ prems concs _):unchecked) = go checked' unchecked-      where-        checked' = if any (\(Rule _ prems' concs' _)-                               -> concs' == concs && prems' `subsetOf` prems)-                          (checked++unchecked)-                   then checked-                   else r:checked---- | @subtermIntruderRules maudeSig@ returns the set of intruder rules for---   the subterm (not Xor, DH, and MSet) part of the given signature.-subtermIntruderRules :: MaudeSig -> [IntrRuleAC]-subtermIntruderRules maudeSig =-     minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig)-     ++ constructionRules (functionSymbols maudeSig)---- | @constructionRules fSig@ returns the construction rules for the given--- function signature @fSig@-constructionRules :: FunSig -> [IntrRuleAC]-constructionRules fSig =-    [ createRule s k | (s,k) <- S.toList fSig ]-  where-    createRule s k = Rule (ConstrRule s) (map kuFact vars) [concfact] [concfact]-      where vars     = take k [ varTerm (LVar "x"  LSortMsg i) | i<- [0..] ]-            m        = fApp (NonAC (s,k)) vars-            concfact = kuFact m------------------------------------------------------------------------------------ Diffie-Hellman Intruder Rules----------------------------------------------------------------------------------- | @dhIntruderRules@ computes the intruder rules for DH-dhIntruderRules :: WithMaude [IntrRuleAC]-dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $-    [ expRule ConstrRule kuFact return-    , invRule ConstrRule kuFact return-    ] ++-    concatMap (variantsIntruder hnd)-      [ expRule DestrRule kdFact (const [])-      , invRule DestrRule kdFact (const [])-      ]-  where-    x_var_0 = varTerm (LVar "x" LSortMsg 0)-    x_var_1 = varTerm (LVar "x" LSortMsg 1)--    expRule mkInfo kudFact mkAction =-        Rule (mkInfo expSymString) [bfact, efact] [concfact] (mkAction concfact)-      where-        bfact = kudFact x_var_0-        efact = kuFact  x_var_1-        conc = fAppExp (x_var_0, x_var_1)-        concfact = kudFact conc--    invRule mkInfo kudFact mkAction =-        Rule (mkInfo invSymString) [bfact] [concfact] (mkAction concfact)-      where-        bfact    = kudFact x_var_0-        conc = fAppInv x_var_0-        concfact = kudFact conc----- | @variantsIntruder mh irule@ computes the deconstruction-variants--- of a given intruder rule @irule@-variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC]-variantsIntruder hnd ru = do-    let ruleTerms = concatMap factTerms-                              (get rPrems ru++get rConcs ru++get rActs ru)-    fsigma <- computeVariants (fAppList ruleTerms) `runReader` hnd-    let sigma     = freshToFree fsigma `evalFreshAvoiding` ruleTerms-        ruvariant = normRule' (apply sigma ru) `runReader` hnd-    guard (frees (get rConcs ruvariant) /= [] &&-           -- ground terms are already deducible by applying construction rules-           ruvariant /= ru &&-           -- this is a construction rule-           (get rConcs ruvariant) \\ (get rPrems ruvariant) /= []-           -- The conclusion is included in the premises-           )--    case concatMap factTerms $ get rConcs ruvariant of-        [viewTerm -> FApp (AC Mult) _] ->-            fail "Rules with product conclusion are redundant"-        _                                 -> return ruvariant---- | @normRule irule@ computes the normal form of @irule@-normRule' :: IntrRuleAC -> WithMaude IntrRuleAC-normRule' (Rule i ps cs as) = reader $ \hnd ->-    let normFactTerms = map (fmap (\t -> norm' t `runReader` hnd)) in-    Rule i (normFactTerms ps) (normFactTerms cs) (normFactTerms as)
− src/Theory/Tools/LoopBreakers.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- |--- Copyright   : (c) 2012 Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Computate the loop-breakers in the premise-conclusion graph of a set of--- multiset rewriting rules.-module Theory.Tools.LoopBreakers (--  -- * Computing loop breakers for solving premises-  useAutoLoopBreakersAC-  ) where--import Control.Applicative-import Control.Monad.Fresh-import Control.Monad.Reader--import Data.DAG.Simple--import Theory.Model----- | An over-approximation of the dependency of solving premises. An element--- @((fromRu, fromPrem), (toRu, toPrem))@ denotes that solving the premise--- @(fromRu,fromPrem)@ might lead to a case where the premise @(toRu, toPrem)@--- is open.-premSolvingRelAC :: (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises-                 -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions-                 -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants-                 -> [a]                         -- ^ Base carrier-                 -> WithMaude (Relation (a, PremIdx))-premSolvingRelAC ePrems eConcs eVariants rules = reader $ \hnd -> do-    (toRu, from) <- dataflowRelAC hnd-    (toPrem, _)  <- ePrems toRu-    return (from, (toRu, toPrem))-  where-    -- An over-approxmiation of the dataflow relation. An element @(fromRu,-    -- (toRu, toPrem))@ denotes that there is a conclusion of @fromRu@-    -- unifying with the premise @(toRu, toPrem)@.-    dataflowRelAC hnd = do-        ruFrom <- rules-        ruTo   <- rules-        (premIdx, premFa0) <- ePrems ruTo-        guard $ or $ do-            premFa <- instances ruTo premFa0-            concFa <- instances ruFrom =<< (snd <$> eConcs ruFrom)-            let concFaFresh = rename concFa `evalFresh` avoid premFa-            return $ (`runReader` hnd) (unifiableLNFacts concFaFresh premFa)-        return (ruFrom, (ruTo, premIdx))--    instances ru fa = do-        subst <- eVariants ru-        return (apply (subst `freshToFreeAvoiding` fa) fa)----- | Replace all loop-breaker information with loop-breakers computed--- automatically from the dataflow relation 'dataflowRelAC'.-useAutoLoopBreakersAC-  :: Ord a-  => (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises-  -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions-  -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants-  -> ([PremIdx] -> a -> a)       -- ^ Add annotation-  -> [a]                         -- ^ Original rules-  -> WithMaude ([a], Relation (a, PremIdx), [(a, PremIdx)])-  -- ^ Annotated rules and the premise solving relation-useAutoLoopBreakersAC ePrems eConcs eVariants addAnn rules =-    reader $ \hnd ->-      let solveRel = (`runReader` hnd) $-              premSolvingRelAC ePrems eConcs eVariants rules-          breakers = dfsLoopBreakers $ solveRel-      in ( do ru <- rules-              return (addAnn [ u | (ru', u) <- breakers, ru == ru' ] ru)-         , solveRel-         , breakers-         )-
− src/Theory/Tools/RuleVariants.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE ViewPatterns               #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Variants of protocol rules.-module Theory.Tools.RuleVariants where--import           Term.Narrowing.Variants-import           Term.Rewriting.Norm-import           Theory.Model-import           Theory.Tools.EquationStore--import           Extension.Prelude-import           Logic.Connectives--import           Control.Applicative-import           Control.Monad.Bind-import           Control.Monad.Reader-import qualified Control.Monad.Trans.PreciseFresh as Precise--import qualified Data.Map                         as M-import qualified Data.Set                         as S-import           Data.Traversable                 (traverse)--import           Debug.Trace.Ignore---- Variants of protocol rules--------------------------------------------------------------------------- | Compute the variants of a protocol rule.---   1. Abstract away terms in facts with variables.---   2. Compute variants of RHSs of equations.---   3. Apply variant substitutions to equations---      to obtain DNF of equations.---   4. Simplify rule.-variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC-variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) =-    -- rename rule to decrease variable indices-    (`Precise.evalFresh` Precise.nothingUsed) . renamePrecise  $ convertRule `evalFreshAvoiding` ru-  where-    convertRule = do-        (abstrPsCsAs, bindings) <- abstrRule-        let eqsAbstr         = map swap (M.toList bindings)-            abstractedTerms  = map snd eqsAbstr-            abstractionSubst = substFromList eqsAbstr-            variantSubsts    = computeVariants (fAppList abstractedTerms) `runReader` hnd-            substs           = [ restrictVFresh (frees abstrPsCsAs) $-                                   removeRenamings $ ((`runReader` hnd) . normSubstVFresh')  $-                                   composeVFresh vsubst abstractionSubst-                               | vsubst <- variantSubsts ]--        case substs of-          [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'"-          _  -> do-              -- x <- return (emptySubst, Just substs) ---              x <- simpDisjunction hnd (const False) (Disj substs)-              case trace (show ("SIMP",abstractedTerms,-                                "abstr", abstrPsCsAs,-                                "substs", substs,-                                "simpSubsts:", x)) x of-                -- the variants can be simplified to a single case-                (commonSubst, Nothing) ->-                  return $ makeRule abstrPsCsAs commonSubst trueDisj-                (commonSubst, Just freshSubsts) ->-                  return $ makeRule abstrPsCsAs commonSubst freshSubsts--    abstrRule = (`runBindT` noBindings) $ do-        -- first import all vars into binding to obtain nicer names-        mapM_ abstrTerm [ varTerm v | v <- frees (prems0, concs0, acts0) ]-        (,,) <$> mapM abstrFact prems0-             <*> mapM abstrFact concs0-             <*> mapM abstrFact acts0--    irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd)-    abstrFact = traverse abstrTerm-    abstrTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =-        fAppNonAC o <$> mapM abstrTerm args-    abstrTerm t = do-        at :: LNTerm <- varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t)-        return at-      where getHint (viewTerm -> Lit (Var v)) = lvarName v-            getHint _                         = "z"--    makeRule (ps, cs, as) subst freshSubsts0 =-        Rule (ProtoRuleACInfo ri (Disj freshSubsts) []) prems concs acts-      where prems = apply subst ps-            concs = apply subst cs-            acts  = apply subst as-            freshSubsts = map (restrictVFresh (frees (prems, concs, acts))) freshSubsts0--    trueDisj = [ emptySubstVFresh ]
− src/Theory/Tools/Wellformedness.hs 
@@ -1,519 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Wellformedness checks for intruder variants, protocol rules, and--- properties.------ The following checks are/should be performed--- (FIXME: compare the list below to what is really implemented.)------   [protocol rules]------     1. no fresh names in rule. (protocol cond. 1)---     ==> freshNamesReport------     2. no Out or K facts in premises. (protocol cond. 2)---     ==> factReports------     3. no Fr, In, or K facts in conclusions. (protocol cond. 3)---     ==> factReports------     4. vars(rhs) subset of vars(lhs) u V_Pub---     ==> multRestrictedReport------     5. lhs does not contain reducible function symbols (*-restricted (a))---     ==> multRestrictedReport------     6. rhs does not contain * (*-restricted (b))---     ==> multRestrictedReport------     7. all facts are used with the same arity.------     8. fr, in, and out, facts are used with arity 1.------     9. fr facts are used with a variable of sort msg or sort fresh------     10. fresh facts of the same rule contain different variables. [TODO]------     11. no protocol fact uses a reserved name =>---        [TODO] change parser to ensure this and pretty printer to show this.------   [security properties]------     1. all facts occur with the same arity in the action of some---        protocol rule.------     2. no node variable is used in a message position and vice versa.-------module Theory.Tools.Wellformedness (--  -- * Wellformedness checking-    WfErrorReport-  , checkWellformedness-  , noteWellformedness--  , prettyWfErrorReport-  ) where--import           Prelude                     hiding (id, (.))--import           Control.Basics-import           Control.Category-import           Data.Char-import           Data.Generics.Uniplate.Data (universeBi)-import           Data.Label-import           Data.List-import           Data.Maybe-import           Data.Monoid                 (mappend, mempty)-import qualified Data.Set                    as S-import           Data.Traversable            (traverse)--import           Control.Monad.Bind--import           Extension.Prelude-import           Term.LTerm-import           Term.Maude.Signature-import           Theory-import           Theory.Text.Pretty----------------------------------------------------------------------------------- Types for error reports---------------------------------------------------------------------------------type Topic         = String-type WfError       = (Topic, Doc)-type WfErrorReport = [WfError]--prettyWfErrorReport :: WfErrorReport -> Doc-prettyWfErrorReport =-    vcat . intersperse (text "") . map ppTopic . groupOn fst-  where-    ppTopic []                 = error "prettyWfErrorReport: groupOn returned empty list"-    ppTopic errs@((topic,_):_) =-      text topic <> colon $-$-      (nest 2 . vcat . intersperse (text "") $ map snd errs)------------------------------------------------------------------------------------ Utilities----------------------------------------------------------------------------------- | All protocol rules of a theory.--- thyProtoRules :: OpenTheory ->-thyProtoRules :: OpenTheory -> [ProtoRuleE]-thyProtoRules thy = [ ru | RuleItem ru <- get thyItems thy ]---- | Lower-case a string.-lowerCase :: String -> String-lowerCase = map toLower---- | Pretty-print a comma, separated list of 'LVar's.-prettyVarList :: Document d => [LVar] -> d-prettyVarList = fsep . punctuate comma . map prettyLVar---- | Pretty-print a comma, separated list of 'LNTerms's.-prettyLNTermList :: Document d => [LNTerm] -> d-prettyLNTermList = fsep . punctuate comma . map prettyLNTerm---- | Wrap strings at word boundaries.-wrappedText :: Document d => String -> d-wrappedText = fsep . map text . words---- | Clashes-clashesOn :: (Ord b, Ord c)-          => (a -> b) -- ^ This projection-          -> (a -> c) -- ^ must determine this projection.-          -> [a] -> [[a]]-clashesOn f g xs = do-    grp <- groupOn f $ sortOn f xs-    guard (length (sortednubOn g grp) >= 2)-    return grp---- | Nice quoting.-quote :: String -> String-quote cs = '`' : cs ++ "'"----------------------------------------------------------------------------------- Checks------------------------------------------------------------------------------------ | Check that the protocol rules are well-formed.-sortsClashCheck :: HasFrees t => String -> t -> WfErrorReport-sortsClashCheck info t = case clashesOn removeSort id $ frees t of-    [] -> []-    cs -> return $-            ( "sorts"-            , text info $-$ (nest 2 $ numbered' $ map prettyVarList cs)-            )-  where-    removeSort lv = (lowerCase (lvarName lv), lvarIdx lv)---- | Report on sort clashes.-ruleSortsReport :: OpenTheory -> WfErrorReport-ruleSortsReport thy = do-    ru <- thyProtoRules thy-    sortsClashCheck ("rule " ++ quote (showRuleCaseName ru) ++-                     " clashing sorts, casings, or multiplicities:") ru---- | Report on fresh names.-freshNamesReport :: OpenTheory -> WfErrorReport-freshNamesReport thy = do-    ru <- thyProtoRules thy-    case filter ((LSortFresh ==) . sortOfName) $ universeBi ru of-      []    -> []-      names -> return $ (,) "fresh names" $ fsep $-          text ( "rule " ++ quote (showRuleCaseName ru) ++ ": " ++-                 "fresh names are not allowed in rule:" )-        : punctuate comma (map (nest 2 . text . show) names)---- | Report on capitalization of public names.-publicNamesReport :: OpenTheory -> WfErrorReport-publicNamesReport thy =-    case findClashes publicNames of-      []      -> []-      clashes -> return $ (,) topic $ numbered' $-          map (nest 2 . fsep . punctuate comma . map ppRuleAndName) clashes-  where-    topic       = "public names with mismatching capitalization"-    publicNames = do-        ru <- thyProtoRules thy-        (,) (showRuleCaseName ru) <$>-            (filter ((LSortPub ==) . sortOfName) $ universeBi ru)-    findClashes   = clashesOn (map toLower . show . snd) (show . snd)-    ppRuleAndName (ruName, pub) =-        text $ "rule " ++ show ruName ++ " name " ++ show pub---- | Check whether a rule has unbound variables.-unboundCheck :: HasFrees i => String -> Rule i -> WfErrorReport-unboundCheck info ru-    | null unboundVars = []-    | otherwise        = return $-        ( "unbound"-        , text info $-$ (nest 2 $ prettyVarList unboundVars) )-  where-    boundVars   = S.fromList $ frees (get rPrems ru)-    unboundVars = do-        v <- frees (get rConcs ru, get rActs ru, get rInfo ru)-        guard $ not (lvarSort v == LSortPub || v `S.member` boundVars)-        return v---- | Report on sort clashes.-unboundReport :: OpenTheory -> WfErrorReport-unboundReport thy = do-    RuleItem ru <- get thyItems thy-    unboundCheck ("rule " ++ quote (showRuleCaseName ru) ++-                  " has unbound variables: "-                 ) ru---- | Report on facts usage.-factReports :: OpenTheory -> WfErrorReport-factReports thy = concat-    [ reservedReport, freshFactArguments, specialFactsUsage-    , factUsage, inexistentActions-    ]-  where-    ruleFacts ru =-      ( "rule " ++ quote (showRuleCaseName ru)-      , extFactInfo <$> concatMap (`get` ru) [rPrems, rActs, rConcs])--    -- NOTE: The check that the number of actual function arguments in a term-    -- agrees with the arity of the function as given by the signature is-    -- enforced by the parser and implicitly checked in 'factArity'.--    theoryFacts = -- sortednubOn (fst &&& (snd . snd)) $-          do ruleFacts <$> get thyCache thy-      <|> do RuleItem ru <- get thyItems thy-             return $ ruleFacts ru-      <|> do LemmaItem l <- get thyItems thy-             return $ (,) ("lemma " ++ quote (get lName l)) $ do-                 fa <- formulaFacts (get lFormula l)-                 return $ (text (show fa), factInfo fa)--    -- we must compute all important information up-front in order to-    -- mangle facts with terms with bound variables and such without them-    extFactInfo fa = (prettyLNFact fa, factInfo fa)--    factInfo :: Fact t -> (FactTag, Int, Multiplicity)-    factInfo fa    = (factTag fa, factArity fa, factMultiplicity fa)--    --- Check for usage of protocol facts with reserved names-    reservedReport = do-        (origin, fas) <- theoryFacts-        case mapMaybe reservedFactName fas of-          []   -> []-          errs -> return $ (,) "reseved names" $ foldr1 ($--$) $-              wrappedText ("The " ++ origin ++-                           " contains facts with reserved names:")-            : map (nest 2) errs--    reservedFactName (ppFa, info@(ProtoFact _ name _, _,_))-      | map toLower name `elem` ["fr","ku","kd","out","in"] =-          return $ ppFa $-$ text ("show:" ++ show info)-    reservedFactName _ = Nothing--    freshFactArguments = do-       ru                      <- thyProtoRules thy-       fa@(Fact FreshFact [m]) <- get rPrems ru-       guard (not (isMsgVar m || isFreshVar m))-       return $ (,) "Fr facts must only use a fresh- or a msg-variable" $-           text ("rule " ++ quote (showRuleCaseName ru)) <->-           text "fact:" <-> prettyLNFact fa--    -- Check for the usage of special facts at wrong positions-    specialFactsUsage = do-       ru <- thyProtoRules thy-       let lhs = [ fa | fa <- get rPrems ru-                      , factTag fa `elem` [KUFact, KDFact, OutFact] ]-           rhs = [ fa | fa <- get rConcs ru-                      , factTag fa `elem` [FreshFact, KUFact, KDFact, InFact] ]-           check _   []  = mzero-           check msg fas = return $ (,) "special fact usage" $-               text ("rule " ++ quote (showRuleCaseName ru)) <-> text msg $-$-               (nest 2 $ fsep $ punctuate comma $ map prettyLNFact fas)--       msum [ check "uses disallowed facts on left-hand-side:"  lhs-            , check "uses disallowed facts on right-hand-side:" rhs ]--    -- Check for facts with equal name modulo capitalization, but different-    -- multiplicity or arity.-    factUsage = do-       clash <- clashesOn factIdentifier (snd . snd) theoryFacts'-       return $ (,) "fact usage" $ numbered' $ do-           (origin, (ppFa, info@(tag, _, _))) <- clash-           return $ text (origin ++-                          ", fact " ++ show (map toLower $ factTagName tag) ++-                          ": " ++ showInfo info)-                    $-$ nest 2 ppFa-      where-        showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl)-        theoryFacts'   = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ]-        factIdentifier (_, (_, (tag, _, _))) = map toLower $ factTagName tag---    -- Check that every fact referenced in a formula is present as an action-    -- of a protocol rule. We have to add the linear "K/1" fact, as the-    -- WF-check cannot rely on a loaded intruder theory.-    ruleActions = S.fromList $ map factInfo $-          kLogFact undefined-        : dedLogFact undefined-        : kuFact undefined-        : (do RuleItem ru <- get thyItems thy; get rActs ru)--    inexistentActions = do-        LemmaItem l <- get thyItems thy-        fa <- sortednub $ formulaFacts (get lFormula l)-        let info = factInfo fa-            name = get lName l-        if info `S.member` ruleActions-          then []-          else return $ (,) "lemma actions" $-                 text ("lemma " ++ quote name ++ " references action ") $-$-                 nest 2 (text $ show info) $-$-                 text "but no rule has such an action."----- | Gather all facts referenced in a formula.-formulaFacts :: Formula s c v -> [Fact (VTerm c (BVar v))]-formulaFacts =-    foldFormula atomFacts-      (const mempty)-      id-      (const mappend) (const $ const id)-  where-    atomFacts (Action _ fa)   = [fa]-    atomFacts (EqE _ _)       = mempty-    atomFacts (Less _ _)      = mempty-    atomFacts (Last _)        = mempty---- | Gather all terms referenced in a formula.-formulaTerms :: Formula s c v -> [VTerm c (BVar v)]-formulaTerms =-    foldFormula atomTerms (const mempty) id (const mappend) (const $ const id)-  where-    atomTerms (Action i fa)   = i : factTerms fa-    atomTerms (EqE t s)       = [t, s]-    atomTerms (Less i j)      = [i, j]-    atomTerms (Last i)        = [i]---- TODO: Perhaps a lot of errors would be captured when making the signature--- of facts, term, and atom constructors explicit.-lemmaAttributeReport :: OpenTheory -> WfErrorReport-lemmaAttributeReport thy = do-    lem <- theoryLemmas thy-    guard $    get lTraceQuantifier lem == ExistsTrace-            && ReuseLemma `elem` get lAttributes lem-    return ( "attributes"-           , text "lemma" <-> (text $ quote $ get lName lem) <> colon <->-             text "cannot reuse 'exists-trace' lemmas"-           )---- | Check for mistakes in lemmas.------ TODO: Perhaps a lot of errors would be captured when making the signature--- of facts, term, and atom constructors explicit.-formulaReports :: OpenTheory -> WfErrorReport-formulaReports thy = do-    (header, fm) <- annFormulas-    msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fm-         , ((,) "formula terms")    <$> checkTerms header fm-         , ((,) "guardedness")      <$> checkGuarded header fm-         ]-  where-    annFormulas = do LemmaItem l <- get thyItems thy-                     let header = "lemma " ++ quote (get lName l)-                         fm     = get lFormula l-                     return (header, fm)-              <|> do AxiomItem ax <- get thyItems thy-                     let header = "axiom " ++ quote (get axName ax)-                         fm     = get axFormula ax-                     return (header, fm)--    -- check that only message and node variables are used-    checkQuantifiers header fm-      | null disallowed = []-      | otherwise       = return $ fsep $-          (text $ header ++ "uses quantifiers with wrong sort:") :-          (punctuate comma $ map (nest 2 . text . show) disallowed)-      where-        binders    = foldFormula (const mempty) (const mempty) id (const mappend)-                         (\_ binder rest -> binder : rest) fm-        disallowed = filter (not . (`elem` [LSortMsg, LSortNode]) . snd) binders--    -- check that only bound variables and public names are used-    checkTerms header fm-      | null offenders = []-      | otherwise      = return $-          (fsep $-            (text $ header ++ " uses terms of the wrong form:") :-            (punctuate comma $ map (nest 2 . text . quote . show) offenders)-          ) $--$-          wrappedText-            "The only allowed terms are public names and bound node and message\-            \ variables. If you encounter free message variables, then you might\-            \ have forgotten a #-prefix. Sort prefixes can only be dropped where\-            \ this is unambiguous."-      where-        offenders = filter (not . allowed) $ formulaTerms fm-        allowed (viewTerm -> Lit (Var (Bound _)))        = True-        allowed (viewTerm -> Lit (Con (Name PubName _))) = True-        allowed _                                        = False--    -- check that the formula can be converted to a guarded formula-    checkGuarded header fm = case formulaToGuarded fm of-        Left err -> return $-            text (header ++ " cannot be converted to a guarded formula:") $-$-            nest 2 err-        Right _  -> []------- | Check that all rules are multipliation restricted. Compared--- to the definition in the paper we are slightly more lenient.--- We also accept a rule that is an instance of a multiplication--- restricted rule.--- 1. Consistently abstract terms with outermost reducible function symbols---    occuring in lhs with fresh variables in rule.--- 2. check vars(rhs) subset of vars(lhs) u V_Pub for abstracted rule for abstracted variables.--- 3. check that * does not occur in rhs of abstracted rule.-multRestrictedReport :: OpenTheory -> WfErrorReport-multRestrictedReport thy = do-    ru <- theoryRules thy-    (,) "multiplication restriction of rules" <$>-        case restrictedFailures ru of-          ([],[]) -> []-          (mults, unbounds) ->-              return $-                (text "The following rule is not multiplication restricted:")-                $-$ (nest 2 (prettyProtoRuleE ru))-                $-$ (text "")-                $-$ (text "After replacing reducible function symbols in lhs with variables:")-                $-$ (nest 2 $ prettyProtoRuleE (abstractRule ru))-                $-$ (text "")-                $-$ (if null mults then mempty-                     else nest 2 $ (text "Terms with multiplication: ") <-> (prettyLNTermList mults))-                $-$ (if null unbounds then mempty-                     else nest 2 $ (text "Variables that occur only in rhs: ") <-> (prettyVarList unbounds))-  where-    abstractRule ru@(Rule i lhs acts rhs) =-        (`evalFreshAvoiding` ru) .  (`evalBindT` noBindings) $ do-        Rule i <$> mapM (traverse abstractTerm) lhs-               <*> mapM (traverse replaceAbstracted) acts-               <*> mapM (traverse replaceAbstracted) rhs--    abstractTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =-        fAppNonAC o <$> mapM abstractTerm args-    abstractTerm (viewTerm -> Lit l) = return $ lit l-    abstractTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t "x"--    replaceAbstracted t = do-        b <- lookupBinding t-        case b of-          Just v -> return $ varTerm v-          Nothing ->-              case viewTerm t of-                FApp o args ->-                    fApp o <$> mapM replaceAbstracted args-                Lit l       -> return $ lit l--    restrictedFailures ru = (mults, unbound ruAbstr \\ unbound ru)-      where-        ruAbstr = abstractRule ru--        mults = [ mt | Fact _ ts <- get rConcs ru, t <- ts, mt <- multTerms t ]--        multTerms t@(viewTerm -> FApp (AC Mult) _)  = [t]-        multTerms   (viewTerm -> FApp _         as) = concatMap multTerms as-        multTerms _                                 = []--    unbound ru = [v | v <- frees (get rConcs ru) \\ frees (get rPrems ru)-                 , lvarSort v /= LSortPub ]---    irreducible = irreducibleFunctionSymbols $ get (sigpMaudeSig . thySignature) thy------ | All 2-multicombinations of a list.--- multicombine2 :: [a] -> [(a,a)]--- multicombine2 xs0 = do (x,xs) <- zip xs0 $ tails xs0; (,) x <$> xs------------------------------------------------------------------------------------ Theory------------------------------------------------------------------------------------- | Returns a list of errors, if there are any.-checkWellformedness :: OpenTheory-                    -> WfErrorReport-checkWellformedness thy = concatMap ($ thy)-    [ unboundReport-    , freshNamesReport-    , publicNamesReport-    , ruleSortsReport-    , factReports-    , formulaReports-    , lemmaAttributeReport-    , multRestrictedReport-    ]---- | Adds a note to the end of the theory, if it is not well-formed.-noteWellformedness :: WfErrorReport -> OpenTheory -> OpenTheory-noteWellformedness report thy =-    addComment wfErrorReport thy-  where-    wfErrorReport-      | null report = text "All well-formedness checks were successful."-      | otherwise   = vsep-          [ text "WARNING: the following wellformedness checks failed!"-          , prettyWfErrorReport report-          ]-
src/Web/Dispatch.hs view
@@ -138,18 +138,11 @@              -> AutoProver              -> IO TheoryMap loadTheories readyMsg thDir thLoader autoProver = do-    mkImageDir     thPaths <- filter (".spthy" `isSuffixOf`) <$> getDirectoryContents thDir     theories <- catMaybes <$> mapM loadThy (zip [1..] (map (thDir </>) thPaths))     putStrLn readyMsg     return $ M.fromList theories   where-    -- Create image directory-    mkImageDir = do-      let dir = thDir </> imageDir-      existsDir <- doesDirectoryExist dir-      unless existsDir (createDirectory dir)-     -- Load theories     loadThy (idx, path) = E.handle catchEx $ do         thy <- thLoader path
src/Web/Hamlet.hs view
@@ -32,7 +32,7 @@ import           Data.Ord import           Data.Time.Format import           Data.Version           (showVersion)-import           Text.Blaze.Html5       (preEscapedString)+import           Text.Blaze.Html        (preEscapedToMarkup)  import           System.Locale @@ -60,6 +60,7 @@         -> Widget -- rootTpl theories form enctype nonce = [whamlet| rootTpl theories = [whamlet|+    $newline never     <div class="ui-layout-container">       <div class="ui-layout-north">         <div class="ui-layout-pane">@@ -88,6 +89,7 @@ -- | Template for listing theories. theoriesTpl :: TheoryMap -> Widget theoriesTpl thmap = [whamlet|+    $newline never     $if M.null thmap       <strong>No theories loaded!</strong>     $else@@ -118,6 +120,7 @@ -- | Template for single line in table on root page. theoryTpl :: (TheoryIdx, TheoryInfo) -> Widget theoryTpl th = [whamlet|+    $newline never     <tr>       <td>         <a href=@{OverviewR (fst th) TheoryHelp}>@@ -139,6 +142,7 @@ -- threadsTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => [T.Text] -> h {- threadsTpl threads = [whamlet|+    $newline never     <h2>Threads     <p>       This page lists all threads that are currently registered as@@ -161,6 +165,7 @@ -- | Template for header frame (various information) headerTpl :: TheoryInfo -> Widget headerTpl info = [whamlet|+    $newline never     <div class="layout-pane-north">       <div #header-info>         Running@@ -200,7 +205,9 @@ proofStateTpl :: RenderUrl -> TheoryInfo -> IO Widget proofStateTpl renderUrl ti = do     let res = renderHtmlDoc $ theoryIndex renderUrl (tiIndex ti) (tiTheory ti)-    return [whamlet| #{preEscapedString res} |]+    return [whamlet|+              $newline never+              #{preEscapedToMarkup res} |]  -- | Framing/UI-layout template (based on JavaScript/JQuery) overviewTpl :: RenderUrl@@ -211,6 +218,7 @@   proofState <- proofStateTpl renderUrl info   mainView <- pathTpl renderUrl info path   return [whamlet|+    $newline never     <div .ui-layout-north>       ^{headerTpl info}     <div .ui-layout-west>@@ -235,11 +243,14 @@         -> TheoryPath   -- ^ Path to display on load         -> IO Widget pathTpl renderUrl info path =-    return $ [whamlet| #{htmlThyPath renderUrl info path} |]+    return $ [whamlet|+                $newline never+                #{htmlThyPath renderUrl info path} |]  -- | Template for introduction. introTpl :: Widget introTpl = [whamlet|+    $newline never       <div id="logo">         <p>           <img src="/static/img/tamarin-logo-3-0-0.png">@@ -278,6 +289,7 @@ --         -> Html        -- ^ Nonce field --         -> h formTpl action label form enctype nonce = [whamlet|+    $newline never     <form action=@{action} method=POST enctype=#{enctype}>       ^{form}       <div .submit-form>
src/Web/Handler.hs view
@@ -63,9 +63,11 @@ import           Data.String                  (fromString) import           Data.List                    (intersperse) import           Data.Monoid                  (mconcat)+import           Data.Conduit                 as C ( ($$), runResourceT)+import           Data.Conduit.List            (consume)  import qualified Blaze.ByteString.Builder     as B-import qualified Data.ByteString.Lazy.Char8   as BS+import qualified Data.ByteString.Char8        as BS import qualified Data.Map                     as M import qualified Data.Text                    as T import           Data.Text.Encoding@@ -326,7 +328,7 @@     theories <- getTheories     defaultLayout $ do       setTitle "Welcome to the Tamarin prover"-      addWidget (rootTpl theories)+      rootTpl theories  data File = File T.Text   deriving Show@@ -337,21 +339,24 @@     case result of       Nothing ->         setMessage "Post request failed."-      Just fileinfo-        | BS.null $ fileContent fileinfo -> setMessage "No theory file given."-        | otherwise                      -> do-            yesod <- getYesod-            closedThy <- liftIO $ parseThy yesod (BS.unpack $ fileContent fileinfo)-            case closedThy of-              Left err  -> setMessage $ "Theory loading failed:\n" <> toHtml err-              Right thy -> do-                  void $ putTheory Nothing-                           (Just $ Upload $ T.unpack $ fileName fileinfo) thy-                  setMessage "Loaded new theory!"+      Just fileinfo -> do+          -- content <- liftIO $ LBS.fromChunks <$> (fileSource fileinfo $$ consume)+          content <- liftIO $ runResourceT (fileSource fileinfo C.$$ consume)+          if null content+            then setMessage "No theory file given."+            else do+              yesod <- getYesod+              closedThy <- liftIO $ parseThy yesod (concatMap BS.unpack content)+              case closedThy of+                Left err  -> setMessage $ "Theory loading failed:\n" <> toHtml err+                Right thy -> do+                    void $ putTheory Nothing+                             (Just $ Upload $ T.unpack $ fileName fileinfo) thy+                    setMessage "Loaded new theory!"     theories <- getTheories     defaultLayout $ do       setTitle "Welcome to the Tamarin prover"-      addWidget (rootTpl theories)+      rootTpl theories   -- | Show overview over theory (framed layout).@@ -361,7 +366,7 @@   defaultLayout $ do     overview <- liftIO $ overviewTpl renderF ti path     setTitle (toHtml $ "Theory: " ++ get thyName (tiTheory ti))-    addWidget overview+    overview  -- | Show source (pretty-printed open theory). getTheorySourceR :: TheoryIdx -> Handler RepPlain
src/Web/Theory.hs view
@@ -26,6 +26,8 @@   ) where +import           Debug.Trace                  (trace)+ import           Data.Char                    (toUpper) import           Data.List import qualified Data.Map                     as M@@ -44,7 +46,7 @@  import           Extension.Data.Label -import           Text.Blaze.Html5             (preEscapedString, toHtml)+import           Text.Blaze.Html              (preEscapedToMarkup, toHtml) import qualified Text.Dot                     as D import           Text.Hamlet                  (Html, hamlet) import           Text.PrettyPrint.Html@@ -391,7 +393,7 @@     pp :: HtmlDoc Doc -> Html     pp d = case renderHtmlDoc d of       [] -> toHtml "Trying to render document yielded empty string. This is a bug."-      cs -> preEscapedString cs+      cs -> preEscapedToMarkup cs      go (TheoryMethod _ _ _)      = pp $ text "Cannot display theory method." @@ -408,6 +410,7 @@     go (TheoryLemma _)      = pp $ text "Implement lemma pretty printing!"      go TheoryHelp           = [hamlet|+        $newline never         <p>           Theory: #{get thyName $ tiTheory info}           \ (Loaded at #{formatTime defaultTimeLocale "%T" $ tiTime info}@@ -563,7 +566,8 @@           ]       if imgGenerated         then return imgPath-        else return $ imageDir ++ "/img/delete.png"+        else trace ("WARNING: failed to convert:\n  '" ++ dotPath ++ "'")+                   (return imgPath)      dotToImg dotMode dotFile imgFile = do       (ecode,_out,err) <- readProcessWithExitCode dotCommand
src/Web/Types.hs view
@@ -4,7 +4,7 @@ Copyright   :  (c) 2011 Cedric Staub License     :  GPL-3 -Maintainer  :  Cedric Staub <cstaub@ethz.ch>+Maintainer  :  Simon Meier <iridcode@gmail.com> Stability   :  experimental Portability :  non-portable -}@@ -239,16 +239,6 @@ -- Routing ------------------------------------------------------------------------------ --- Quasi-quotation syntax changed from GHC 6 to 7,--- so we need this switch in order to support both.-#if __GLASGOW_HASKELL__ >= 700-#define HAMLET hamlet-#define PARSE_ROUTES parseRoutes-#else-#define HAMLET $hamlet-#define PARSE_ROUTES $parseRoutes-#endif- -- This is a hack we need to work around a bug (?) in the -- C pre-processor. In order to define multi-pieces we need -- the asterisk symbol, but the C pre-processor always chokes@@ -329,7 +319,8 @@ defaultLayout' w = do   page <- widgetToPageContent w   message <- getMessage-  hamletToRepHtml [HAMLET|+  hamletToRepHtml [hamlet|+    $newline never     !!!     <html>       <head>
tamarin-prover.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.8 build-type:         Simple name:               tamarin-prover-version:            0.8.1.0+version:            0.8.2.0 license:            GPL license-file:       LICENSE category:           Theorem Provers@@ -73,6 +73,7 @@   -- classic security protocols   examples/classic/TLS_Handshake.spthy   examples/classic/NSLPK3.spthy+  examples/classic/NSPK3.spthy    -- loops   examples/loops/Minimal_Crypto_API.spthy@@ -80,15 +81,21 @@   examples/loops/Minimal_Create_Use_Destroy.spthy   examples/loops/Minimal_Typing_Example.spthy   examples/loops/Minimal_Loop_Example.spthy+  examples/loops/Minimal_HashChain.spthy   examples/loops/Typing_and_Destructors.spthy   examples/loops/JCS12_Typing_Example.spthy   examples/loops/TESLA_Scheme1.spthy+  examples/loops/TESLA_Scheme2_lossless.spthy+  examples/loops/TESLA_Scheme2.spthy    -- related work   examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy-  examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy+  examples/related_work/StatVerif_ARR_CSF11/StatVerif_Security_Device.spthy+  examples/related_work/StatVerif_ARR_CSF11/StatVerif_GM_Contract_Signing.spthy   examples/related_work/TPM_DKRS_CSF11/Envelope.spthy-  examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy+  examples/related_work/TPM_DKRS_CSF11/TPM_Exclusive_Secrets.spthy+  examples/related_work/YubiSecure_KS_STM12/Yubikey.spthy+  examples/related_work/YubiSecure_KS_STM12/Yubikey_and_YubiHSM.spthy    -- CSF'12 case studies   examples/csf12/Artificial.spthy@@ -157,7 +164,7 @@  executable tamarin-prover     if flag(threaded)-        ghc-options:   -threaded+        ghc-options:   -threaded -eventlog      -- Note that eager blackholing lead to segfaults: See GHC Ticket #6146     -- Morevoer, it seems that the bug is not fully fixed on GHC 7.4.2, as we@@ -183,23 +190,20 @@       -- To help the top-down solver we put the more difficult to solve yesod       -- dependencies up front.       build-depends:-        -- not direct dependencies, but wai-extra specifies its dependencies-        -- to lax and thus breaks due to the upgrade of fast-logger-          fast-logger       == 0.0.2-        , wai-logger        == 0.1.* -        , bytestring        == 0.9.*-        , blaze-html        == 0.4.*-        , http-types        == 0.6.*+          bytestring        >= 0.9+        , blaze-html        == 0.5.*+        , http-types        == 0.7.*         , blaze-builder     == 0.3.*-        , yesod-core        == 1.0.*-        , yesod-json        == 1.0.*-        , yesod-static      == 1.0.*+        , yesod-core        == 1.1.*+        , yesod-json        == 1.1.*+        , yesod-static      == 1.1.*+        , conduit           == 0.5.*         -- , yesod-form        == 0.4.*   -- required once we reactivate editing         , text              == 0.11.*-        , wai               == 1.2.*-        , hamlet            == 1.0.*-        , warp              == 1.2.*+        , wai               == 1.3.*+        , hamlet            == 1.1.*+        , warp              == 1.3.*         , aeson             == 0.6.*         , old-locale        == 1.0.*         , monad-control     == 0.3.*@@ -230,8 +234,9 @@       , parallel          == 3.2.*       , HUnit             == 1.2.* -      , tamarin-prover-utils >= 0.8.1 && < 0.9-      , tamarin-prover-term  >= 0.8.1 && < 0.9+      , tamarin-prover-utils  >= 0.8.2  && < 0.9+      , tamarin-prover-term   >= 0.8.2  && < 0.9+      , tamarin-prover-theory >= 0.8.2  && < 0.9       other-modules:@@ -249,42 +254,6 @@       Main.Mode.Intruder       Main.Mode.Test -      Theory-      Theory.Proof--      Theory.Constraint.Solver-      Theory.Constraint.Solver.CaseDistinctions-      Theory.Constraint.Solver.Contradictions-      Theory.Constraint.Solver.Goals-      Theory.Constraint.Solver.Reduction-      Theory.Constraint.Solver.Simplify-      Theory.Constraint.Solver.ProofMethod-      Theory.Constraint.Solver.Types-      Theory.Constraint.System-      Theory.Constraint.System.Dot-      Theory.Constraint.System.Guarded-      Theory.Constraint.System.Constraints--      Theory.Model-      Theory.Model.Atom-      Theory.Model.Fact-      Theory.Model.Formula-      Theory.Model.Rule-      Theory.Model.Signature--      Theory.Text.Parser-      Theory.Text.Parser.Token-      Theory.Text.Parser.UnitTests-      Theory.Text.Pretty--      Theory.Tools.AbstractInterpretation-      Theory.Tools.IntruderRules-      Theory.Tools.LoopBreakers-      Theory.Tools.RuleVariants-      Theory.Tools.Wellformedness-      Theory.Tools.EquationStore-      Theory.Tools.InjectiveFactInstances-       Web.Dispatch       Web.Hamlet       Web.Handler@@ -292,6 +261,9 @@       Web.Settings       Web.Theory       Web.Types++      Test.ParserTests+  source-repository head   type:     git