Commit 2b441573 authored by Michael Hanus 's avatar Michael Hanus

Proof file processing improved

parent c35604ff
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
--- (together with possible preconditions). --- (together with possible preconditions).
--- ---
--- @author Michael Hanus, Jan-Patrick Baye --- @author Michael Hanus, Jan-Patrick Baye
--- @version October 2018 --- @version November 2018
------------------------------------------------------------------------- -------------------------------------------------------------------------
import AnsiCodes import AnsiCodes
...@@ -53,7 +53,7 @@ ccBanner :: String ...@@ -53,7 +53,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine] ccBanner = unlines [bannerLine,bannerText,bannerLine]
where where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++ bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 31/10/2018)" packageVersion ++ " of 01/11/2018)"
bannerLine = take (length bannerText) (repeat '-') bannerLine = take (length bannerText) (repeat '-')
-- Help text -- Help text
...@@ -389,13 +389,15 @@ classifyTests opts prog = map makeProperty ...@@ -389,13 +389,15 @@ classifyTests opts prog = map makeProperty
-- Extracts all tests from a given Curry module and transforms -- Extracts all tests from a given Curry module and transforms
-- all polymorphic tests into tests on a base type. -- all polymorphic tests into tests on a base type.
-- The second argument contains the names of existing proof files.
-- It is used to ignore tests when the properties are already proved.
-- The third argument contains the list of function representing -- The third argument contains the list of function representing
-- proved properties. It is used to simplify post conditions to be tested. -- proved properties. It is used to simplify post conditions to be tested.
-- The result contains a triple consisting of all actual tests, -- The result contains a triple consisting of all actual tests,
-- all ignored tests, and the public version of the original module. -- all ignored tests, and the public version of the original module.
transformTests :: Options -> String -> [CFuncDecl] -> CurryProg transformTests :: Options -> [String] -> [CFuncDecl] -> CurryProg
-> IO ([CFuncDecl],[CFuncDecl],CurryProg) -> IO ([CFuncDecl],[CFuncDecl],CurryProg)
transformTests opts srcdir theofuncs transformTests opts prfnames theofuncs
prog@(CurryProg mname imps typeDecls functions opDecls) = do prog@(CurryProg mname imps typeDecls functions opDecls) = do
simpfuncs <- simplifyPostConditionsWithTheorems (optVerb opts) theofuncs funcs simpfuncs <- simplifyPostConditionsWithTheorems (optVerb opts) theofuncs funcs
let preCondOps = preCondOperations simpfuncs let preCondOps = preCondOperations simpfuncs
...@@ -404,16 +406,18 @@ transformTests opts srcdir theofuncs ...@@ -404,16 +406,18 @@ transformTests opts srcdir theofuncs
specOps = map ((\ (mn,fn) -> (mn, fromSpecName fn)) . funcName) specOps = map ((\ (mn,fn) -> (mn, fromSpecName fn)) . funcName)
(funDeclsWith isSpecName simpfuncs) (funDeclsWith isSpecName simpfuncs)
-- generate post condition tests: -- generate post condition tests:
postCondTests = concatMap (genPostCondTest preCondOps postCondOps) funcs postCondTests =
concatMap (genPostCondTest preCondOps postCondOps prfnames) funcs
-- generate specification tests: -- generate specification tests:
specOpTests = concatMap (genSpecTest preCondOps specOps) funcs specOpTests = concatMap (genSpecTest preCondOps specOps prfnames) funcs
(realtests,ignoredtests) = partition fst $ (realtests,ignoredtests) = partition fst $
if not (optProp opts) if not (optProp opts)
then [] then []
else concatMap (poly2default opts) $ else concatMap (poly2default opts) $
-- ignore already proved properties: -- ignore already proved properties:
filter (\fd -> funcName fd `notElem` map funcName theofuncs) filter (\fd -> not (existsProofFor (orgQName (funcName fd))
prfnames))
usertests ++ usertests ++
(if optSpec opts then postCondTests ++ specOpTests else []) (if optSpec opts then postCondTests ++ specOpTests else [])
return (map snd realtests, return (map snd realtests,
...@@ -480,15 +484,17 @@ propResultType te = case te of ...@@ -480,15 +484,17 @@ propResultType te = case te of
-- Transforms a function declaration into a post condition test if -- Transforms a function declaration into a post condition test if
-- there is a post condition for this function (i.e., a relation named -- there is a post condition for this function (i.e., a relation named
-- f'post). The post condition test is of the form -- f'post) and there is no proof file for this post condition.
-- The generated post condition test is of the form
-- fSatisfiesPostCondition x1...xn y = always (f'post x1...xn (f x1...xn)) -- fSatisfiesPostCondition x1...xn y = always (f'post x1...xn (f x1...xn))
genPostCondTest :: [QName] -> [QName] -> CFuncDecl -> [CFuncDecl] genPostCondTest :: [QName] -> [QName] -> [String] -> CFuncDecl -> [CFuncDecl]
genPostCondTest prefuns postops (CmtFunc _ qf ar vis texp rules) = genPostCondTest prefuns postops prooffnames (CmtFunc _ qf ar vis texp rules) =
genPostCondTest prefuns postops (CFunc qf ar vis texp rules) genPostCondTest prefuns postops prooffnames (CFunc qf ar vis texp rules)
genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) = genPostCondTest prefuns postops prooffnames (CFunc qf@(mn,fn) _ _ texp _) =
if qf `notElem` postops then [] else if qf `notElem` postops || existsProofFor (orgQName postname) prooffnames
[CFunc (mn, fn ++ postCondSuffix) ar Public then []
(propResultType texp) else
[CFunc postname ar Public (propResultType texp)
[simpleRule (map CPVar cvars) $ [simpleRule (map CPVar cvars) $
if qf `elem` prefuns if qf `elem` prefuns
then applyF (easyCheckModule,"==>") then applyF (easyCheckModule,"==>")
...@@ -496,6 +502,7 @@ genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) = ...@@ -496,6 +502,7 @@ genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) =
else postprop else postprop
]] ]]
where where
postname = (mn, fn ++ postCondSuffix) -- name of generated post cond. test
ar = arityOfType texp ar = arityOfType texp
cvars = map (\i -> (i,"x"++show i)) [1 .. ar] cvars = map (\i -> (i,"x"++show i)) [1 .. ar]
rcall = applyF qf (map CVar cvars) rcall = applyF qf (map CVar cvars)
...@@ -505,21 +512,24 @@ genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) = ...@@ -505,21 +512,24 @@ genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) =
-- Transforms a function declaration into a specification test if -- Transforms a function declaration into a specification test if
-- there is a specification for this function (i.e., an operation named -- there is a specification for this function (i.e., an operation named
-- f'spec). The specification test is of the form -- f'spec) and there is no proof file for the satisfaction of the specification.
-- The generated specification test is of the form
-- fSatisfiesSpecification x1...xn = -- fSatisfiesSpecification x1...xn =
-- f'pre x1...xn ==> (f x1...xn <~> f'spec x1...xn) -- f'pre x1...xn ==> (f x1...xn <~> f'spec x1...xn)
genSpecTest :: [QName] -> [QName] -> CFuncDecl -> [CFuncDecl] genSpecTest :: [QName] -> [QName] -> [String] -> CFuncDecl -> [CFuncDecl]
genSpecTest prefuns specops (CmtFunc _ qf ar vis texp rules) = genSpecTest prefuns specops prooffnames (CmtFunc _ qf ar vis texp rules) =
genSpecTest prefuns specops (CFunc qf ar vis texp rules) genSpecTest prefuns specops prooffnames (CFunc qf ar vis texp rules)
genSpecTest prefuns specops (CFunc qf@(mn,fn) _ _ texp _) = genSpecTest prefuns specops prooffnames (CFunc qf@(mn,fn) _ _ texp _) =
if qf `notElem` specops then [] else if qf `notElem` specops || existsProofFor (orgQName sptname) prooffnames
[CFunc (mn, fn ++ satSpecSuffix) ar Public then []
(propResultType texp) else
[CFunc sptname ar Public (propResultType texp)
[simpleRule (map CPVar cvars) $ [simpleRule (map CPVar cvars) $
addPreCond (applyF (easyCheckModule,"<~>") addPreCond (applyF (easyCheckModule,"<~>")
[applyF qf (map CVar cvars), [applyF qf (map CVar cvars),
applyF (mn,toSpecName fn) (map CVar cvars)])]] applyF (mn,toSpecName fn) (map CVar cvars)])]]
where where
sptname = (mn, fn ++ satSpecSuffix) -- name of generated specification test
cvars = map (\i -> (i,"x"++show i)) [1 .. ar] cvars = map (\i -> (i,"x"++show i)) [1 .. ar]
ar = arityOfType texp ar = arityOfType texp
...@@ -612,6 +622,20 @@ orgTestName (mn,tname) ...@@ -612,6 +622,20 @@ orgTestName (mn,tname)
= orgTestName (mn, stripSuffix tname satSpecSuffix) = orgTestName (mn, stripSuffix tname satSpecSuffix)
| otherwise = (mn,tname) | otherwise = (mn,tname)
-- Transforms a possibly changed qualified name, e.g., `("Mod_PUBLIC","f")`
-- or `("Mod_PUBLICDET","f")`, back to its original name by removing the
-- module suffix.
orgQName :: QName -> QName
orgQName (mn,fn)
| publicSuffix `isSuffixOf` mn
= (stripSuffix mn publicSuffix, fn)
| publicdetSuffix `isSuffixOf` mn
= (stripSuffix mn publicdetSuffix, fn)
| otherwise = (mn,fn)
where
publicSuffix = "_PUBLIC"
publicdetSuffix = "_PUBLICDET"
-- This function implements the first phase of CurryCheck: it analyses -- This function implements the first phase of CurryCheck: it analyses
-- a module to be checked, i.e., it finds the tests, creates new tests -- a module to be checked, i.e., it finds the tests, creates new tests
-- (e.g., for polymorphic properties, deterministic functions, post -- (e.g., for polymorphic properties, deterministic functions, post
...@@ -680,7 +704,7 @@ analyseCurryProg opts modname orgprog = do ...@@ -680,7 +704,7 @@ analyseCurryProg opts modname orgprog = do
| otherwise = mn | otherwise = mn
theopubfuncs = map (updQNamesInCFuncDecl rnm2pub) theofuncs theopubfuncs = map (updQNamesInCFuncDecl rnm2pub) theofuncs
(rawTests,ignoredTests,pubmod) <- (rawTests,ignoredTests,pubmod) <-
transformTests opts srcdir theopubfuncs transformTests opts prooffiles theopubfuncs
. renameCurryModule pubmodname . makeAllPublic $ prog . renameCurryModule pubmodname . makeAllPublic $ prog
let (rawDetTests,ignoredDetTests,pubdetmod) = let (rawDetTests,ignoredDetTests,pubdetmod) =
transformDetTests opts prooffiles transformDetTests opts prooffiles
......
...@@ -49,13 +49,6 @@ determinismTheoremFor funcname = funcname ++ "isdeterministic" ...@@ -49,13 +49,6 @@ determinismTheoremFor funcname = funcname ++ "isdeterministic"
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Operations for proof files: -- Operations for proof files:
--- Get the names of all files in the directory (first argument) containing
--- proofs of theorems.
getProofFiles :: String -> IO [String]
getProofFiles dir = do
files <- getDirectoryContents dir
return (filter isProofFileName files)
--- Get the names of all files in the directory (first argument) containing --- Get the names of all files in the directory (first argument) containing
--- proofs of theorems of the module (second argument). --- proofs of theorems of the module (second argument).
getModuleProofFiles :: String -> String -> IO [String] getModuleProofFiles :: String -> String -> IO [String]
...@@ -69,10 +62,6 @@ existsProofFor :: QName -> [String] -> Bool ...@@ -69,10 +62,6 @@ existsProofFor :: QName -> [String] -> Bool
existsProofFor qpropname filenames = existsProofFor qpropname filenames =
any (isProofFileNameFor qpropname) filenames any (isProofFileNameFor qpropname) filenames
--- Is this a file name with a proof, i.e., start it with `proof`?
isProofFileName :: String -> Bool
isProofFileName fn = "proof" `isPrefixOf` (map toLower fn)
--- Is the second argument a file name with a proof of some theorem of a module --- Is the second argument a file name with a proof of some theorem of a module
--- (first argument), i.e., start it with `proof` and the module name? --- (first argument), i.e., start it with `proof` and the module name?
isModuleProofFileName :: String -> String -> Bool isModuleProofFileName :: String -> String -> Bool
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment