Commit 27466f60 authored by Michael Hanus 's avatar Michael Hanus

Adds option --noiotest

parent acb87025
...@@ -20,6 +20,7 @@ data Options = Options ...@@ -20,6 +20,7 @@ data Options = Options
, optMaxFail :: Int , optMaxFail :: Int
, optDefType :: String , optDefType :: String
, optSource :: Bool , optSource :: Bool
, optIOTest :: Bool
, optProp :: Bool , optProp :: Bool
, optSpec :: Bool , optSpec :: Bool
, optDet :: Bool , optDet :: Bool
...@@ -40,6 +41,7 @@ defaultOptions = Options ...@@ -40,6 +41,7 @@ defaultOptions = Options
, optMaxFail = 0 , optMaxFail = 0
, optDefType = "Ordering" , optDefType = "Ordering"
, optSource = True , optSource = True
, optIOTest = True
, optProp = True , optProp = True
, optSpec = True , optSpec = True
, optDet = True , optDet = True
...@@ -83,6 +85,9 @@ options = ...@@ -83,6 +85,9 @@ options =
, Option "" ["nosource"] , Option "" ["nosource"]
(NoArg (\opts -> opts { optSource = False })) (NoArg (\opts -> opts { optSource = False }))
"do not perform source code checks" "do not perform source code checks"
, Option "" ["noiotest"]
(NoArg (\opts -> opts { optIOTest = False }))
"do not test I/O properties"
, Option "" ["noprop"] , Option "" ["noprop"]
(NoArg (\opts -> opts { optProp = False })) (NoArg (\opts -> opts { optProp = False }))
"do not perform property tests" "do not perform property tests"
......
...@@ -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 February 2018 --- @version June 2018
------------------------------------------------------------------------- -------------------------------------------------------------------------
import AnsiCodes import AnsiCodes
...@@ -55,7 +55,7 @@ ccBanner :: String ...@@ -55,7 +55,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 12/02/2018)" packageVersion ++ " of 01/06/2018)"
bannerLine = take (length bannerText) (repeat '-') bannerLine = take (length bannerText) (repeat '-')
-- Help text -- Help text
...@@ -432,8 +432,7 @@ classifyTests opts prog = map makeProperty ...@@ -432,8 +432,7 @@ classifyTests opts prog = map makeProperty
(e1,e2) -> error $ "Illegal equivalence property:\n" ++ (e1,e2) -> error $ "Illegal equivalence property:\n" ++
showCExpr e1 ++ " <=> " ++ showCExpr e2 showCExpr e1 ++ " <=> " ++ showCExpr e2
defaultingType = poly2defaultType (optDefType opts) . typeOfQualType defaultingType = poly2defaultType opts . typeOfQualType . defaultQualType
. defaultQualType
funcTypeOf f = maybe (error $ "Cannot find type of " ++ show f ++ "!") funcTypeOf f = maybe (error $ "Cannot find type of " ++ show f ++ "!")
funcType funcType
...@@ -464,7 +463,7 @@ transformTests opts srcdir ...@@ -464,7 +463,7 @@ transformTests opts srcdir
(realtests,ignoredtests) = partition fst $ (realtests,ignoredtests) = partition fst $
if not (optProp opts) if not (optProp opts)
then [] then []
else concatMap (poly2default (optDefType opts)) $ else concatMap (poly2default opts) $
-- ignore already proved properties: -- ignore already proved properties:
filter (\fd -> funcName fd `notElem` map funcName theofuncs) filter (\fd -> funcName fd `notElem` map funcName theofuncs)
usertests ++ usertests ++
...@@ -514,7 +513,7 @@ transformDetTests opts prooffiles ...@@ -514,7 +513,7 @@ transformDetTests opts prooffiles
(realtests,ignoredtests) = partition fst $ (realtests,ignoredtests) = partition fst $
if not (optProp opts) if not (optProp opts)
then [] then []
else concatMap (poly2default (optDefType opts)) else concatMap (poly2default opts)
(if optDet opts then detOpTests else []) (if optDet opts then detOpTests else [])
-- Get all operations with a defined precondition from a list of functions. -- Get all operations with a defined precondition from a list of functions.
...@@ -631,27 +630,30 @@ genDetProp prefuns (CFunc (mn,fn) ar _ (CQualType clscon texp) _) = ...@@ -631,27 +630,30 @@ genDetProp prefuns (CFunc (mn,fn) ar _ (CQualType clscon texp) _) =
-- Generates auxiliary (base-type instantiated) test functions for -- Generates auxiliary (base-type instantiated) test functions for
-- polymorphically typed test function. -- polymorphically typed test function.
-- The flag indicates whether the test function should be actually passed -- The returned flag indicates whether the test function should actually
-- to the test tool. -- be passed to the test tool.
poly2default :: String -> CFuncDecl -> [(Bool,CFuncDecl)] -- Thus, IO tests are flagged by `False` if the corresponding option is set.
poly2default dt (CmtFunc _ name arity vis ftype rules) = poly2default :: Options -> CFuncDecl -> [(Bool,CFuncDecl)]
poly2default dt (CFunc name arity vis ftype rules) poly2default opts (CmtFunc _ name arity vis ftype rules) =
poly2default dt fdecl@(CFunc (mn,fname) arity vis qftype rs) poly2default opts (CFunc name arity vis ftype rules)
poly2default opts fdecl@(CFunc (mn,fname) arity vis qftype rs)
| isPolyType ftype | isPolyType ftype
= [(False,fdecl) = [(False,fdecl)
,(True, CFunc (mn,fname++defTypeSuffix) arity vis ,(True, CFunc (mn,fname++defTypeSuffix) arity vis
(emptyClassType (poly2defaultType dt ftype)) (emptyClassType (poly2defaultType opts ftype))
[simpleRule [] (applyF (mn,fname) [])]) [simpleRule [] (applyF (mn,fname) [])])
] ]
| not (optIOTest opts) && isPropIOType ftype
= [(False,fdecl)]
| otherwise | otherwise
= [(True, CFunc (mn,fname) arity vis (CQualType clscon ftype) rs)] = [(True, CFunc (mn,fname) arity vis (CQualType clscon ftype) rs)]
where where
CQualType clscon ftype = defaultQualType qftype CQualType clscon ftype = defaultQualType qftype
poly2defaultType :: String -> CTypeExpr -> CTypeExpr poly2defaultType :: Options -> CTypeExpr -> CTypeExpr
poly2defaultType dt texp = p2dt texp poly2defaultType opts texp = p2dt texp
where where
p2dt (CTVar _) = baseType (pre dt) p2dt (CTVar _) = baseType (pre (optDefType opts))
p2dt (CFuncType t1 t2) = CFuncType (p2dt t1) (p2dt t2) p2dt (CFuncType t1 t2) = CFuncType (p2dt t1) (p2dt t2)
p2dt (CTApply t1 t2) = CTApply (p2dt t1) (p2dt t2) p2dt (CTApply t1 t2) = CTApply (p2dt t1) (p2dt t2)
p2dt (CTCons ct) = CTCons ct p2dt (CTCons ct) = CTCons ct
...@@ -1263,8 +1265,8 @@ cleanup opts mainmod modules = ...@@ -1263,8 +1265,8 @@ cleanup opts mainmod modules =
system $ "rm -f " ++ srcfilename system $ "rm -f " ++ srcfilename
-- Show some statistics about number of tests: -- Show some statistics about number of tests:
showTestStatistics :: [Test] -> String showTestStatistics :: Options -> [Test] -> String
showTestStatistics tests = showTestStatistics opts tests =
let numtests = sumOf (const True) let numtests = sumOf (const True)
unittests = sumOf isUnitTest unittests = sumOf isUnitTest
proptests = sumOf isPropTest proptests = sumOf isPropTest
...@@ -1273,7 +1275,7 @@ showTestStatistics tests = ...@@ -1273,7 +1275,7 @@ showTestStatistics tests =
in "TOTAL NUMBER OF TESTS: " ++ show numtests ++ in "TOTAL NUMBER OF TESTS: " ++ show numtests ++
" (UNIT: " ++ show unittests ++ ", PROPERTIES: " ++ " (UNIT: " ++ show unittests ++ ", PROPERTIES: " ++
show proptests ++ ", EQUIVALENCE: " ++ show equvtests ++ show proptests ++ ", EQUIVALENCE: " ++ show equvtests ++
", IO: " ++ show iotests ++ ")" (if optIOTest opts then ", IO: " ++ show iotests else "") ++ ")"
where where
sumOf p = length . filter p $ tests sumOf p = length . filter p $ tests
...@@ -1323,7 +1325,7 @@ main = do ...@@ -1323,7 +1325,7 @@ main = do
ret <- system runcmd ret <- system runcmd
cleanup opts testmodname finaltestmodules cleanup opts testmodname finaltestmodules
unless (isQuiet opts || ret /= 0) $ unless (isQuiet opts || ret /= 0) $
putStrLn $ withColor opts green $ showTestStatistics finaltests putStrLn $ withColor opts green $ showTestStatistics opts finaltests
exitWith ret exitWith ret
where where
showStaticErrors opts errs = putStrLn $ withColor opts red $ showStaticErrors opts errs = putStrLn $ withColor opts red $
......
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