Commit 43ade459 authored by Michael Hanus 's avatar Michael Hanus
Browse files

Changes according to version3

parent 05f1f130
-- In order to write a test, we have to import the module Test.Prop:
import Test.Prop
-- We import the System module for performing some I/O tests on operations
-- We import thist module to perform some I/O tests on operations
-- in this module:
import System
import System.Environment ( getEnv, setEnv, unsetEnv )
--------------------------------------------------------------------------
-- Deterministic tests:
......@@ -73,7 +73,7 @@ coin_plus_coin_multi = coin+coin <~~> (0?1?1?2)
-- `last` defined with a functional pattern always yields a single result.
-- This can be done by checking whether each call of `last` with
-- a non-empty list yields a single result:
last :: [a] -> a
last :: Data a => [a] -> a
last (_ ++ [x]) = x
last_has_single_results xs = not (null xs) ==> last xs # 1
......@@ -90,10 +90,10 @@ last_has_single_results xs = not (null xs) ==> last xs # 1
evar = "abc123"
-- First, we check whether setting this variable works:
set_environ = (setEnviron evar "SET" >> getEnviron evar) `returns` "SET"
set_environ = (setEnv evar "SET" >> getEnv evar) `returns` "SET"
-- Now we check whether unsetting works:
unset_environ = (unsetEnviron evar >> getEnviron evar) `returns` ""
unset_environ = (unsetEnv evar >> getEnv evar) `returns` ""
-- We can also compare the results of two actions with `sameReturns`:
sameIO = return (6*7) `sameReturns` return 42
......
......@@ -8,9 +8,9 @@
--- needed for checking each property is shown.
runPropertyTests :: Bool -> Bool -> [IO (Maybe String)] -> IO Int
runPropertyTests withcolor withtime props = do
failedmsgs <- sequenceIO (if withtime then map showRunTimeFor props
else props)
>>= return . Maybe.catMaybes
failedmsgs <- sequence (if withtime then map showRunTimeFor props
else props)
>>= return . Data.Maybe.catMaybes
if null failedmsgs
then return 0
else do
......@@ -43,8 +43,9 @@ instance (Show a, Show b) => Show (Func a b) where
show (Func abs)
| null abs = "{ _ -> failed }"
| otherwise
= "{" ++ List.intercalate ", " (map showMap (tail abs) ++
["_ -> " ++ show (snd (head abs))]) ++ "}"
= "{" ++ Data.List.intercalate ", "
(map showMap (tail abs) ++
["_ -> " ++ show (snd (head abs))]) ++ "}"
where
showMap (x,y) = show x ++ " -> " ++ show y
......@@ -101,8 +102,8 @@ constrValue :: [String] -> String
constrValue xs = case xs of
[] -> ""
[c] -> c
[c,x,y] -> if Char.isAlpha (head c) then bracket $ unwords xs
else bracket $ unwords [x,c,y]
[c,x,y] -> if Data.Char.isAlpha (head c) then bracket $ unwords xs
else bracket $ unwords [x,c,y]
_ -> bracket $ unwords xs
where
bracket s = '(' : s ++ ")"
......
{
"name": "currycheck",
"version": "2.0.0",
"version": "3.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "A tool to support automatic testing of Curry programs",
"category": [ "Testing" ],
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0",
"abstract-curry": ">= 2.0.0",
"ansi-terminal" : ">= 0.0.1",
"cass-analysis" : ">= 2.0.0",
"cass" : ">= 2.0.0",
"contracts" : ">= 0.0.1",
"csv" : ">= 1.0.0",
"currypath" : ">= 0.0.1",
"easycheck" : ">= 0.0.1",
"flatcurry" : ">= 2.0.0",
"frontend-exec" : ">= 0.0.1",
"profiling" : ">= 1.0.0",
"rewriting" : ">= 2.0.0",
"setfunctions" : ">= 0.0.1",
"wl-pprint" : ">= 0.0.1"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0, < 3.0.0",
"kics2": ">= 2.0.0, < 3.0.0"
"base" : ">= 3.0.0, < 4.0.0",
"abstract-curry": ">= 3.0.0, < 4.0.0",
"ansi-terminal" : ">= 3.0.0, < 4.0.0",
"cass-analysis" : ">= 3.0.0, < 4.0.0",
"cass" : ">= 3.0.0, < 4.0.0",
"contracts" : ">= 3.0.0, < 4.0.0",
"csv" : ">= 3.0.0, < 4.0.0",
"currypath" : ">= 3.0.0, < 4.0.0",
"distribution" : ">= 3.0.0, < 4.0.0",
"easycheck" : ">= 3.0.0, < 4.0.0",
"flatcurry" : ">= 3.0.0, < 4.0.0",
"frontend-exec" : ">= 3.0.0, < 4.0.0",
"profiling" : ">= 3.0.0, < 4.0.0",
"rewriting" : ">= 3.0.0, < 4.0.0",
"setfunctions" : ">= 3.0.0, < 4.0.0",
"wl-pprint" : ">= 3.0.0, < 4.0.0"
},
"configModule": "CC.Config",
"executable": {
......
......@@ -7,7 +7,8 @@ module CC.AnalysisHelpers
, dropPublicSuffix )
where
import List ( intercalate, isSuffixOf )
import System.Console.ANSI.Codes ( blue )
import Data.List ( intercalate, isSuffixOf )
import AbstractCurry.Types ( QName )
import Analysis.Types ( Analysis )
......@@ -17,7 +18,6 @@ import Analysis.Termination ( Productivity(..), productivityAnalysis
, terminationAnalysis )
import Analysis.UnsafeModule ( unsafeModuleAnalysis )
import CASS.Server ( analyzeGeneric )
import System.Console.ANSI.Codes ( blue )
import CC.Options
......@@ -64,18 +64,19 @@ dropPublicQName (m,f) = (dropPublicSuffix m, f)
-- Analyze a list of modules with some static program analysis.
-- Returns the combined analysis information.
-- Raises an error if something goes wrong.
analyzeModules :: Options -> String -> Analysis a -> [String] -> IO (ProgInfo a)
analyzeModules :: (Read a, Show a) => Options -> String -> Analysis a
-> [String] -> IO (ProgInfo a)
analyzeModules opts ananame analysis mods = do
putStrIfNormal opts $ withColor opts blue $
"\nRunning " ++ ananame ++ " analysis on modules: " ++
intercalate ", " mods ++ "..."
anainfos <- mapIO (analyzeModule analysis) mods
anainfos <- mapM (analyzeModule analysis) mods
putStrIfNormal opts $ withColor opts blue $ "done...\n"
return $ foldr combineProgInfo emptyProgInfo anainfos
-- Analyze a module with some static program analysis.
-- Raises an error if something goes wrong.
analyzeModule :: Analysis a -> String -> IO (ProgInfo a)
analyzeModule :: (Read a, Show a) => Analysis a -> String -> IO (ProgInfo a)
analyzeModule analysis mod = do
aresult <- analyzeGeneric analysis mod
either return
......
......@@ -5,9 +5,9 @@
module CC.Helpers ( ccLoadPath )
where
import FilePath ( splitSearchPath )
import List ( intercalate, isInfixOf )
import System ( getEnviron )
import System.FilePath ( splitSearchPath )
import Data.List ( intercalate, isInfixOf )
import System.Environment ( getEnv )
import CC.Config ( packageLoadPath )
......@@ -17,7 +17,7 @@ import CC.Config ( packageLoadPath )
--- and the additional load path for packages required by CurryCheck.
ccLoadPath :: IO String
ccLoadPath = do
ecurrypath <- getEnviron "CURRYPATH"
ecurrypath <- getEnv "CURRYPATH"
let ecurrypath' = case ecurrypath of ':':_ -> '.':ecurrypath
_ -> ecurrypath
return $ intercalate ":"
......@@ -32,5 +32,6 @@ ccExecLoadPath =
where
isRequiredPackage dir =
any (`isInfixOf` dir)
[ "ansi-terminal", "easycheck", "profiling", "random"
, "searchtree", "setfunctions" ]
[ "ansi-terminal", "directory", "distribution", "easycheck"
, "filepath", "process", "profiling", "random"
, "searchtree", "setfunctions", "time" ]
......@@ -4,11 +4,12 @@
module CC.Options where
import Char ( toUpper )
import GetOpt
import IO
import List ( isPrefixOf )
import ReadNumeric ( readNat )
import Control.Monad ( unless, when )
import Data.Char ( toUpper )
import Data.List ( isPrefixOf )
import Numeric ( readNat )
import System.Console.GetOpt
import System.IO
------------------------------------------------------------------------------
-- Representation of command line options.
......@@ -89,7 +90,7 @@ options =
"do not perform source code checks"
, Option "" ["noiotest"]
(NoArg (\opts -> opts { optIOTest = False }))
"do not test I/O properties"
"do not test I/O properties or unsafe modules"
, Option "" ["noprop"]
(NoArg (\opts -> opts { optProp = False }))
"do not perform property tests"
......@@ -113,11 +114,9 @@ options =
"write test statistics in CSV format into <file>"
]
where
safeReadNat opttrans s opts =
let numError = error "Illegal number argument (try `-h' for help)" in
maybe numError
(\ (n,rs) -> if null rs then opttrans n opts else numError)
(readNat s)
safeReadNat opttrans s opts = case readNat s of
[(n,"")] -> opttrans n opts
_ -> error "Illegal number argument (try `-h' for help)"
checkVerb n opts = if n>=0 && n<5
then opts { optVerb = n }
......
......@@ -14,17 +14,19 @@
--- (together with possible preconditions).
---
--- @author Michael Hanus, Jan-Patrick Baye
--- @version August 2020
--- @version November 2020
-------------------------------------------------------------------------
import Char ( toUpper )
import Directory ( createDirectoryIfMissing )
import Distribution ( curryCompiler, installDir )
import FilePath ( (</>), pathSeparator, takeDirectory )
import GetOpt
import List
import Maybe ( fromJust, isJust )
import System ( system, exitWith, getArgs, getPID, setEnviron )
import Control.Monad ( unless, when )
import Data.Char ( toUpper )
import Data.List
import Data.Maybe ( fromJust, isJust )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( (</>), pathSeparator, takeDirectory )
import System.Console.GetOpt
import System.Environment ( getArgs, setEnv )
import System.Process ( system, exitWith, getPID )
import System.Console.ANSI.Codes
import AbstractCurry.Types
import AbstractCurry.Files ( readCurryWithParseOptions, readUntypedCurry )
......@@ -38,7 +40,7 @@ import Contract.Names
import qualified FlatCurry.Types as FC
import FlatCurry.Files
import qualified FlatCurry.Goodies as FCG
import System.Console.ANSI.Codes
import Language.Curry.Distribution ( curryCompiler, installDir )
import System.CurryPath ( modNameToPath, lookupModuleSourceInLoadPath
, stripCurrySuffix )
import System.FrontendExec ( defaultParams, setQuiet )
......@@ -64,7 +66,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 28/08/2020)"
packageVersion ++ " of 16/11/2020)"
bannerLine = take (length bannerText) (repeat '-')
-- Help text
......@@ -203,7 +205,7 @@ equivPropTypes testmod = concatMap equivTypesOf (propTests testmod)
genTestFuncs :: Options -> (QName -> Bool) -> (QName -> Productivity) -> String
-> TestModule -> IO [CFuncDecl]
genTestFuncs opts terminating productivity mainmod tm =
liftM (filter (not . null . funcRules))
fmap (filter (not . null . funcRules))
(mapM genTestFunc (propTests tm))
where
genTestFunc test = case test of
......@@ -256,8 +258,8 @@ genTestFuncs opts terminating productivity mainmod tm =
-- Operation equivalence test for terminating operations:
equivBodyTerm f1 f2 texp test =
let xvars = map (\i -> (i,"x"++show i)) [1 .. arityOfType texp]
pxvars = map (\i -> (i,"px"++show i)) [1 .. arityOfType texp]
let xvars = map (\i -> (i,"x" ++ show i)) [1 .. arityOfType texp]
pxvars = map (\i -> (i,"px" ++ show i)) [1 .. arityOfType texp]
pvalOfFunc = ctype2typeop mainmod "pvalOf_" (resultType texp)
in propOrEquivBody
(map (\t -> ctype2BotType mainmod False t) (argTypes texp))
......@@ -275,8 +277,8 @@ genTestFuncs opts terminating productivity mainmod tm =
-- Operation equivalence test for arbitrary operations:
equivBodyAny f1 f2 texp test =
let xvars = map (\i -> (i,"x"++show i)) [1 .. arityOfType texp]
pxvars = map (\i -> (i,"px"++show i)) [1 .. arityOfType texp]
let xvars = map (\i -> (i,"x" ++ show i)) [1 .. arityOfType texp]
pxvars = map (\i -> (i,"px" ++ show i)) [1 .. arityOfType texp]
pvar = (2,"p")
pvalOfFunc = ctype2typeop mainmod "peval_" (resultType texp)
in propOrEquivBody
......@@ -419,7 +421,7 @@ transFuncArgsInProp mainmod argtypes propexp
in letExpr (concat locals) (applyE propexp (map CVar nvars)))
| otherwise = propexp
where
vars = map (\i -> (i,"x"++show i)) [1 .. length argtypes]
vars = map (\i -> (i,"x" ++ show i)) [1 .. length argtypes]
ftype2let (texp,v@(j,xj)) =
if isFunctionalType texp
......@@ -550,7 +552,7 @@ transformTests opts prfnames theofuncs
(\ _ -> case classifyTest opts prog fdecl of
EquivTest _ f1 f2 texp _ ->
let ar = arityOfType texp
cvars = map (\i -> (i,"x"++show i)) [1 .. ar]
cvars = map (\i -> (i,"x" ++ show i)) [1 .. ar]
in stFunc (funcName fdecl) ar Public (propResultType texp)
[simpleRule (map CPVar cvars)
(applyF (easyCheckModule,"<~>")
......@@ -633,7 +635,7 @@ genPostCondTest prefuns postops prooffnames
where
postname = (mn, fn ++ postCondSuffix) -- name of generated post cond. test
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)
postprop = applyF (easyCheckModule,"always")
[applyF (mn,toPostCondName fn)
......@@ -677,7 +679,7 @@ genSpecGroundEquivTest prefuns qf@(mn,fn) clscon texp =
applyF (mn,toSpecName fn) (map CVar cvars)])]
where
ar = arityOfType texp
cvars = map (\i -> (i,"x"++show i)) [1 .. ar]
cvars = map (\i -> (i,"x" ++ show i)) [1 .. ar]
qfspec = (mn, toSpecName fn)
-- Adds the preconditions of operations (second argument), if they are
......@@ -734,7 +736,7 @@ genDetProp prefuns (CFunc (mn,fn) ar _ (CQualType clscon texp) _) =
where
rtypevars = tvarsOfType (resultType texp)
forg = take (length fn - 9) fn
cvars = map (\i -> (i,"x"++show i)) [1 .. ar]
cvars = map (\i -> (i,"x" ++ show i)) [1 .. ar]
forgcall = applyF (mn,forg) (map CVar cvars)
rnumcall = applyF (easyCheckModule,"#<") [forgcall, cInt 2]
......@@ -867,10 +869,12 @@ analyseModule :: Options -> String -> IO [TestModule]
analyseModule opts modname = do
putStrIfNormal opts $ withColor opts blue $
"Analyzing module '" ++ modname ++ "'...\n"
catch (readCurryWithParseOptions modname (setQuiet True defaultParams) >>=
catch (readCurryWithParseOptions modname defaultParams >>= --(setQuiet True defaultParams) >>=
analyseCurryProg opts modname)
(\_ -> return [staticErrorTestMod modname
["Module '"++modname++"': incorrect source program"]])
(\err -> return
[staticErrorTestMod modname
["Module '" ++ modname ++ "': incorrect source program:\n" ++
"ERROR: " ++ show err]])
-- Analyse a Curry module for static errors:
staticProgAnalysis :: Options -> String -> String -> CurryProg
......@@ -904,7 +908,8 @@ analyseCurryProg opts modname orgprog = do
let prog = renameProp2EasyCheck orgprog
(topdir,srcfilename) <- lookupModuleSourceInLoadPath modname >>=
return .
maybe (error $ "Source file of module '"++modname++"' not found!") id
maybe (error $ "Source file of module '" ++ modname ++ "' not found!")
id
let srcdir = takeDirectory srcfilename
putStrLnIfDebug opts $ "Source file: " ++ srcfilename
prooffiles <- if optProof opts
......@@ -929,16 +934,16 @@ analyseCurryProg opts modname orgprog = do
. renameCurryModule pubmodname . makeAllPublic $ prog
let (rawDetTests,ignoredDetTests,pubdetmod) =
transformDetTests opts prooffiles
. renameCurryModule (modname++"_PUBLICDET")
. renameCurryModule (modname ++ "_PUBLICDET")
. makeAllPublic $ prog
unless (not (null staticerrs) || null rawTests && null rawDetTests) $
putStrIfNormal opts $
"Properties to be tested:\n" ++
unwords (map (snd . funcName) (rawTests++rawDetTests)) ++ "\n"
unwords (map (snd . funcName) (rawTests ++ rawDetTests)) ++ "\n"
unless (not (null staticerrs) || null ignoredTests && null ignoredDetTests) $
putStrIfNormal opts $
"Properties ignored for testing:\n" ++
unwords (map (snd . funcName) (ignoredTests++ignoredDetTests)) ++ "\n"
unwords (map (snd . funcName) (ignoredTests ++ ignoredDetTests)) ++ "\n"
let tm = TestModule modname
(progName pubmod)
staticerrs
......@@ -995,7 +1000,7 @@ genBottomType :: String -> FC.TypeDecl -> CTypeDecl
genBottomType _ (FC.TypeSyn _ _ _ _) =
error "genBottomType: cannot translate type synonyms"
genBottomType mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
CType (mainmod,t2bt tc) Public (map transTVar tvars)
CType (mainmod,t2bt tc) Public (map (transTVar . fst) tvars)
(simpleCCons (mainmod,"Bot_"++transQN tc) Public [] :
if isPrimExtType qtc
then [simpleCCons (mainmod,"Value_"++tc) Public [baseType qtc]]
......@@ -1080,15 +1085,15 @@ genPeval mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
then [valueRule]
else map genConsRule consdecls)
where
botSym = (mainmod,"Bot_"++transQN tc) -- bottom constructor
botSym = (mainmod, "Bot_" ++ transQN tc) -- bottom constructor
-- variables for polymorphic type arguments:
polyavars = [ (i,"a"++show i) | i <- tvars]
polyrvars = [ (i,"b"++show i) | i <- tvars]
polyavars = [ (i,"a" ++ show i) | i <- map fst tvars]
polyrvars = [ (i,"b" ++ show i) | i <- map fst tvars]
genConsRule (FC.Cons qc@(_,cons) _ _ argtypes) =
let args = [(i,"x"++show i) | i <- [0 .. length argtypes - 1]]
pargs = [(i,"y"++show i) | i <- [0 .. length argtypes - 1]]
let args = [(i,"x" ++ show i) | i <- [0 .. length argtypes - 1]]
pargs = [(i,"y" ++ show i) | i <- [0 .. length argtypes - 1]]
pcons = (mainmod,t2bt cons)
in simpleRule (map CPVar polyavars ++
[CPComb qc (map CPVar args), CPComb pcons (map CPVar pargs)])
......@@ -1140,11 +1145,11 @@ genPValOf mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
else map genConsRule consdecls)
where
-- variables for polymorphic type arguments:
polyavars = [ (i,"a"++show i) | i <- tvars]
polyrvars = [ (i,"b"++show i) | i <- tvars]
polyavars = [ (i,"a" ++ show i) | i <- map fst tvars]
polyrvars = [ (i,"b" ++ show i) | i <- map fst tvars]
genConsRule (FC.Cons qc@(_,cons) _ _ argtypes) =
let args = [(i,"x"++show i) | i <- [0 .. length argtypes - 1]]
let args = [(i,"x" ++ show i) | i <- [0 .. length argtypes - 1]]
in simpleRule (map CPVar polyavars ++ [CPComb qc (map CPVar args)])
(applyF (mainmod,t2bt cons)
(map (\ (e,te) ->
......@@ -1218,10 +1223,10 @@ genShowP mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
else map genConsRule consdecls)]
where
-- variables for polymorphic type arguments:
polyavars = [ (i,"a"++show i) | i <- tvars]
polyavars = [ (i,"a" ++ show i) | i <- map fst tvars]
genConsRule (FC.Cons (_,cons) _ _ argtypes) =
let args = [(i,"x"++show i) | i <- [0 .. length argtypes - 1]]
let args = [(i,"x" ++ show i) | i <- [0 .. length argtypes - 1]]
showargs = map (\v -> applyF (pre "show") [CVar v]) args
in simpleRule [CPComb (mainmod,t2bt cons) (map CPVar args)]
(if null showargs
......@@ -1267,11 +1272,11 @@ genFromP mainmod (FC.Type qtc@(_,tc) _ tvars consdecls) =
else map genConsRule consdecls)
where
-- variables for polymorphic type arguments:
polyavars = [ (i,"a"++show i) | i <- tvars]
polyrvars = [ (i,"b"++show i) | i <- tvars]
polyavars = [ (i,"a" ++ show i) | i <- map fst tvars]
polyrvars = [ (i,"b" ++ show i) | i <- map fst tvars]
genConsRule (FC.Cons qc@(_,cons) _ _ argtypes) =
let args = [(i,"x"++show i) | i <- [0 .. length argtypes - 1]]
let args = [(i,"x" ++ show i) | i <- [0 .. length argtypes - 1]]
in simpleRule (map CPVar polyavars ++
[CPComb (mainmod,t2bt cons) (map CPVar args)])
(applyF qc
......@@ -1306,11 +1311,12 @@ ctypedecl2ftypedecl (CTypeSyn _ _ _ _) =
ctypedecl2ftypedecl (CNewType _ _ _ _ _) =
error "ctypedecl2ftypedecl: cannot translate newtype"
ctypedecl2ftypedecl (CType qtc _ tvars consdecls _) =
FC.Type qtc FC.Public (map fst tvars) (map transConsDecl consdecls)
FC.Type qtc FC.Public (map (\ (v,_) -> (v,FC.KStar)) tvars)
(map transConsDecl consdecls)
where
transConsDecl (CCons _ _ qc _ argtypes) =
transConsDecl (CCons qc _ argtypes) =
FC.Cons qc (length argtypes) FC.Public (map transTypeExpr argtypes)
transConsDecl (CRecord _ _ _ _ _) =
transConsDecl (CRecord _ _ _) =
error "ctypedecl2ftypedecl: cannot translate records"
transTypeExpr (CTVar (i,_)) = FC.TVar i
......@@ -1366,12 +1372,14 @@ genMainTestModule opts mainmod orgtestmods = do
map (genPartialPrimDataGenerator mainmod)
(map FCG.typeName
(filter (isPrimExtType . FCG.typeName) equvrtypes))
testfuncs <- liftM concat
testfuncs <- fmap concat
(mapM (genTestFuncs opts terminfos prodinfos mainmod) testmods)
let mainFunction = genMainFunction opts mainmod testfuncs
imports = nub $ [ easyCheckModule, easyCheckExecModule
, searchTreeModule, generatorModule
, "List", "Char", "Maybe", "System", "Debug.Profile"
, "Control.Monad"
, "Data.List", "Data.Char", "Data.Maybe"
, "System.Process", "Debug.Profile"
, "System.Console.ANSI.Codes" ] ++
map (fst . fst) testtypes ++
map testModuleName testmods
......@@ -1407,9 +1415,9 @@ genMainFunction opts testModule testfuncs =
[constF (pre (if optColor opts then "True" else "False")),
constF (pre (if optTime opts then "True" else "False")),
list2ac $ map (constF . funcName) testfuncs]
, CSExpr $ applyF (pre "when")
, CSExpr $ applyF ("Control.Monad", "when")
[applyF (pre "/=") [cvar "x1", cInt 0],
applyF ("System", "exitWith") [cvar "x1"]]
applyF ("System.Process", "exitWith") [cvar "x1"]]
]
-- Remove all tests that should not be executed.
......@@ -1519,7 +1527,7 @@ genTestDataGenerator mainmod tdecl = type2genData tdecl
= applyF (generatorModule, "genCons" ++ show ar)
([CSymbol qn] ++ map type2gen ctypes)
type2gen (FC.TVar i) = CVar (i,"a"++show i)
type2gen (FC.TVar i) = CVar (i,"a" ++ show i)
type2gen (FC.FuncType _ _) =
error $ "Type '" ++ qtString ++
"': cannot create value generators for functions!"
......@@ -1529,8 +1537,8 @@ genTestDataGenerator mainmod tdecl = type2genData tdecl
error $ "Type '" ++ qtString ++
"': cannot create value generators for forall types!"
ctvars = map (\i -> CTVar (i,"a"++show i)) tvars
cvars = map (\i -> (i,"a"++show i)) tvars
ctvars = map (\(i,_) -> CTVar (i,"a" ++ show i)) tvars
cvars = map (\(i,_) -> (i,"a" ++ show i)) tvars
-- Generates a test data generator for a partial primitive type
-- where some constant is used as a value (instead of generating all values).
......@@ -1561,15 +1569,15 @@ cleanup :: Options -> String -> [TestModule] -> IO ()
cleanup opts mainmod modules =
unless (optKeep opts) $ do
removeCurryModule mainmod
mapIO_ removeCurryModule (map testModuleName modules)
mapM_ removeCurryModule (map testModuleName modules)
where
removeCurryModule modname =
lookupModuleSourceInLoadPath modname >>=
maybe done
maybe (return ())
(\ (_,srcfilename) -> do
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ "rm -f " ++ srcfilename
done )
return () )
-- Print or store some statistics about number of tests.
printTestStatistics :: Options -> [String] -> String -> Int -> [Test] -> IO ()
......@@ -1607,11 +1615,11 @@ main = do
putStrIfNormal opts ccBanner
when (null args || optHelp opts) (putStrLn usageText >> exitWith 1)
let mods = map stripCurrySuffix args
mapIO_ checkModuleName mods
mapM_ checkModuleName mods
currypath <- ccLoadPath
--putStrLn $ "export CURRYPATH=" ++ currypath
setEnviron "CURRYPATH" currypath
testModules <- mapIO (analyseModule opts) mods
putStrLnIfDebug opts $ "SET CURRYPATH=" ++ currypath
setEnv "CURRYPATH" currypath
testModules <- mapM (analyseModule opts) mods
let staticerrs = concatMap staticErrors (concat testModules)
finaltestmodules = filter testThisModule (concat testModules)
testmodname = if null (optMainProg opts)
......@@ -1719,8 +1727,7 @@ writeCurryProgram :: Options -> String -> CurryProg -> String -> IO ()
writeCurryProgram opts srcdir p appendix = do
let progfile = srcdir </> modNameToPath (progName p) ++ ".curry"
putStrLnIfDebug opts $ "Writing program: " ++ progfile
writeFile progfile
(ACPretty.showCProg p ++ "\n" ++ appendix ++ "\n")
writeFile progfile (ACPretty.showCProg p ++ "\n" ++ appendix ++ "\n")
isPAKCS :: Bool
isPAKCS = curryCompiler == "pakcs"
......
......@@ -13,7 +13,7 @@ module DefaultRuleUsage
import AbstractCurry.Types
import AbstractCurry.Select
import List
import Data.List
--- Does a program contains default rules?
containsDefaultRules :: CurryProg -> Bool
......
......@@ -53,7 +53,7 @@ inExp (Typed se te) x e = Typed (inExp se x e) te
--- Note that this construction is necessary to achieve a finite search
--- space when matching against a finite expression with the operation
--- `inExp`.
withElem :: a -> a -> [a] -> [a]
withElem :: Data a => a -> a -> [a] -> [a]
withElem e x zs = prefix ++ e : (zs=:=prefix++(x:suffix) &> suffix)
where prefix,suffix free
......
......@@ -18,13 +18,15 @@ module SimplifyPostConds
( simplifyPostConditionsWithTheorems)
where
import Control.Monad ( unless, when )
import Data.List ( last, maximum )
import Data.Maybe ( maybeToList )
import ReadShowTerm ( readQTerm )
import AbstractCurry.Types
import AbstractCurry.Select
import AbstractCurry.Build
import Contract.Names
import List (last, maximum)
import Maybe (maybeToList)
import ReadShowTerm (readQTerm)
import Rewriting.Files
import Rewriting.Term
import Rewriting.Position
......@@ -39,7 +41,7 @@ import Rewriting.Rules
simplifyPostConditionsWithTheorems :: Int -> [CFuncDecl] -> [CFuncDecl]
-> IO [CFuncDecl]
simplifyPostConditionsWithTheorems verb theofuncs postconds = do
theoTRS <- mapIO safeFromFuncDecl theofuncs >>= return . concat
theoTRS <- mapM safeFromFuncDecl theofuncs >>= return . concat
if null theoTRS
then return postconds
else do
......@@ -48,13 +50,13 @@ simplifyPostConditionsWithTheorems verb theofuncs postconds = do
[ "THEOREMS (with existing proof files):", showTRS snd theoTRS,
"SIMPLIFICATION RULES (for postcondition reduction):"
, showTRS snd simprules]
simppostconds <- mapIO (safeSimplifyPostCondition verb simprules) postconds
simppostconds <- mapM (safeSimplifyPostCondition verb simprules) postconds
return (concat simppostconds)
where
safeFromFuncDecl fd =
catch (return $!! (snd (fromFuncDecl fd)))
(\e -> do
putStrLn $ showError e ++ "\nTheorem \"" ++
putStrLn $ show e ++ "\nTheorem \"" ++
snd (funcName fd) ++
"\" not used for simplification (too complex)."
return [])
......@@ -64,7 +66,7 @@ simplifyPostConditionsWithTheorems verb theofuncs postconds = do
safeSimplifyPostCondition :: Int -> TRS QName -> CFuncDecl -> IO [CFuncDecl]
safeSimplifyPostCondition verb simprules fundecl =
catch (simplifyPostCondition verb simprules fundecl)
(\e -> do putStrLn $ showError e ++ "\nPostcondition \"" ++
(\e -> do putStrLn $ show e ++ "\nPostcondition \"" ++
snd (funcName fundecl) ++
"\" not simplified (too complex)."
return [fundecl])
......@@ -74,7 +76,7 @@ simplifyPostCondition verb simprules (CFunc qn ar vis texp rs) =
simplifyPostCondition verb simprules (CmtFunc "" qn ar vis texp rs)
simplifyPostCondition verb simprules fdecl@(CmtFunc cmt qn ar vis texp rules) =
if isPostCondName (snd qn)
then do redrules <- mapIO (simplifyRule verb simprules qn) rules
then do redrules <- mapM (simplifyRule verb simprules qn) rules
return $ if all isTrivial redrules
then []
else [CmtFunc cmt qn ar vis texp redrules]
......@@ -106,14 +108,14 @@ maxSimpSteps = 100
-- Simplify a rule of a postcondition.
simplifyRule :: Int -> TRS QName -> QName -> CRule -> IO CRule
simplifyRule verb simprules qn crule@(CRule rpats _) = do
(id $!! (lhs,rhs)) `seq` done -- in order to raise a fromRule error here!
(id $!! (lhs,rhs)) `seq` return () -- in order to raise a fromRule error here!
unless (null trs) $
error $ "simplifyRule: cannot handle local TRS:\n" ++ showTRS snd trs
when (verb > 1 ) $ putStrLn $ unlines
["POSTCONDITION: " ++ showRule snd (lhs,rhs),