Commit e5b3a08c authored by Michael Hanus 's avatar Michael Hanus

Initial support for checking productive operations added

parent 381b596f
......@@ -15,7 +15,8 @@ module CPM.Diff.Behavior
, findFunctionsToCompare
) where
import AbstractCurry.Build (cmtfunc, cfunc, simpleRule, applyF, pVars, applyE)
import AbstractCurry.Build ( baseType, (~>), cmtfunc, cfunc, simpleRule
, applyF, pVars, applyE)
import AbstractCurry.Pretty (defaultOptions, ppCTypeExpr, showCProg)
import AbstractCurry.Select (publicFuncNames, funcName, functions, funcArity
, funcType, argTypes, typeName, types, tconsOfType
......@@ -223,11 +224,11 @@ genCurryCheckProgram :: Config
-> ComparisonInfo
-> ACYCache
-> IO (ErrorLogger ())
genCurryCheckProgram cfg repo gc prodfuncs info acyCache = getBaseTemp |>=
genCurryCheckProgram cfg repo gc checkfuncs info acyCache = getBaseTemp |>=
\baseTmp -> foldEL translatorGenerator (acyCache, emptyTrans)
translateTypes |>=
\(_, transMap) ->
let testFunctions = map (genTestFunction info transMap) funcs
let testFunctions = map (genTestFunction info transMap) prodfuncs
transFunctions = transFuncs transMap
prog = CurryProg "Compare" imports [] (testFunctions ++ transFunctions) []
in do
......@@ -235,13 +236,13 @@ genCurryCheckProgram cfg repo gc prodfuncs info acyCache = getBaseTemp |>=
(progcmts ++ "\n" ++ showCProg prog)
let prodops = map snd (filter fst prodfuncs)
unless (null prodops) $ putStrLn $
"Productive operations (currently not checked): " ++
"Productive operations (currently not fully supported): " ++
showFuncNames prodops ++ "\n"
succeedIO ()
where
-- for the moment, we filter out the operations for which an additional
-- productivity check is required
funcs = map snd (filter (not . fst) prodfuncs)
prodfuncs = -- if we don't support productive operations:
filter (not . fst)
checkfuncs
progcmts = unlines $ map ("-- "++)
[ "This file contains properties to compare packages"
......@@ -252,21 +253,28 @@ genCurryCheckProgram cfg repo gc prodfuncs info acyCache = getBaseTemp |>=
, "export CURRYPATH=" ++ infDirA info ++ ":" ++ infDirB info
]
allReferencedTypes = nub ((concat $ map (argTypes . funcType) funcs) ++
map (resultType . funcType) funcs)
allReferencedTypes = nub ((concat $ map (argTypes . funcType . snd) prodfuncs)
++ map (resultType . funcType . snd) prodfuncs)
translateTypes = filter (needToTranslatePart info) allReferencedTypes
translatorGenerator = uncurry $ genTranslatorFunction cfg repo gc info
mods = map (fst . funcName) funcs
mods = map (fst . funcName . snd) prodfuncs
modsA = map (\mod -> (infPrefixA info) ++ "_" ++ mod) mods
modsB = map (\mod -> (infPrefixB info) ++ "_" ++ mod) mods
imports = modsA ++ modsB ++ ["Test.EasyCheck"]
--- Generates a test function to compare two versions of the given function.
genTestFunction :: ComparisonInfo -> TransMap -> CFuncDecl -> CFuncDecl
genTestFunction info tm f =
cmtfunc ("Check equivalence of operation " ++ fmod ++ "." ++ fname)
(modName, testName) (realArity f) Private newType
[simpleRule vars (applyF ("Test.EasyCheck", "<~>") [callA, callB])]
genTestFunction :: ComparisonInfo -> TransMap -> (Bool,CFuncDecl) -> CFuncDecl
genTestFunction info tm (isprod,f) =
cmtfunc ("Check equivalence of operation " ++ fmod ++ "." ++ fname ++
if isprod then " up to a depth limit" else "")
(modName, testName) (realArity f) Private newType
[if isprod
then let limitvar = (100,"limit")
in simpleRule (if isprod then CPVar limitvar : vars else vars)
(applyF ("Test.EasyCheck", "<~>")
[wrapLimitType limitvar callA (resultType (funcType f)),
wrapLimitType limitvar callB (resultType (funcType f))])
else simpleRule vars (applyF ("Test.EasyCheck", "<~>") [callA, callB])]
where
(fmod,fname) = funcName f
modName = "Compare"
......@@ -276,6 +284,11 @@ genTestFunction info tm f =
modA = (infPrefixA info) ++ "_" ++ fmod
modB = (infPrefixB info) ++ "_" ++ fmod
instantiatedFunc = instantiateBool $ funcType f
newType = let ftype = mapTypes info $ genTestFuncType f
in if isprod then baseType ("Nat","Nat") ~> ftype
else ftype
returnTransform = case findTrans tm (resultType $ instantiatedFunc) of
Nothing -> id
Just tr -> \t -> applyF (modName, tr) [t]
......@@ -313,7 +326,6 @@ genTestFunction info tm f =
transformedVar (CTCons _ _, CPFuncComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
transformedVar (CTCons _ _, CPLazy _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
transformedVar (CTCons _ _, CPRecord _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
newType = mapTypes info $ genTestFuncType f
-- encode a Curry identifier into an alphanum form:
encodeCurryId :: String -> String
......@@ -591,6 +603,18 @@ arityOfType (CFuncType _ b) = 1 + arityOfType b
arityOfType (CTVar _) = 0
arityOfType (CTCons _ _) = 0
-- Wrap an expression of a given type with a call to a corresponding
-- depth-limit function:
wrapLimitType :: CVarIName -> CExpr -> CTypeExpr -> CExpr
wrapLimitType _ _ (CTVar _) = error "wrapLimitType"
wrapLimitType _ _ (CFuncType _ _) = error "wrapLimitType"
wrapLimitType lv exp (CTCons (_,cn) _) =
applyF ("Limit","limit" ++ trans cn) [CVar lv, exp]
where
trans n | n=="[]" = "List"
| n=="()" = "Unit"
| otherwise = n
--- Generates a function type for the test function by replacing the result
--- type with `Test.EasyCheck.Prop`. Also instantiates polymorphic types to
--- 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