🤡

a5/src/APL/Tests.hs

@@ -0,0 +1,121 @@
+module APL.Tests
+  ( properties,
+    genVar
+  )
+where
+
+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
+  ( Property
+  , Gen
+  , Arbitrary (arbitrary, shrink)
+  , property
+  , cover
+  , 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 [])
+
+  shrink (Add e1 e2) =
+    e1 : e2 : [Add e1' e2 | e1' <- shrink e1] ++ [Add e1 e2' | e2' <- shrink e2]
+  shrink (Sub e1 e2) =
+    e1 : e2 : [Sub e1' e2 | e1' <- shrink e1] ++ [Sub e1 e2' | e2' <- shrink e2]
+  shrink (Mul e1 e2) =
+    e1 : e2 : [Mul e1' e2 | e1' <- shrink e1] ++ [Mul e1 e2' | e2' <- shrink e2]
+  shrink (Div e1 e2) =
+    e1 : e2 : [Div e1' e2 | e1' <- shrink e1] ++ [Div e1 e2' | e2' <- shrink e2]
+  shrink (Pow e1 e2) =
+    e1 : e2 : [Pow e1' e2 | e1' <- shrink e1] ++ [Pow e1 e2' | e2' <- shrink e2]
+  shrink (Eql e1 e2) =
+    e1 : e2 : [Eql e1' e2 | e1' <- shrink e1] ++ [Eql e1 e2' | e2' <- shrink e2]
+  shrink (If cond e1 e2) =
+    e1 : e2 : [If cond' e1 e2 | cond' <- shrink cond] ++ [If cond e1' e2 | e1' <- shrink e1] ++ [If cond e1 e2' | e2' <- shrink e2]
+  shrink (Let x e1 e2) =
+    e1 : [Let x e1' e2 | e1' <- shrink e1] ++ [Let x e1 e2' | e2' <- shrink e2]
+  shrink (Lambda x e) =
+    [Lambda x e' | e' <- shrink e]
+  shrink (Apply e1 e2) =
+    e1 : e2 : [Apply e1' e2 | e1' <- shrink e1] ++ [Apply e1 e2' | e2' <- shrink e2]
+  shrink (TryCatch e1 e2) =
+    e1 : e2 : [TryCatch e1' e2 | e1' <- shrink e1] ++ [TryCatch e1 e2' | e2' <- shrink e2]
+  shrink _ = []
+
+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
+    thirdSize = size `div` 3
+
+expCoverage :: Exp -> Property
+expCoverage e = checkCoverage
+  . cover 20 (any isDomainError (checkExp e)) "domain error"
+  . cover 20 (not $ any isDomainError (checkExp e)) "no domain error"
+  . cover 20 (any isTypeError (checkExp e)) "type error"
+  . cover 20 (not $ any isTypeError (checkExp e)) "no type error"
+  . cover 5 (any isVariableError (checkExp e)) "variable error"
+  . cover 70 (not $ any isVariableError (checkExp e)) "no variable error"
+  . cover 50 (or [2 <= n && n <= 4 | Var v <- subExp e, let n = length v]) "non-trivial variable"
+  $ ()
+
+parsePrinted :: Exp -> Bool
+parsePrinted e = case (parseAPL "input" (printExp e)) of
+  Left _ -> False
+  Right e' -> e == e'
+
+onlyCheckedErrors :: Exp -> Bool
+onlyCheckedErrors _ = undefined
+
+properties :: [(String, Property)]
+properties =
+  [ ("expCoverage", property expCoverage)
+  , ("parsePrinted", property parsePrinted)
+  , ("onlyCheckedErrors", property onlyCheckedErrors)
+  ]