Commit a71e6eda authored by Michael Hanus's avatar Michael Hanus
Browse files

Code refactoring

parent 4968223d
# currycheck - A Property Testing Tool for Curry
# CurryCheck - A Property Testing Tool for Curry
This package contains the tool `curry-check` that supports
the automation of testing Curry programs.
......
......@@ -42,7 +42,7 @@ import qualified FlatCurry.Types as FC
import FlatCurry.Files
import qualified FlatCurry.Goodies as FCG
import System.CurryPath ( modNameToPath, lookupModuleSourceInLoadPath
, stripCurrySuffix )
, runModuleAction, stripCurrySuffix )
import System.FrontendExec ( defaultParams, setQuiet )
import Text.CSV ( writeCSVFile )
import Text.Pretty ( pPrint )
......@@ -66,7 +66,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 16/11/2020)"
packageVersion ++ " of 27/12/2020)"
bannerLine = take (length bannerText) (repeat '-')
-- Help text
......@@ -869,7 +869,10 @@ analyseModule :: Options -> String -> IO [TestModule]
analyseModule opts modname = do
putStrIfNormal opts $ withColor opts blue $
"Analyzing module '" ++ modname ++ "'...\n"
catch (readCurryWithParseOptions modname defaultParams >>= --(setQuiet True defaultParams) >>=
let parserparams = if optVerb opts < 2
then setQuiet True defaultParams
else defaultParams
catch (readCurryWithParseOptions modname parserparams >>=
analyseCurryProg opts modname)
(\err -> return
[staticErrorTestMod modname
......@@ -999,6 +1002,8 @@ generatorsOfProg = map funcName . filter isGen . functions
genBottomType :: String -> FC.TypeDecl -> CTypeDecl
genBottomType _ (FC.TypeSyn _ _ _ _) =
error "genBottomType: cannot translate type synonyms"
genBottomType _ (FC.TypeNew _ _ _ _) =
error "genBottomType: cannot translate newtypes"
genBottomType mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
CType (mainmod,t2bt tc) Public (map (transTVar . fst) tvars)
(simpleCCons (mainmod,"Bot_"++transQN tc) Public [] :
......@@ -1070,6 +1075,8 @@ f_equiv_g x p = peval_C (f x) p <~> peval_C (g x) p
genPeval :: String -> FC.TypeDecl -> CFuncDecl
genPeval _ (FC.TypeSyn _ _ _ _) =
error "genPeval: cannot translate type synonyms"
genPeval _ (FC.TypeNew _ _ _ _) =
error "genPeval: cannot translate newtypes"
genPeval mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
cmtfunc ("Evaluate a `"++tc++"` value up to a partial approxmiation.")
(mainmod,"peval_"++transQN tc) 1 Public
......@@ -1130,6 +1137,8 @@ f_equiv_g x = pvalOf_C (f x) <~> pvalOf_C (g x)
genPValOf :: String -> FC.TypeDecl -> CFuncDecl
genPValOf _ (FC.TypeSyn _ _ _ _) =
error "genPValOf: cannot translate type synonyms"
genPValOf _ (FC.TypeNew _ _ _ _) =
error "genPValOf: cannot translate newtypes"
genPValOf mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
cmtfunc ("Map a `"++tc++"` value into all its partial approximations.")
(mainmod,"pvalOf_"++transQN tc) 1 Public
......@@ -1208,6 +1217,8 @@ instance Show P_C where
genShowP :: String -> FC.TypeDecl -> CInstanceDecl
genShowP _ (FC.TypeSyn _ _ _ _) =
error "genShowP: cannot translate type synonyms"
genShowP _ (FC.TypeNew _ _ _ _) =
error "genShowP: cannot translate newtypes"
genShowP mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
CInstance (pre "Show")
(CContext (map (\tv -> (pre "Show", CTVar tv)) polyavars))
......@@ -1256,6 +1267,8 @@ from_P_C (P_C x) = C (from_P_AB x)
genFromP :: String -> FC.TypeDecl -> CFuncDecl
genFromP _ (FC.TypeSyn _ _ _ _) =
error "genFromP: cannot translate type synonyms"
genFromP _ (FC.TypeNew _ _ _ _) =
error "genFromP: cannot translate newtypes"
genFromP mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
cmtfunc ("Map a partial `"++tc++"` value into its real value (or fail).")
(mainmod,"from_P_"++transQN tc) 1 Public
......@@ -1508,6 +1521,8 @@ genTestDataGenerator mainmod tdecl = type2genData tdecl
type2genData (FC.TypeSyn _ _ _ _) =
error $ "Cannot create generator for type synonym " ++ qtString
type2genData (FC.TypeNew _ _ _ _) =
error $ "Cannot create generator for newtype " ++ qtString
type2genData (FC.Type _ _ tvars cdecls)
| null cdecls
= error $ "Cannot create value generator for type '" ++ qtString ++
......@@ -1611,26 +1626,39 @@ printTestStatistics opts mods testmodname retcode tests = do
main :: IO ()
main = do
argv <- getArgs
pid <- getPID
let (funopts, args, opterrors) = getOpt Permute options argv
opts <- processOpts (foldl (flip id) defaultOptions funopts)
unless (null opterrors)
(putStr (unlines opterrors) >> putStrLn usageText >> exitWith 1)
putStrIfNormal opts ccBanner
when (null args || optHelp opts) (putStrLn usageText >> exitWith 1)
when (optHelp opts) (putStrLn usageText >> exitWith 0)
let mods = map stripCurrySuffix args
mapM_ checkModuleName mods
case mods of
[] -> putStrLn usageText >> exitWith 1
[m] -> runModuleAction (\mn -> checkModules opts [mn]) m
_ -> do mapM_ checkModuleName mods
checkModules opts mods
where
checkModuleName mn =
when (pathSeparator `elem` mn) $ do
putStrLn $
"More than one module name with path prefixes not allowed:\n" ++ mn
exitWith 1
checkModules :: Options -> [String] -> IO ()
checkModules opts mods = do
currypath <- ccLoadPath
putStrLnIfDebug opts $ "SET CURRYPATH=" ++ currypath
setEnv "CURRYPATH" currypath
testModules <- mapM (analyseModule opts) mods
pid <- getPID
let staticerrs = concatMap staticErrors (concat testModules)
finaltestmodules = filter testThisModule (concat testModules)
testmodname = if null (optMainProg opts)
then "TEST" ++ show pid
else optMainProg opts
if not (null staticerrs)
then do showStaticErrors opts staticerrs
then do showStaticErrors staticerrs
putStrLn $ withColor opts red "Testing aborted!"
cleanup opts testmodname finaltestmodules
printTestStatistics opts mods testmodname 1 []
......@@ -1661,14 +1689,9 @@ main = do
printTestStatistics opts mods testmodname ret finaltests
exitWith ret
where
showStaticErrors opts errs = putStrLn $ withColor opts red $
showStaticErrors errs = putStrLn $ withColor opts red $
unlines (line : "STATIC ERRORS IN PROGRAMS:" : errs) ++ line
checkModuleName mn =
when (pathSeparator `elem` mn) $ do
putStrLn $ "Module names with path prefixes not allowed: " ++ mn
exitWith 1
line = take 78 (repeat '=')
showGeneratedModule :: Options -> String -> String -> IO ()
......
Supports Markdown
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