Commit b6b167da authored by Michael Hanus 's avatar Michael Hanus

Adds support for generating functional values

parent 9affe40c
-- Some tests on floats.
import Float
import Test.Prop
-- Property: the addition operator is commutative
addIsCommutative :: Float -> Float -> Prop
addIsCommutative x y = x +. y -=- y +. x
addIsCommutative x y = x + y -=- y + x
-- Property: the addition operator is almost associative due to rounding errors
addIsAssociative :: Float -> Float -> Float -> Prop
addIsAssociative x y z = always (almostEqual ((x +. y) +. z) (x +. (y +. z)))
addIsAssociative x y z = always (almostEqual ((x + y) + z) (x + (y + z)))
almostEqual :: Float -> Float -> Bool
almostEqual x y = absf (x -. y) < 0.00001
almostEqual x y = absf (x - y) < 0.00001
where
absf x = if x < 0 then 0.0 -. x else x
absf x = if x < 0 then 0.0 - x else x
-- Some tests involving higher-order functions so that also
-- functional values are generated.
import Test.Prop
-- Naive list reverse.
rev :: [a] -> [a]
rev [] = []
rev (x:xs) = rev xs ++ [x]
-- Map a function on all elements of a list.
map :: (a->b) -> [a] -> [b]
map _ [] = []
map f (x:xs) = f x : map f xs
revMap f xs = rev (map f xs) <~> map f (rev xs)
mapMap f g xs = map (f . g) xs <~> map f (map g xs)
......@@ -31,3 +31,61 @@ showRunTimeFor action = do
return result
-------------------------------------------------------------------------
-- Auxiliaries for function generators:
-- Data type to represent a function as a list of (argument,result) pairs.
data Func a b = Func [(a,b)]
-- This can be exploited to show a function in mathematical notation.
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))]) ++ "}"
where
showMap (x,y) = show x ++ " -> " ++ show y
--- Generates a search tree for functions represented by non-empty(!)
--- pair list values where the search trees for the arguments and results
--- are given as a parameter.
genFunc :: SearchTree.SearchTree a -> SearchTree.SearchTree b
-> SearchTree.SearchTree (Func a b)
genFunc gena genb =
SearchTreeGenerators.genCons1 Func
(genNEList (SearchTreeGenerators.genPair gena genb))
-- Generates a search tree for non-empty list values where the search tree
-- for the elements is given as a parameter.
genNEList :: SearchTree.SearchTree a -> SearchTree.SearchTree [a]
genNEList genx =
SearchTreeGenerators.genCons2 (:) genx (SearchTreeGenerators.genList genx)
--- Transforms a function in list presentation into a real function.
list2Func :: Eq a => Func a b -> (a -> b)
list2Func (Func abs) x = maybe (if null abs then failed else snd (head abs))
id
(lookup x abs)
--- Generates a search tree for functions represented by non-empty(!)
--- pair list values where the search trees for the arguments and results
--- are given as a parameter.
genFunction :: Eq a => SearchTree.SearchTree a -> SearchTree.SearchTree b
-> SearchTree.SearchTree (a -> b)
genFunction gena genb =
mapST l2f (genNEList (SearchTreeGenerators.genPair gena genb))
where
l2f abs x = maybe (if null abs then failed else snd (head abs))
id
(lookup x abs)
mapST :: (a -> b) -> SearchTree.SearchTree a -> SearchTree.SearchTree b
mapST f (SearchTree.Value a) = SearchTree.Value (f a)
mapST _ (SearchTree.Fail n) = SearchTree.Fail n
mapST f (SearchTree.Or t1 t2) = SearchTree.Or (mapST f t1) (mapST f t2)
instance (Show a, Show b) => Show (a -> b) where
show f = "<<function>>"
-------------------------------------------------------------------------
......@@ -26,7 +26,7 @@
{ "src-dir": "examples",
"options": "-m70",
"modules": [ "DefaultRulesTest", "DetOperations", "ExampleTests",
"ExamplesFromManual", "FloatTest",
"ExamplesFromManual", "FloatTest", "HigherOrder",
"Nats", "SEBF", "Sum", "SortSpec", "Tree" ]
},
{ "src-dir": "examples",
......
......@@ -56,7 +56,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 08/10/2018)"
packageVersion ++ " of 15/10/2018)"
bannerLine = take (length bannerText) (repeat '-')
-- Help text
......@@ -286,18 +286,17 @@ genTestFuncs opts terminating productivity mainmod tm =
(map (\ (t,genpart) ->
applyF (easyCheckModule,"valuesOfSearchTree")
[if isPAKCS || useUserDefinedGen t || isFloatType t
then type2genop mainmod tm genpart t
then type2genop mainmod tm genpart True t
else applyF (searchTreeModule,"someSearchTree")
[CTyped (constF (pre "unknown"))
(emptyClassType t)]])
argtypes) ++
[propexp]
[transFuncArgsInProp mainmod argtypes propexp]
])]
where
useUserDefinedGen texp = case texp of
CTVar _ -> error "No polymorphic generator!"
CFuncType _ _ -> error $ "No generator for functional types:\n" ++
showCTypeExpr texp
CFuncType _ _ -> True
CTApply _ _ ->
maybe (error "No generator for type applications!")
(\ ((_,tc),_) -> isJust
......@@ -336,17 +335,19 @@ easyCheckConfig opts =
-- Translates a type expression into calls to generator operations.
-- If the third argument is `True`, calls to partial generators are used.
type2genop :: String -> TestModule -> Bool -> CTypeExpr -> CExpr
type2genop _ _ _ (CTVar _) = error "No polymorphic generator!"
type2genop _ _ _ te@(CFuncType _ _) =
error $ "No generator for functional types:\n" ++ showCTypeExpr te
type2genop mainmod tm genpart (CTCons qt) =
-- The fourth argument is `True` when top-level types are translated.
type2genop :: String -> TestModule -> Bool -> Bool -> CTypeExpr -> CExpr
type2genop _ _ _ _ (CTVar _) = error "No polymorphic generator!"
type2genop mainmod tm genpart top (CFuncType ta tb) =
applyF (mainmod, if top then "genFunc" else "genFunction")
(map (type2genop mainmod tm genpart False) [ta,tb])
type2genop mainmod tm genpart _ (CTCons qt) =
constF (typename2genopname mainmod (generators tm) genpart qt)
type2genop mainmod tm genpart te@(CTApply _ _) =
type2genop mainmod tm genpart _ te@(CTApply _ _) =
maybe (error "No generator for type applications!")
(\ (qt,targs) ->
applyF (typename2genopname mainmod (generators tm) genpart qt)
(map (type2genop mainmod tm genpart) targs))
(map (type2genop mainmod tm genpart False) targs))
(tconsArgsOfType te)
isFloatType :: CTypeExpr -> Bool
......@@ -384,6 +385,31 @@ transQN tcons | tcons == "[]" = "List"
| tcons == "(,,,,)" = "Tuple5"
| otherwise = tcons
-------------------------------------------------------------------------
-- If some arguments of a property are functional, translate these
-- arguments (which have generated values of type `[(a,b)]`) into
-- a function by introducing let bindings and use `list2func`.
-- For instance, a property `p` with argument types `[(Int->Int), [Int]]`
-- is translated into the expression
-- \x1 x2 -> let fx1 = list2func x1 in p fx1 x2
transFuncArgsInProp :: String -> [(CTypeExpr,Bool)] -> CExpr -> CExpr
transFuncArgsInProp mainmod argtypes propexp
| any (isFunctionalType . fst) argtypes
= CLambda (map CPVar vars)
(let (nvars,locals) = unzip (map ftype2let (zip argtypes vars))
in letExpr (concat locals) (applyE propexp (map CVar nvars)))
| otherwise = propexp
where
vars = map (\i -> (i,"x"++show i)) [1 .. length argtypes]
ftype2let ((texp,_),v@(j,xj)) =
if isFunctionalType texp
then let fx = (j + length argtypes, 'f':xj)
in (fx,
[CLocalPat (CPVar fx)
(CSimpleRhs (applyF (mainmod,"list2Func") [CVar v]) [])])
else (v,[])
-------------------------------------------------------------------------
-- Turn all functions into public ones.
-- This ensures that all tests can be executed.
......@@ -1150,10 +1176,11 @@ genMainTestModule opts mainmod orgtestmods = do
let mainFunction = genMainFunction opts mainmod testfuncs
imports = nub $ [ easyCheckModule, easyCheckExecModule
, searchTreeModule, generatorModule
, "AnsiCodes","Maybe","System","Profile"] ++
, "List", "AnsiCodes", "Maybe", "System"
, "Profile"] ++
map (fst . fst) testtypes ++
map testModuleName testmods
appendix <- readFile (packagePath </> "src" </> "TestAppendix.curry")
appendix <- readFile (packagePath </> "include" </> "TestAppendix.curry")
writeCurryProgram opts "."
(CurryProg mainmod imports Nothing [] [] bottypes
(mainFunction : testfuncs ++ generators ++ pvalfuns ++ pevalfuns)
......
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