Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry-packages
currycheck
Commits
f527776b
Commit
f527776b
authored
May 08, 2017
by
Michael Hanus
Browse files
Typeclass version packaged
parent
57be800b
Changes
14
Hide whitespace changes
Inline
Side-by-side
examples/ExampleTests.curry
View file @
f527776b
...
...
@@ -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.
...
...
examples/ExamplesFromManual.curry
View file @
f527776b
...
...
@@ -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
...
...
examples/ListSpecifications.curry
View file @
f527776b
...
...
@@ -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
examples/Nats.curry
View file @
f527776b
...
...
@@ -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
...
...
examples/Tree.curry
View file @
f527776b
...
...
@@ -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
...
...
package.json
View file @
f527776b
{
"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"
]
...
...
src/CheckDetUsage.curry
View file @
f527776b
...
...
@@ -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
...
...
src/ContractUsage.curry
View file @
f527776b
...
...
@@ -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?
...
...
src/CurryCheck.curry
View file @
f527776b
...
...
@@ -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 0
6
/0
2
/2017)"
packageVersion ++ " of 0
8
/0
5
/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
q
ftype
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
...
...
src/DefaultRuleUsage.curry
View file @
f527776b
...
...
@@ -3,7 +3,7 @@
--- default rules in a Curry program.
---
--- @author Michael Hanus
--- @version
May
2016
--- @version
October
2016
------------------------------------------------------------------------
module DefaultRuleUsage
...
...
src/PropertyUsage.curry
View file @
f527776b
...
...
@@ -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
...
...
src/SimplifyPostConds.curry
View file @
f527776b
...
...
@@ -11,7 +11,7 @@
--- theorem'sorted xs = always (sorted (sort xs))
---
--- @author Michael Hanus
--- @version
August
2016
--- @version
October
2016
------------------------------------------------------------------------
module SimplifyPostConds
...
...
src/TheoremUsage.curry
View file @
f527776b
...
...
@@ -20,7 +20,7 @@