Commit b6b167da by 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 = "<>" -------------------------------------------------------------------------
 ... ... @@ -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!