From e994dbda3870430bafd9dfe6dbe1f7f2ef18a5a9 Mon Sep 17 00:00:00 2001 From: Nikolaj Gade Date: Fri, 11 Oct 2024 14:41:07 +0200 Subject: [PATCH] :clown_face: --- a5/{a5-handout => }/a5.cabal | 0 a5/{a5-handout => }/apl.hs | 0 a5/{a5-handout => }/runtests.hs | 0 a5/{a5-handout => }/src/APL/AST.hs | 0 a5/{a5-handout => }/src/APL/Check.hs | 0 a5/{a5-handout => }/src/APL/Error.hs | 0 a5/{a5-handout => }/src/APL/Eval.hs | 0 a5/{a5-handout => }/src/APL/Parser.hs | 2 +- a5/{a5-handout => }/src/APL/Tests.hs | 75 +++++++++++++++++++-------- 9 files changed, 53 insertions(+), 24 deletions(-) rename a5/{a5-handout => }/a5.cabal (100%) rename a5/{a5-handout => }/apl.hs (100%) rename a5/{a5-handout => }/runtests.hs (100%) rename a5/{a5-handout => }/src/APL/AST.hs (100%) rename a5/{a5-handout => }/src/APL/Check.hs (100%) rename a5/{a5-handout => }/src/APL/Error.hs (100%) rename a5/{a5-handout => }/src/APL/Eval.hs (100%) rename a5/{a5-handout => }/src/APL/Parser.hs (98%) rename a5/{a5-handout => }/src/APL/Tests.hs (58%) diff --git a/a5/a5-handout/a5.cabal b/a5/a5.cabal similarity index 100% rename from a5/a5-handout/a5.cabal rename to a5/a5.cabal diff --git a/a5/a5-handout/apl.hs b/a5/apl.hs similarity index 100% rename from a5/a5-handout/apl.hs rename to a5/apl.hs diff --git a/a5/a5-handout/runtests.hs b/a5/runtests.hs similarity index 100% rename from a5/a5-handout/runtests.hs rename to a5/runtests.hs diff --git a/a5/a5-handout/src/APL/AST.hs b/a5/src/APL/AST.hs similarity index 100% rename from a5/a5-handout/src/APL/AST.hs rename to a5/src/APL/AST.hs diff --git a/a5/a5-handout/src/APL/Check.hs b/a5/src/APL/Check.hs similarity index 100% rename from a5/a5-handout/src/APL/Check.hs rename to a5/src/APL/Check.hs diff --git a/a5/a5-handout/src/APL/Error.hs b/a5/src/APL/Error.hs similarity index 100% rename from a5/a5-handout/src/APL/Error.hs rename to a5/src/APL/Error.hs diff --git a/a5/a5-handout/src/APL/Eval.hs b/a5/src/APL/Eval.hs similarity index 100% rename from a5/a5-handout/src/APL/Eval.hs rename to a5/src/APL/Eval.hs diff --git a/a5/a5-handout/src/APL/Parser.hs b/a5/src/APL/Parser.hs similarity index 98% rename from a5/a5-handout/src/APL/Parser.hs rename to a5/src/APL/Parser.hs index d58c41d..0d98dd2 100644 --- a/a5/a5-handout/src/APL/Parser.hs +++ b/a5/src/APL/Parser.hs @@ -1,4 +1,4 @@ -module APL.Parser (parseAPL) where +module APL.Parser (parseAPL, keywords) where import APL.AST (Exp (..), VName) import Control.Monad (void) diff --git a/a5/a5-handout/src/APL/Tests.hs b/a5/src/APL/Tests.hs similarity index 58% rename from a5/a5-handout/src/APL/Tests.hs rename to a5/src/APL/Tests.hs index 7ab874e..beffa70 100644 --- a/a5/a5-handout/src/APL/Tests.hs +++ b/a5/src/APL/Tests.hs @@ -1,9 +1,11 @@ module APL.Tests - ( properties + ( properties, + genVar ) where -import APL.AST (Exp (..), subExp) +import APL.AST (Exp (..), subExp, VName, printExp) +import APL.Parser (parseAPL, keywords) import APL.Error (isVariableError, isDomainError, isTypeError) import APL.Check (checkExp) import Test.QuickCheck @@ -15,10 +17,25 @@ import Test.QuickCheck , checkCoverage , oneof , sized + , frequency + , elements + , listOf + , suchThat + , resize ) +genString :: Gen String +genString = resize 4 $ listOf $ elements ['a'..'z'] + +varTest :: String -> Bool +varTest s = (not (s `elem` keywords)) && ((length s) > 1) + +genVar :: Gen String +genVar = suchThat (genString) (varTest) + + instance Arbitrary Exp where - arbitrary = sized genExp + arbitrary = sized (genExp []) shrink (Add e1 e2) = e1 : e2 : [Add e1' e2 | e1' <- shrink e1] ++ [Add e1 e2' | e2' <- shrink e2] @@ -44,24 +61,34 @@ instance Arbitrary Exp where e1 : e2 : [TryCatch e1' e2 | e1' <- shrink e1] ++ [TryCatch e1 e2' | e2' <- shrink e2] shrink _ = [] -genExp :: Int -> Gen Exp -genExp 0 = oneof [CstInt <$> arbitrary, CstBool <$> arbitrary] -genExp size = - oneof - [ CstInt <$> arbitrary - , CstBool <$> arbitrary - , Add <$> genExp halfSize <*> genExp halfSize - , Sub <$> genExp halfSize <*> genExp halfSize - , Mul <$> genExp halfSize <*> genExp halfSize - , Div <$> genExp halfSize <*> genExp halfSize - , Pow <$> genExp halfSize <*> genExp halfSize - , Eql <$> genExp halfSize <*> genExp halfSize - , If <$> genExp thirdSize <*> genExp thirdSize <*> genExp thirdSize - , Var <$> arbitrary - , Let <$> arbitrary <*> genExp halfSize <*> genExp halfSize - , Lambda <$> arbitrary <*> genExp (size - 1) - , Apply <$> genExp halfSize <*> genExp halfSize - , TryCatch <$> genExp halfSize <*> genExp halfSize +genExp :: [VName] -> Int -> Gen Exp +genExp _ 0 = oneof [CstInt <$> arbitrary, CstBool <$> arbitrary] +genExp vars size = + frequency + [ (1, CstInt <$> arbitrary) + , (1, CstBool <$> arbitrary) + , (1, Add <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, Sub <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, Mul <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, Div <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, Pow <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, Eql <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, If <$> genExp vars thirdSize <*> genExp vars thirdSize <*> genExp vars thirdSize) + , (1, Var <$> arbitrary) + , (if (length vars) > 0 then 50 else 0, Var <$> elements vars) + , (25, do + var <- genVar + e1 <- genExp vars halfSize + e2 <- genExp (var:vars) halfSize + pure $ Let var e1 e2 + ) + , (25, do + var <- genVar + body <- genExp vars (size - 1) + pure $ Lambda var body + ) + , (1, Apply <$> genExp vars halfSize <*> genExp vars halfSize) + , (1, TryCatch <$> genExp vars halfSize <*> genExp vars halfSize) ] where halfSize = size `div` 2 @@ -79,7 +106,9 @@ expCoverage e = checkCoverage $ () parsePrinted :: Exp -> Bool -parsePrinted _ = undefined +parsePrinted e = case (parseAPL "input" (printExp e)) of + Left _ -> False + Right e' -> e == e' onlyCheckedErrors :: Exp -> Bool onlyCheckedErrors _ = undefined @@ -87,6 +116,6 @@ onlyCheckedErrors _ = undefined properties :: [(String, Property)] properties = [ ("expCoverage", property expCoverage) - , ("onlyCheckedErrors", property onlyCheckedErrors) , ("parsePrinted", property parsePrinted) + , ("onlyCheckedErrors", property onlyCheckedErrors) ]