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

Typeclass version packaged

parent 57be800b
......@@ -27,7 +27,7 @@ plusComm :: Int -> Int -> Prop
plusComm x y = x + y -=- y + x
-- We can even write a polymorphic test:
rev_rev_is_id :: [a] -> Prop
rev_rev_is_id :: (Eq a, Show a) => [a] -> Prop
rev_rev_is_id xs = reverse (reverse xs) -=- xs
-- A polymorphic test will be automatically transformed into the same
-- test specialized to values of type Ordering.
......
......@@ -6,7 +6,7 @@ rev [] = []
rev (x:xs) = rev xs ++ [x]
-- Unit tests:
revNull = rev [] -=- []
revNull = rev [] -=- ([] :: [Int])
rev123 = rev [1,2,3] -=- [3,2,1]
-- Property: reversing two times is the identity:
......@@ -69,6 +69,7 @@ neg_or b1 b2 = not (b1 || b2) -=- not b1 && not b2
-- Natural numbers defined by s-terms (Z=zero, S=successor):
data Nat = Z | S Nat
deriving (Eq,Show)
-- addition on natural numbers:
add :: Nat -> Nat -> Nat
......@@ -84,6 +85,7 @@ addIsAssociative x y z = add (add x y) z -=- add x (add y z)
-- A general tree type:
data Tree a = Leaf a | Node [Tree a]
deriving (Eq,Show)
-- The leaves of a tree:
leaves (Leaf x) = [x]
......@@ -107,6 +109,7 @@ sumUpIsCorrect n = n>=0 ==> sumUp n -=- n * (n+1) `div` 2
-- To test sumUpIsCorrect explicitly on non-ngeative integers,
-- we define a new data type to wrap integers:
data NonNeg = NonNeg { nonNeg :: Int }
deriving (Eq,Show)
-- We define our own generator for producing only non-negative integers:
genNonNeg = genCons1 NonNeg genNN
......
......@@ -8,33 +8,33 @@
import qualified List
import Test.Prop
nub :: [a] -> [a]
nub :: Eq a => [a] -> [a]
nub = List.nub
nub'spec :: [a] ->DET [a]
nub'spec :: Eq a => [a] ->DET [a]
nub'spec (xs++[e]++ys++[e]++zs) = nub'spec (xs++[e]++ys++zs)
nub'spec'default xs = xs
isPrefixOf :: [a] -> [a] -> Bool
isPrefixOf :: Eq a => [a] -> [a] -> Bool
isPrefixOf = List.isPrefixOf
isPrefixOf'spec :: [a] -> [a] ->DET Bool
isPrefixOf'spec :: Eq a => [a] -> [a] ->DET Bool
isPrefixOf'spec xs (xs ++ _) = True
isPrefixOf'spec'default _ _ = False
isSuffixOf :: [a] -> [a] -> Bool
isSuffixOf :: Eq a => [a] -> [a] -> Bool
isSuffixOf = List.isSuffixOf
isSuffixOf'spec :: [a] -> [a] ->DET Bool
isSuffixOf'spec :: Eq a => [a] -> [a] ->DET Bool
isSuffixOf'spec xs (_ ++ xs) = True
isSuffixOf'spec'default _ _ = False
isInfixOf :: [a] -> [a] -> Bool
isInfixOf :: Eq a => [a] -> [a] -> Bool
isInfixOf = List.isInfixOf
isInfixOf'spec :: [a] -> [a] ->DET Bool
isInfixOf'spec :: Eq a => [a] -> [a] ->DET Bool
isInfixOf'spec xs (_ ++ xs ++ _) = True
isInfixOf'spec'default _ _ = False
......@@ -4,6 +4,7 @@ import Test.Prop
-- Natural numbers defined by s-terms (Z=zero, S=successor):
data Nat = Z | S Nat
deriving (Eq,Show)
-- addition on natural numbers:
add :: Nat -> Nat -> Nat
......
......@@ -4,6 +4,7 @@ import Test.Prop
-- A general tree type:
data Tree a = Leaf a | Node [Tree a]
deriving (Eq,Show)
leaves (Leaf x) = [x]
leaves (Node ts) = concatMap leaves ts
......
{
"name": "currycheck",
"version": "1.0.1",
"version": "2.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "A tool to support automatic testing of Curry programs",
"category": [ "Testing" ],
"dependencies": {
"rewriting" : ">= 0.0.1"
"rewriting" : ">= 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 1.14.0, < 2.0.0",
"kics2": ">= 0.5.0, < 2.0.0"
"pakcs": ">= 2.0.0",
"kics2": ">= 2.0.0"
},
"configModule": "CurryCheckConfig",
"executable": {
......@@ -18,6 +18,7 @@
},
"testsuite": [
{ "src-dir": "examples",
"options": "-m70",
"modules": [ "DefaultRulesTest", "DetOperations", "ExampleTests",
"ExamplesFromManual", "FloatTest", "ListSpecifications",
"Nats", "SEBF", "Sum", "SortSpec", "Tree" ]
......
......@@ -7,7 +7,7 @@
--- See example program `Examples/UsageErrors.curry` for some examples.
---
--- @author Michael Hanus
--- @version May 2016
--- @version October 2016
---------------------------------------------------------------------------
module CheckDetUsage(containsDetOperations, checkDetUse) where
......@@ -18,25 +18,26 @@ import AbstractCurry.Select
---------------------------------------------------------------------
--- Does a Curr program contains operations with DET annotations?
containsDetOperations :: CurryProg -> Bool
containsDetOperations (CurryProg _ _ _ fdecls _) =
any (detInTopLevelType . funcType) fdecls
containsDetOperations (CurryProg _ _ _ _ _ _ fdecls _) =
any (detInTopLevelType . typeOfQualType . funcType) fdecls
where
detInTopLevelType (CTVar _) = False
detInTopLevelType (CTCons tc _) = tc == pre "DET"
detInTopLevelType (CTVar _) = False
detInTopLevelType (CTCons _) = False
detInTopLevelType (CFuncType _ rt) = detInTopLevelType rt
detInTopLevelType (CTApply tc _) = tc == CTCons (pre "DET")
---------------------------------------------------------------------
--- Returns messages about unintended uses of type synonym `DET`
--- in a Curry program.
checkDetUse :: CurryProg -> [(QName,String)]
checkDetUse (CurryProg _ _ _ fdecls _) =
checkDetUse (CurryProg _ _ _ _ _ _ fdecls _) =
concatMap (map showDetError . checkDetUseInFDecl) fdecls
where
showDetError qf = (qf, "wrong use of DET type synonym!")
checkDetUseInFDecl :: CFuncDecl -> [QName]
checkDetUseInFDecl (CFunc qn _ _ t rs) =
if checkDetInTopLevelType t || any detInRule rs
if checkDetInTopLevelType (typeOfQualType t) || any detInRule rs
then [qn]
else []
checkDetUseInFDecl (CmtFunc _ qn ar vis t rs) =
......@@ -44,15 +45,16 @@ checkDetUseInFDecl (CmtFunc _ qn ar vis t rs) =
checkDetInTopLevelType :: CTypeExpr -> Bool
checkDetInTopLevelType (CTVar _) = False
checkDetInTopLevelType (CTCons _ ts) = any detInTypeExpr ts
checkDetInTopLevelType (CTCons _) = False
checkDetInTopLevelType (CFuncType at rt) =
detInTypeExpr at || checkDetInTopLevelType rt
checkDetInTopLevelType (CTApply _ ta) = detInTypeExpr ta
detInTypeExpr :: CTypeExpr -> Bool
detInTypeExpr (CTVar _) = False
detInTypeExpr (CTCons tc ts) =
tc == pre "DET" || any detInTypeExpr ts
detInTypeExpr (CTCons tc) = tc == pre "DET"
detInTypeExpr (CFuncType at rt) = detInTypeExpr at || detInTypeExpr rt
detInTypeExpr (CTApply tc ta) = detInTypeExpr tc || detInTypeExpr ta
detInRule :: CRule -> Bool
detInRule (CRule _ rhs) = detInRhs rhs
......@@ -64,9 +66,9 @@ detInRhs (CGuardedRhs gs ldcls) = any detInGuard gs || any detInLocalDecl ldcls
detInLocalDecl :: CLocalDecl -> Bool
detInLocalDecl (CLocalFunc (CFunc _ _ _ t rs)) =
detInTypeExpr t || any detInRule rs
detInTypeExpr (typeOfQualType t) || any detInRule rs
detInLocalDecl (CLocalFunc (CmtFunc _ _ _ _ t rs)) =
detInTypeExpr t || any detInRule rs
detInTypeExpr (typeOfQualType t) || any detInRule rs
detInLocalDecl (CLocalPat _ rhs) = detInRhs rhs
detInLocalDecl (CLocalVars _) = False
......@@ -80,7 +82,7 @@ detInExp (CLetDecl ldecls e) = any detInLocalDecl ldecls || detInExp e
detInExp (CDoExpr stmts) = any detInStatement stmts
detInExp (CListComp e stmts) = detInExp e || any detInStatement stmts
detInExp (CCase _ e branches) = detInExp e || any (detInRhs . snd) branches
detInExp (CTyped e t) = detInExp e || detInTypeExpr t
detInExp (CTyped e t) = detInExp e || detInTypeExpr (typeOfQualType t)
detInExp (CRecConstr _ fields) = any (detInExp . snd) fields
detInExp (CRecUpdate e fields) = detInExp e || any (detInExp . snd) fields
......
......@@ -5,7 +5,7 @@
--- and pre/postconditions.
---
--- @author Michael Hanus
--- @version May 2016
--- @version October 2016
------------------------------------------------------------------------
module ContractUsage
......@@ -56,7 +56,7 @@ checkPrePostResultTypes prog =
in preerrs ++ posterrs
hasBoolResultType :: CFuncDecl -> Bool
hasBoolResultType fd = resultType (funcType fd) == boolType
hasBoolResultType fd = resultType (typeOfQualType (funcType fd)) == boolType
-- Get function names from a Curry module with a name satisfying the predicate:
funDeclsWithNameArity :: (String -> Bool) -> CurryProg -> [(String,Int)]
......@@ -66,7 +66,8 @@ funDeclsWithNameArity pred prog =
-- Computes the unqualified name and the arity from the type of the function.
nameArityOfFunDecl :: CFuncDecl -> (String,Int)
nameArityOfFunDecl fd = (snd (funcName fd), length (argTypes (funcType fd)))
nameArityOfFunDecl fd =
(snd (funcName fd), length (argTypes (typeOfQualType (funcType fd))))
-- Is this the name of a specification?
......
......@@ -22,7 +22,8 @@ import AbstractCurry.Files
import AbstractCurry.Select
import AbstractCurry.Build
import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Transform (renameCurryModule,updCProg,updQNamesInCProg)
import AbstractCurry.Transform (renameCurryModule, trCTypeExpr
,updCProg, updQNamesInCProg)
import AnsiCodes
import Distribution
import FilePath ((</>), takeDirectory)
......@@ -54,7 +55,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 06/02/2017)"
packageVersion ++ " of 08/05/2017)"
bannerLine = take (length bannerText) (repeat '-')
-- Help text
......@@ -261,9 +262,8 @@ userTestDataOfModule testmod = concatMap testDataOf (propTests testmod)
userTypesOf (CTVar _) = []
userTypesOf (CFuncType from to) = union (userTypesOf from) (userTypesOf to)
userTypesOf (CTCons (mn,tc) argtypes) =
union (if mn == preludeName then [] else [(mn,tc)])
(unionOn userTypesOf argtypes)
userTypesOf (CTCons (mn,tc)) = if mn == preludeName then [] else [(mn,tc)]
userTypesOf (CTApply tc ta) = union (userTypesOf tc) (userTypesOf ta)
unionOn f = foldr union [] . map f
......@@ -274,7 +274,7 @@ createTests opts mainmodname tm = map createTest (propTests tm)
where
createTest test =
cfunc (mainmodname, (genTestName $ getTestName test)) 0 Public
(ioType (maybeType stringType))
(emptyClassType (ioType (maybeType stringType)))
(case test of PropTest name t _ -> propBody name (argTypes t) test
IOTest name _ -> ioTestBody name test)
......@@ -308,10 +308,15 @@ createTests opts mainmodname tm = map createTest (propTests tm)
])]
where
useUserDefinedGen texp = case texp of
CTVar _ -> error "No polymorphic generator!"
CFuncType _ _ -> error "No generator for functional types!"
CTCons (_,tc) _ -> isJust
(find (\qn -> "gen"++tc == snd qn) (generators tm))
CTVar _ -> error "No polymorphic generator!"
CFuncType _ _ -> error "No generator for functional types!"
CTApply _ _ ->
maybe (error "No generator for type applications!")
(\ ((_,tc),_) -> isJust
(find (\qn -> "gen"++tc == snd qn) (generators tm)))
(tconsArgsOfType texp)
CTCons (_,tc) -> isJust
(find (\qn -> "gen"++tc == snd qn) (generators tm))
configOpWithMaxTest =
let n = optMaxTest opts
......@@ -345,13 +350,17 @@ easyCheckConfig opts =
type2genop :: String -> TestModule -> CTypeExpr -> CExpr
type2genop _ _ (CTVar _) = error "No polymorphic generator!"
type2genop _ _ (CFuncType _ _) = error "No generator for functional types!"
type2genop mainmod tm (CTCons qt targs) =
applyF (typename2genopname mainmod (generators tm) qt)
(map (type2genop mainmod tm) targs)
type2genop mainmod tm (CTCons qt) =
constF (typename2genopname mainmod (generators tm) qt)
type2genop mainmod tm te@(CTApply _ _) =
maybe (error "No generator for type applications!")
(\ (qt,targs) -> applyF (typename2genopname mainmod (generators tm) qt)
(map (type2genop mainmod tm) targs))
(tconsArgsOfType te)
isFloatType :: CTypeExpr -> Bool
isFloatType texp = case texp of CTCons tc [] -> tc == (preludeName,"Float")
_ -> False
isFloatType texp = case texp of CTCons tc -> tc == (preludeName,"Float")
_ -> False
typename2genopname :: String -> [QName] -> QName -> QName
typename2genopname mainmod definedgenops (mn,tc)
......@@ -378,8 +387,10 @@ typename2genopname mainmod definedgenops (mn,tc)
-- Turn all functions into public ones.
-- This ensures that all tests can be executed.
makeAllPublic :: CurryProg -> CurryProg
makeAllPublic (CurryProg modname imports typedecls functions opdecls) =
CurryProg modname stimports typedecls publicFunctions opdecls
makeAllPublic (CurryProg modname imports dfltdecl clsdecls instdecls
typedecls functions opdecls) =
CurryProg modname stimports dfltdecl clsdecls instdecls
typedecls publicFunctions opdecls
where
stimports = if generatorModule `elem` imports &&
searchTreeModule `notElem` imports
......@@ -405,9 +416,10 @@ makeAllPublic (CurryProg modname imports typedecls functions opdecls) =
classifyTests :: [CFuncDecl] -> [Test]
classifyTests = map makeProperty
where
makeProperty test = if isPropIOType (funcType test)
makeProperty test = if isPropIOType ftype
then IOTest (funcName test) 0
else PropTest (funcName test) (funcType test) 0
else PropTest (funcName test) ftype 0
where ftype = typeOfQualType (funcType test)
-- Extracts all tests from a given Curry module and transforms
-- all polymorphic tests into tests on a base type.
......@@ -416,7 +428,8 @@ classifyTests = map makeProperty
transformTests :: Options -> String -> CurryProg
-> IO ([CFuncDecl],[CFuncDecl],CurryProg)
transformTests opts srcdir
prog@(CurryProg mname imps typeDecls functions opDecls) = do
prog@(CurryProg mname imps dfltdecl clsdecls instdecls
typeDecls functions opDecls) = do
theofuncs <- if optProof opts then getTheoremFunctions srcdir prog
else return []
simpfuncs <- simplifyPostConditionsWithTheorems (optVerb opts) theofuncs funcs
......@@ -442,6 +455,7 @@ transformTests opts srcdir
map snd ignoredtests,
CurryProg mname
(nub (easyCheckModule:imps))
dfltdecl clsdecls instdecls
typeDecls
(simpfuncs ++ map snd (realtests ++ ignoredtests))
opDecls)
......@@ -458,10 +472,12 @@ transformTests opts srcdir
transformDetTests :: Options -> [String] -> CurryProg
-> ([CFuncDecl],[CFuncDecl],CurryProg)
transformDetTests opts prooffiles
(CurryProg mname imports typeDecls functions opDecls) =
(CurryProg mname imports dfltdecl clsdecls instdecls
typeDecls functions opDecls) =
(map snd realtests, map snd ignoredtests,
CurryProg mname
(nub (easyCheckModule:imports))
dfltdecl clsdecls instdecls
typeDecls
(map (revertDetOpTrans detOpNames) functions ++
map snd (realtests ++ ignoredtests))
......@@ -507,10 +523,11 @@ propResultType te = case te of
genPostCondTest :: [QName] -> [QName] -> CFuncDecl -> [CFuncDecl]
genPostCondTest prefuns postops (CmtFunc _ qf ar vis texp rules) =
genSpecTest prefuns postops (CFunc qf ar vis texp rules)
genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) =
genPostCondTest prefuns postops
(CFunc qf@(mn,fn) _ _ (CQualType clscon texp) _) =
if qf `notElem` postops then [] else
[CFunc (mn, fn ++ postCondSuffix) ar Public
(propResultType texp)
(CQualType clscon (propResultType texp))
[simpleRule (map CPVar cvars) $
if qf `elem` prefuns
then applyF (easyCheckModule,"==>")
......@@ -533,10 +550,11 @@ genPostCondTest prefuns postops (CFunc qf@(mn,fn) _ _ texp _) =
genSpecTest :: [QName] -> [QName] -> CFuncDecl -> [CFuncDecl]
genSpecTest prefuns specops (CmtFunc _ qf ar vis texp rules) =
genSpecTest prefuns specops (CFunc qf ar vis texp rules)
genSpecTest prefuns specops (CFunc qf@(mn,fn) _ _ texp _) =
genSpecTest prefuns specops
(CFunc qf@(mn,fn) _ _ (CQualType clscon texp) _) =
if qf `notElem` specops then [] else
[CFunc (mn, fn ++ satSpecSuffix) ar Public
(propResultType texp)
(CQualType (addShowContext clscon) (propResultType texp))
[simpleRule (map CPVar cvars) $
addPreCond (applyF (easyCheckModule,"<~>")
[applyF qf (map CVar cvars),
......@@ -579,9 +597,9 @@ genDetOpTests prooffiles prefuns fdecls =
genDetProp :: [QName] -> CFuncDecl -> CFuncDecl
genDetProp prefuns (CmtFunc _ qf ar vis texp rules) =
genDetProp prefuns (CFunc qf ar vis texp rules)
genDetProp prefuns (CFunc (mn,fn) ar _ texp _) =
genDetProp prefuns (CFunc (mn,fn) ar _ (CQualType clscon texp) _) =
CFunc (mn, forg ++ isDetSuffix) ar Public
(propResultType texp)
(CQualType (addShowContext clscon) (propResultType texp))
[simpleRule (map CPVar cvars) $
if (mn,forg) `elem` prefuns
then applyF (easyCheckModule,"==>")
......@@ -600,18 +618,76 @@ genDetProp prefuns (CFunc (mn,fn) ar _ texp _) =
poly2default :: String -> CFuncDecl -> [(Bool,CFuncDecl)]
poly2default dt (CmtFunc _ name arity vis ftype rules) =
poly2default dt (CFunc name arity vis ftype rules)
poly2default dt fdecl@(CFunc (mn,fname) arity vis ftype _)
poly2default dt fdecl@(CFunc (mn,fname) arity vis qftype rs)
| isPolyType ftype
= [(False,fdecl)
,(True, CFunc (mn,fname++defTypeSuffix) arity vis (p2dt ftype)
[simpleRule [] (applyF (mn,fname) [])])
,(True, CFunc (mn,fname++defTypeSuffix) arity vis
(emptyClassType (p2dt ftype))
[simpleRule [] (applyF (mn,fname) [])])
]
| otherwise
= [(True,fdecl)]
= [(True, CFunc (mn,fname) arity vis (CQualType clscon ftype) rs)]
where
p2dt (CTVar _) = baseType (pre dt)
CQualType clscon ftype = defaultQualType qftype
p2dt (CTVar _) = baseType (pre dt)
p2dt (CFuncType t1 t2) = CFuncType (p2dt t1) (p2dt t2)
p2dt (CTCons ct ts) = CTCons ct (map p2dt ts)
p2dt (CTApply t1 t2) = CTApply (p2dt t1) (p2dt t2)
p2dt (CTCons ct) = CTCons ct
-------------------------------------------------------------------------
-- Try to default a qualified type by replacing Num/Integral-constrained
-- types by Int and Fractional-constrained types by Float.
defaultQualType :: CQualTypeExpr -> CQualTypeExpr
defaultQualType (CQualType (CContext allclscon) ftype) =
CQualType (CContext deffractxt) deffratype
where
(numcons,nonnumcons) =
partition (\ (cls,te) -> (cls == pre "Num" || cls == pre "Integral")
&& isTVar te)
allclscon
defnumtype = def2TConsInType numcons (pre "Int") ftype
defnumctxt = removeNonTVarClassContexts
(map (\ (cls,con) ->
(cls, def2TConsInType numcons (pre "Int") con))
nonnumcons)
(fracons,nonfracons) =
partition (\ (cls,te) -> cls == pre "Fractional" && isTVar te) defnumctxt
deffratype = def2TConsInType fracons (pre "Float") defnumtype
deffractxt = removeNonTVarClassContexts
(map (\ (cls,con) ->
(cls, def2TConsInType fracons (pre "Float") con))
nonfracons)
-- remove constant type class contexts
removeNonTVarClassContexts = filter (\ (_,te) -> isTVar te)
-- replace all type variables (occurring in the first list of class
-- constraints) by the type constructor (second argument) in a given
-- type expression (third argument)
def2TConsInType clscons tcons texp =
foldr (tvar2TCons tcons) texp (map snd clscons)
-- substitute a type variable by type Int in a type
tvar2TCons tcons texp = case texp of
CTVar tv -> substTVar tv (CTCons tcons)
_ -> id
-- substitute a type variable by a type expression in a type expression:
substTVar tvariname texp =
trCTypeExpr (\tv -> if tv==tvariname then texp else CTVar tv)
CTCons CFuncType CTApply
isTVar te = case te of CTVar _ -> True
_ -> False
-- Add a "Show" class context to all types occurring in the context.
addShowContext :: CContext -> CContext
addShowContext (CContext clscons) =
CContext (nub (clscons ++ (map (\t -> (pre "Show",t)) (map snd clscons))))
-------------------------------------------------------------------------
-- Transforms a possibly changed test name (like "test_ON_BASETYPE")
-- back to its original name.
......@@ -734,11 +810,12 @@ generatorsOfProg :: CurryProg -> [QName]
generatorsOfProg = map funcName . filter isGen . functions
where
isGen fdecl = "gen" `isPrefixOf` snd (funcName fdecl) &&
isSearchTreeType (resultType (funcType fdecl))
isSearchTreeType (resultType (typeOfQualType (funcType fdecl)))
isSearchTreeType (CTVar _) = False
isSearchTreeType (CFuncType _ _) = False
isSearchTreeType (CTCons tc _) = tc == searchTreeTC
isSearchTreeType (CTApply _ _) = False
isSearchTreeType (CTCons tc) = tc == searchTreeTC -- TODO!
-------------------------------------------------------------------------
-- Create the main test module containing all tests of all test modules as
......@@ -762,14 +839,15 @@ genMainTestModule opts mainmodname modules = do
map fst testtypes ++ map testModuleName modules
appendix <- readFile (packagePath </> "src" </> "TestAppendix.curry")
writeCurryProgram opts "."
(CurryProg mainmodname imports [] (mainFunction : funcs) [])
appendix
(CurryProg mainmodname imports Nothing [] [] [] (mainFunction : funcs) [])
appendix
-- Generates the main function which executes all property tests
-- of all test modules.
genMainFunction :: Options -> String -> [Test] -> CFuncDecl
genMainFunction opts testModule tests =
CFunc (testModule, "main") 0 Public (ioType unitType) [simpleRule [] body]
CFunc (testModule, "main") 0 Public (emptyClassType (ioType unitType))
[simpleRule [] body]
where
body = CDoExpr $
(if isQuiet opts
......@@ -843,8 +921,10 @@ createTestDataGenerator mainmodname tdecl = type2genData tdecl
then error $ "Cannot create value generator for type '" ++ qtString ++
"' without constructors!"
else CFunc (typename2genopname mainmodname [] qt) (length tvars) Public
(foldr (~>) (CTCons searchTreeTC [CTCons qt ctvars])
(map (\v -> CTCons searchTreeTC [v]) ctvars))
(emptyClassType
(foldr (~>) (CTApply (CTCons searchTreeTC)
(applyTC qt ctvars))
(map (\v -> applyTC searchTreeTC [v]) ctvars)))
[simpleRule (map CPVar cvars)
(foldr1 (\e1 e2 -> applyF (generatorModule,"|||") [e1,e2])
(map cons2gen cdecls))]
......@@ -874,13 +954,12 @@ cleanup opts mainmodname modules =
removeCurryModule mainmodname
mapIO_ removeCurryModule (map testModuleName modules)
where
removeCurryModule modname =
lookupModuleSourceInLoadPath modname >>=
maybe done
(\ (_,srcfilename) -> do
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ "rm -f " ++ srcfilename
done )
removeCurryModule modname = do
(_,srcfilename) <- lookupModuleSourceInLoadPath modname >>=
return .
maybe (error $ "Source file of module '"++modname++"' not found!") id
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ "rm -f " ++ srcfilename
-- Show some statistics about number of tests:
showTestStatistics :: [TestModule] -> String
......@@ -921,6 +1000,7 @@ main = do
putStrIfNormal opts $ withColor opts blue $
"Generating main test module '"++testmodname++"'..."
genMainTestModule opts testmodname finaltestmodules
showGeneratedModule opts "main test" testmodname
putStrIfNormal opts $ withColor opts blue $ "and compiling it...\n"
ret <- system $ unwords $ [installDir </> "bin" </> "curry"
,"--noreadline"
......@@ -937,13 +1017,23 @@ main = do
unlines (line : "STATIC ERRORS IN PROGRAMS:" : errs) ++ line
line = take 78 (repeat '=')
showGeneratedModule :: Options -> String -> String -> IO ()
showGeneratedModule opts mkind modname = when (optVerb opts > 3) $ do
putStrLn $ '\n' : line
putStrLn $ "Generated " ++ mkind ++ " module `" ++ modname ++ ".curry':"
putStrLn line
readFile (modname ++ ".curry") >>= putStr
putStrLn line
where
line = take 78 (repeat '=')
-------------------------------------------------------------------------
-- Auxiliaries
-- Rename all module references to "Test.Prog" into "Test.EasyCheck"
renameProp2EasyCheck :: CurryProg -> CurryProg
renameProp2EasyCheck prog =
updCProg id (map rnmMod) id id id
updCProg id (map rnmMod) id id id id id id
(updQNamesInCProg (\ (mod,n) -> (rnmMod mod,n)) prog)
where
rnmMod mod | mod == propModule = easyCheckModule
......
......@@ -3,7 +3,7 @@
--- default rules in a Curry program.
---
--- @author Michael Hanus
--- @version May 2016
--- @version October 2016
------------------------------------------------------------------------
module DefaultRuleUsage
......
......@@ -3,7 +3,7 @@
--- a Curry program.
---
--- @author Michael Hanus
--- @version Augsut 2016
--- @version October 2016
------------------------------------------------------------------------
module PropertyUsage
......@@ -12,27 +12,27 @@ module PropertyUsage
) where
import AbstractCurry.Types
import AbstractCurry.Select (funcType, resultType)
import AbstractCurry.Select (funcType, resultType, typeOfQualType)
------------------------------------------------------------------------
-- Check whether a function definition is a property,
-- i.e., if the result type is `Prop` or `PropIO`.
isProperty :: CFuncDecl -> Bool
isProperty = isPropertyType . funcType
isProperty = isPropertyType . typeOfQualType . funcType
where
isPropertyType ct = isPropIOType ct || isPropType (resultType ct)
-- Is the type expression the type Test.EasyCheck.Prop?
isPropType :: CTypeExpr -> Bool
isPropType texp = case texp of
CTCons (mn,tc) [] -> tc == "Prop" && isCheckModule mn
_ -> False
CTCons (mn,tc) -> tc == "Prop" && isCheckModule mn
_ -> False
-- Is the type expression the type Test.EasyCheck.PropIO?
isPropIOType :: CTypeExpr -> Bool
isPropIOType texp = case texp of
CTCons (mn,tc) [] -> tc == "PropIO" && isCheckModule mn
_ -> False
CTCons (mn,tc) -> tc == "PropIO" && isCheckModule mn
_ -> False
-- Is the module name Test.Prop or Test.EasyCheck?
isCheckModule :: String -> Bool
......
......@@ -11,7 +11,7 @@
--- theorem'sorted xs = always (sorted (sort xs))
---
--- @author Michael Hanus
--- @version August 2016
--- @version October 2016
------------------------------------------------------------------------