Permalink
Browse files

test: prover and parsing of proofs

  • Loading branch information...
meiersi committed Jul 17, 2012
1 parent 320965c commit d90d1a3b46d5e5efa40788a2b8517eb6a6c96233
@@ -18,11 +18,11 @@ import System.Console.CmdArgs.Explicit as CmdArgs
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
View
@@ -12,7 +12,6 @@ module Main.Mode.Test (
testMode
) where
-import Control.Applicative
import System.Console.CmdArgs.Explicit as CmdArgs
import System.Exit
import Test.HUnit (Counts(..), Test(..), runTestTT)
@@ -23,7 +22,8 @@ import Main.Console
import Main.Environment
import qualified Term.UnitTests as Term (tests)
-import qualified Theory.Text.Parser.UnitTests as Parser (testParseDirectory)
+import Theory
+import qualified Theory.Text.Parser.UnitTests as Parser
-- | Self-test mode.
@@ -55,19 +55,41 @@ run _thisMode as = do
#else
let successGraphVizDot = True
#endif
+ --------------------------------------------------------------------------
nextTopic "Testing the parser on our examples"
examplePath <- getDataFileName "examples"
- parseTests <- TestList <$> Parser.testParseDirectory 2 examplePath
- successParser <- runUnitTest parseTests
+ let mkParseTest = Parser.testParseFile Nothing
+ parseTests <- Parser.testParseDirectory mkParseTest 2 examplePath
+ successParser <- runUnitTest $ TestList parseTests
+ --------------------------------------------------------------------------
+ nextTopic "Testing the prover on some of our examples"
+
+ let heuristic = roundRobinHeuristic [SmartRanking False]
+ autoProver = AutoProver heuristic Nothing CutDFS
+ prover = Just ( maudePath as
+ , replaceSorryProver $ runAutoProver autoProver
+ )
+ mkProverTest file = do
+ fullFile <- getDataFileName file
+ return $ Parser.testParseFile prover fullFile
+
+ nslEx <- mkProverTest "examples/classic/NSLPK3.spthy"
+ loopEx <- mkProverTest "examples/loops/Minimal_Loop_Example.spthy"
+ diffieEx <- mkProverTest "examples/csf12/JKL_TS1_2008_KI.spthy"
+
+ successProver <- runUnitTest $ TestList [ nslEx, loopEx, diffieEx ]
+
+ --------------------------------------------------------------------------
nextTopic "Testing the unification infrastructure"
successTerm <- runUnitTest =<< Term.tests (maudePath as)
+ --------------------------------------------------------------------------
-- FIXME: Implement regression testing.
--
nextTopic "TEST SUMMARY"
let success = and [ successMaude, successGraphVizDot
- , successTerm, successParser ]
+ , successTerm, successParser, successProver ]
if success
then do putStrLn $ "All tests successful."
putStrLn $ "The " ++ programName ++ " should work as intended."
View
@@ -9,8 +9,7 @@
-- Theory loading infrastructure.
module Main.TheoryLoader (
-- * Static theory loading settings
- intruderVariantsFile
- , theoryLoadFlags
+ theoryLoadFlags
-- ** Loading open theories
, loadOpenThy
@@ -30,39 +29,28 @@ module Main.TheoryLoader (
import Prelude hiding (id, (.))
import Data.Char (toLower)
-import Data.Label
import Data.Monoid
import Control.Basics
import Control.Category
import Control.DeepSeq (rnf)
import System.Console.CmdArgs.Explicit
-import System.Directory
-
-import Extension.Prelude
import Theory
import Theory.Text.Parser
import Theory.Text.Pretty
import Theory.Tools.AbstractInterpretation (EvaluationStyle(..))
-import Theory.Tools.IntruderRules
import Theory.Tools.Wellformedness
import Main.Console
import Main.Environment
-import Paths_tamarin_prover (getDataFileName)
-
------------------------------------------------------------------------------
-- Theory loading: shared between interactive and batch mode
------------------------------------------------------------------------------
--- | The name of the intruder variants file.
-intruderVariantsFile :: FilePath
-intruderVariantsFile = "intruder_variants_dh.spthy"
-
-- | Flags for loading a theory.
theoryLoadFlags :: [Flag Arguments]
@@ -134,23 +122,7 @@ loadGenericThy :: (a -> IO OpenTheory)
-> Arguments
-> (a -> IO OpenTheory, OpenTheory -> IO ClosedTheory)
loadGenericThy loader as =
- (loader, (closeThy as) <=< tryAddIntrVariants)
- where
- -- intruder variants
- --------------------
- tryAddIntrVariants :: OpenTheory -> IO OpenTheory
- tryAddIntrVariants thy0 = do
- let msig = get (sigpMaudeSig . thySignature) thy0
- thy = addIntrRuleACs (subtermIntruderRules msig ++ specialIntruderRules) thy0
- if (enableDH msig) then
- do variantsFile <- getDataFileName intruderVariantsFile
- ifM (doesFileExist variantsFile)
- (do intrVariants <- parseIntruderRulesDH variantsFile
- return $ addIntrRuleACs intrVariants thy
- )
- (error $ "could not find intruder message deduction theory '"
- ++ variantsFile ++ "'")
- else return thy
+ (loader, (closeThy as) <=< addMessageDeductionRuleVariants)
-- | Close a theory according to arguments.
closeThy :: Arguments -> OpenTheory -> IO ClosedTheory
View
@@ -1,5 +1,9 @@
-{-# LANGUAGE TemplateHaskell, TupleSections, DeriveFunctor #-}
-{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-}
+{-# 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)
@@ -42,8 +46,9 @@ module Theory (
, OpenTheory
, defaultOpenTheory
, addProtoRule
- , addIntrRuleACs
, applyPartialEvaluation
+ , addIntrRuleACs
+ , normalizeTheory
-- ** Closed theories
, ClosedTheory
@@ -88,7 +93,7 @@ module Theory (
) where
-import Prelude hiding ( (.), id )
+import Prelude hiding (id, (.))
import Data.Binary
import Data.DeriveTH
@@ -113,10 +118,9 @@ 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
-import Theory.Tools.InjectiveFactInstances
-
------------------------------------------------------------------------------
-- Specific proof types
@@ -439,6 +443,31 @@ addProtoRule ruE thy = do
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.set lFormulaAC Nothing $
+ L.modify lProof stripProofAnnotations $ lem
+ RuleItem _ -> item
+ TextItem _ -> 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
@@ -518,7 +547,7 @@ closeTheoryWithMaude sig thy0 = do
proveTheory checkProof $ Theory (L.get thyName thy0) sig cache items
where
cache = closeRuleCache typAsms sig rules $ L.get thyCache thy0
- checkProof = checkAndExtendProver (sorryProver "not yet proven")
+ checkProof = checkAndExtendProver (sorryProver Nothing)
-- Maude / Signature handle
hnd = L.get sigmMaudeHandle sig
@@ -92,7 +92,7 @@ type CaseName = String
-- | Sound transformations of sequents.
data ProofMethod =
- Sorry String -- ^ Proof was not completed
+ Sorry (Maybe String) -- ^ Proof was not completed
| Solved -- ^ An attack was fond
| Simplify -- ^ A simplification step.
| SolveGoal Goal -- ^ A goal that was solved.
@@ -384,7 +384,8 @@ prettyProofMethod :: HighlightDocument d => ProofMethod -> d
prettyProofMethod method = case method of
Solved -> keyword_ "SOLVED" <-> lineComment_ "trace found"
Induction -> keyword_ "induction"
- Sorry reason -> fsep [keyword_ "sorry", lineComment_ reason]
+ Sorry reason ->
+ fsep [keyword_ "sorry", maybe emptyDoc lineComment_ reason]
SolveGoal goal ->
keyword_ "solve(" <-> prettyGoal goal <-> keyword_ ")"
Simplify -> keyword_ "simplify"
View
@@ -181,12 +181,12 @@ type Proof a = LTree CaseName (ProofStep a)
--------------------
-- | A proof using the 'sorry' proof method.
-sorry :: String -> a -> Proof a
+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 "not yet proven"
+unproven = sorry Nothing
-- Paths in proofs
@@ -235,7 +235,7 @@ boundProofDepth bound =
where
go n (LNode ps@(ProofStep _ info) cs)
| 0 < n = LNode ps $ M.map (go (pred n)) cs
- | otherwise = sorry ("bound " ++ show bound ++ " hit") info
+ | otherwise = sorry (Just $ "bound " ++ show bound ++ " hit") info
-- | Fold a proof.
foldProof :: Monoid m => (ProofStep a -> m) -> Proof a -> m
@@ -324,7 +324,8 @@ checkProof ctxt prover d sys prf@(LNode (ProofStep method info) cs) =
(Sorry reason, _ ) -> sorryNode reason cs
(_ , Just cases) -> node method $ checkChildren cases
(_ , Nothing ) ->
- sorryNode "invalid proof step encountered" (M.singleton "" prf)
+ 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)
@@ -408,7 +409,7 @@ oneStepProver method = Prover $ \ctxt _ se _ -> do
return $ LNode (ProofStep method (Just se)) (M.map (unproven . Just) cases)
-- | Replace the current proof with a sorry step and the given reason.
-sorryProver :: String -> Prover
+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.
@@ -427,7 +428,7 @@ checkAndExtendProver :: Prover -> Prover
checkAndExtendProver prover0 = Prover $ \ctxt d se prf ->
return $ mapProofInfo snd $ checkProof ctxt (prover ctxt) d se prf
where
- unhandledCase = sorry "unhandled case" Nothing
+ unhandledCase = sorry (Just "unhandled case") Nothing
prover ctxt d se =
fromMaybe unhandledCase $ runProver prover0 ctxt d se unhandledCase
@@ -462,7 +463,6 @@ contradictionProver = Prover $ \ctxt d sys prf ->
data SolutionExtractor = CutDFS | CutBFS | CutNothing
deriving( Eq, Ord, Show, Read )
-
data AutoProver = AutoProver
{ apHeuristic :: Heuristic
, apBound :: Maybe Int
@@ -566,7 +566,7 @@ cutOnSolvedBFS =
msg <- case st of
TraceFound -> return $ "ignored (attack exists)"
_ -> S.put IncompleteProof >> return "bound reached"
- return $ LNode (ProofStep (Sorry msg) x) M.empty
+ 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
Oops, something went wrong.

0 comments on commit d90d1a3

Please sign in to comment.