🤡
This commit is contained in:
82
a5/src/APL/AST.hs
Normal file
82
a5/src/APL/AST.hs
Normal file
@ -0,0 +1,82 @@
|
||||
module APL.AST
|
||||
( VName
|
||||
, Exp (..)
|
||||
, printExp
|
||||
, subExp
|
||||
)
|
||||
where
|
||||
|
||||
type VName = String
|
||||
|
||||
data Exp
|
||||
= CstInt Integer
|
||||
| CstBool Bool
|
||||
| Add Exp Exp
|
||||
| Sub Exp Exp
|
||||
| Mul Exp Exp
|
||||
| Div Exp Exp
|
||||
| Pow Exp Exp
|
||||
| Eql Exp Exp
|
||||
| If Exp Exp Exp
|
||||
| Var VName
|
||||
| Let VName Exp Exp
|
||||
| Lambda VName Exp
|
||||
| Apply Exp Exp
|
||||
| TryCatch Exp Exp
|
||||
deriving (Eq, Show)
|
||||
|
||||
parens :: String -> String
|
||||
parens x = "(" ++ x ++ ")"
|
||||
|
||||
printBinOp :: String -> Exp -> Exp -> String
|
||||
printBinOp op x y = parens $ printExp x ++ " " ++ op ++ " " ++ printExp y
|
||||
|
||||
printExp :: Exp -> String
|
||||
printExp (CstInt x) = show x
|
||||
printExp (CstBool b) = if b then "true" else "false"
|
||||
printExp (Add x y) = printBinOp "+" x y
|
||||
printExp (Sub x y) = printBinOp "-" x y
|
||||
printExp (Mul x y) = printBinOp "*" x y
|
||||
printExp (Div x y) = printBinOp "/" x y
|
||||
printExp (Pow x y) = printBinOp "**" x y
|
||||
printExp (Eql x y) = printBinOp "==" x y
|
||||
printExp (If x y z) =
|
||||
parens $
|
||||
"if "
|
||||
++ printExp x
|
||||
++ " then "
|
||||
++ printExp y
|
||||
++ " else "
|
||||
++ printExp z
|
||||
printExp (Var v) = v
|
||||
printExp (Let v e1 e2) =
|
||||
parens $
|
||||
"let "
|
||||
++ v
|
||||
++ " = "
|
||||
++ printExp e1
|
||||
++ " in "
|
||||
++ printExp e2
|
||||
printExp (Lambda v body) =
|
||||
parens $ "\\" ++ v ++ " -> " ++ printExp body
|
||||
printExp (Apply x y) =
|
||||
printExp x ++ " " ++ printExp y
|
||||
printExp (TryCatch x y) =
|
||||
"try " ++ printExp x ++ " catch " ++ printExp y
|
||||
|
||||
subExp :: Exp -> [Exp]
|
||||
subExp e = e : case e of
|
||||
CstInt _ -> []
|
||||
CstBool _ -> []
|
||||
Add e1 e2 -> subExp e1 ++ subExp e2
|
||||
Sub e1 e2 -> subExp e1 ++ subExp e2
|
||||
Mul e1 e2 -> subExp e1 ++ subExp e2
|
||||
Div e1 e2 -> subExp e1 ++ subExp e2
|
||||
Pow e1 e2 -> subExp e1 ++ subExp e2
|
||||
Eql e1 e2 -> subExp e1 ++ subExp e2
|
||||
If e0 e1 e2 -> subExp e0 ++ subExp e1 ++ subExp e2
|
||||
Var _ -> []
|
||||
Let _ e1 e2 -> subExp e1 ++ subExp e2
|
||||
Lambda _ body -> subExp body
|
||||
Apply e1 e2 -> subExp e1 ++ subExp e2
|
||||
TryCatch e1 e2 -> subExp e1 ++ subExp e2
|
||||
92
a5/src/APL/Check.hs
Normal file
92
a5/src/APL/Check.hs
Normal file
@ -0,0 +1,92 @@
|
||||
module APL.Check (checkExp, Error) where
|
||||
|
||||
import APL.AST (Exp (..), VName)
|
||||
import APL.Error (Error (..))
|
||||
import Control.Monad (ap, liftM, unless)
|
||||
import Data.List (union)
|
||||
|
||||
type Vars = [VName]
|
||||
|
||||
newtype CheckM a = CheckM {runCheckM :: Vars -> (a, [Error])}
|
||||
|
||||
instance Functor CheckM where
|
||||
fmap = liftM
|
||||
|
||||
instance Applicative CheckM where
|
||||
(<*>) = ap
|
||||
pure x = CheckM $ \_ -> (x, [])
|
||||
|
||||
instance Monad CheckM where
|
||||
CheckM x >>= f = CheckM $ \vars ->
|
||||
let (y, errs1) = x vars
|
||||
(z, errs2) = runCheckM (f y) vars
|
||||
in (z, union errs1 errs2)
|
||||
|
||||
askVars :: CheckM Vars
|
||||
askVars = CheckM $ \vars -> (vars, [])
|
||||
|
||||
localVars :: (Vars -> Vars) -> CheckM a -> CheckM a
|
||||
localVars f m = CheckM $ \vars ->
|
||||
runCheckM m (f vars)
|
||||
|
||||
failure :: Error -> CheckM ()
|
||||
failure err = CheckM $ \_ -> ((), [err])
|
||||
|
||||
maskErrors :: CheckM a -> CheckM a
|
||||
maskErrors m = CheckM $ \vars ->
|
||||
let (x, _) = runCheckM m vars in (x, [])
|
||||
|
||||
check :: Exp -> CheckM ()
|
||||
check (CstInt _) = pure ()
|
||||
check (CstBool _) = pure ()
|
||||
check (Var v) = do
|
||||
vars <- askVars
|
||||
unless (v `elem` vars) $
|
||||
failure $
|
||||
UnknownVariable v
|
||||
check (Add x y) = do
|
||||
failure NonInteger
|
||||
check x
|
||||
check y
|
||||
check (Sub x y) = do
|
||||
failure NonInteger
|
||||
check x
|
||||
check y
|
||||
check (Mul x y) = do
|
||||
failure NonInteger
|
||||
check x
|
||||
check y
|
||||
check (Div x y) = do
|
||||
failure NonInteger
|
||||
failure DivisionByZero
|
||||
check x
|
||||
check y
|
||||
check (Pow x y) = do
|
||||
failure NonInteger
|
||||
failure NegativeExponent
|
||||
check x
|
||||
check y
|
||||
check (Eql x y) = do
|
||||
failure InvalidEqual
|
||||
check x
|
||||
check y
|
||||
check (If x y z) = do
|
||||
failure NonBoolean
|
||||
check x
|
||||
check y
|
||||
check z
|
||||
check (Let v e1 e2) = do
|
||||
check e1
|
||||
localVars (v :) $ check e2
|
||||
check (Lambda v e) = do
|
||||
localVars (v :) $ check e
|
||||
check (Apply x y) = do
|
||||
failure NonFunction
|
||||
check x
|
||||
check y
|
||||
check (TryCatch x y) = do
|
||||
maskErrors $ check x
|
||||
check y
|
||||
|
||||
checkExp :: Exp -> [Error]
|
||||
checkExp e = snd $ runCheckM (check e) []
|
||||
35
a5/src/APL/Error.hs
Normal file
35
a5/src/APL/Error.hs
Normal file
@ -0,0 +1,35 @@
|
||||
module APL.Error
|
||||
( Error(..)
|
||||
, isVariableError
|
||||
, isDomainError
|
||||
, isTypeError
|
||||
)
|
||||
where
|
||||
|
||||
import APL.AST (VName)
|
||||
|
||||
data Error
|
||||
= NonInteger
|
||||
| UnknownVariable VName
|
||||
| DivisionByZero
|
||||
| NegativeExponent
|
||||
| InvalidEqual
|
||||
| NonBoolean
|
||||
| NonFunction
|
||||
deriving (Show, Eq)
|
||||
|
||||
isVariableError :: Error -> Bool
|
||||
isVariableError (UnknownVariable _) = True
|
||||
isVariableError _ = False
|
||||
|
||||
isDomainError :: Error -> Bool
|
||||
isDomainError DivisionByZero = True
|
||||
isDomainError NegativeExponent = True
|
||||
isDomainError _ = False
|
||||
|
||||
isTypeError :: Error -> Bool
|
||||
isTypeError NonInteger = True
|
||||
isTypeError InvalidEqual = True
|
||||
isTypeError NonBoolean = True
|
||||
isTypeError NonFunction = True
|
||||
isTypeError _ = False
|
||||
128
a5/src/APL/Eval.hs
Normal file
128
a5/src/APL/Eval.hs
Normal file
@ -0,0 +1,128 @@
|
||||
module APL.Eval
|
||||
( Val (..),
|
||||
Env,
|
||||
eval,
|
||||
runEval,
|
||||
)
|
||||
where
|
||||
|
||||
import APL.AST (Exp (..), VName)
|
||||
import APL.Error (Error (..))
|
||||
import Control.Monad (ap, liftM)
|
||||
|
||||
data Val
|
||||
= ValInt Integer
|
||||
| ValBool Bool
|
||||
| ValFun Env VName Exp
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Env = [(VName, Val)]
|
||||
|
||||
envEmpty :: Env
|
||||
envEmpty = []
|
||||
|
||||
envExtend :: VName -> Val -> Env -> Env
|
||||
envExtend v val env = (v, val) : env
|
||||
|
||||
envLookup :: VName -> Env -> Maybe Val
|
||||
envLookup v env = lookup v env
|
||||
|
||||
newtype EvalM a = EvalM (Env -> Either Error a)
|
||||
|
||||
instance Functor EvalM where
|
||||
fmap = liftM
|
||||
|
||||
instance Applicative EvalM where
|
||||
pure x = EvalM $ \_env -> Right x
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad EvalM where
|
||||
EvalM x >>= f = EvalM $ \env ->
|
||||
case x env of
|
||||
Left err -> Left err
|
||||
Right x' ->
|
||||
let EvalM y = f x'
|
||||
in y env
|
||||
|
||||
askEnv :: EvalM Env
|
||||
askEnv = EvalM $ \env -> Right env
|
||||
|
||||
localEnv :: (Env -> Env) -> EvalM a -> EvalM a
|
||||
localEnv f (EvalM m) = EvalM $ \env -> m (f env)
|
||||
|
||||
failure :: Error -> EvalM a
|
||||
failure s = EvalM $ \_env -> Left s
|
||||
|
||||
catch :: EvalM a -> EvalM a -> EvalM a
|
||||
catch (EvalM m1) (EvalM m2) = EvalM $ \env ->
|
||||
case m1 env of
|
||||
Left _ -> m2 env
|
||||
Right x -> Right x
|
||||
|
||||
runEval :: EvalM a -> Either Error a
|
||||
runEval (EvalM m) = m envEmpty
|
||||
|
||||
evalIntBinOp :: (Integer -> Integer -> EvalM Integer) -> Exp -> Exp -> EvalM Val
|
||||
evalIntBinOp f e1 e2 = do
|
||||
v1 <- eval e1
|
||||
v2 <- eval e2
|
||||
case (v1, v2) of
|
||||
(ValInt x, ValInt y) -> ValInt <$> f x y
|
||||
(_, _) -> failure NonInteger
|
||||
|
||||
evalIntBinOp' :: (Integer -> Integer -> Integer) -> Exp -> Exp -> EvalM Val
|
||||
evalIntBinOp' f e1 e2 =
|
||||
evalIntBinOp f' e1 e2
|
||||
where
|
||||
f' x y = pure $ f x y
|
||||
|
||||
eval :: Exp -> EvalM Val
|
||||
eval (CstInt x) = pure $ ValInt x
|
||||
eval (CstBool b) = pure $ ValBool b
|
||||
eval (Var v) = do
|
||||
env <- askEnv
|
||||
case envLookup v env of
|
||||
Just x -> pure x
|
||||
Nothing -> failure $ UnknownVariable v
|
||||
eval (Add e1 e2) = evalIntBinOp' (+) e1 e2
|
||||
eval (Sub e1 e2) = evalIntBinOp' (-) e1 e2
|
||||
eval (Mul e1 e2) = evalIntBinOp' (*) e1 e2
|
||||
eval (Div e1 e2) = evalIntBinOp checkedDiv e1 e2
|
||||
where
|
||||
checkedDiv _ 0 = failure DivisionByZero
|
||||
checkedDiv x y = pure $ x `div` y
|
||||
eval (Pow e1 e2) = evalIntBinOp checkedPow e1 e2
|
||||
where
|
||||
checkedPow x y =
|
||||
if y < 0
|
||||
then failure NegativeExponent
|
||||
else pure $ x ^ y
|
||||
eval (Eql e1 e2) = do
|
||||
v1 <- eval e1
|
||||
v2 <- eval e2
|
||||
case (v1, v2) of
|
||||
(ValInt x, ValInt y) -> pure $ ValBool $ x == y
|
||||
(ValBool x, ValBool y) -> pure $ ValBool $ x == y
|
||||
(_, _) -> failure InvalidEqual
|
||||
eval (If cond e1 e2) = do
|
||||
cond' <- eval cond
|
||||
case cond' of
|
||||
ValBool True -> eval e1
|
||||
ValBool False -> eval e2
|
||||
_ -> failure NonBoolean
|
||||
eval (Let var e1 e2) = do
|
||||
v1 <- eval e1
|
||||
localEnv (envExtend var v1) $ eval e2
|
||||
eval (Lambda var body) = do
|
||||
env <- askEnv
|
||||
pure $ ValFun env var body
|
||||
eval (Apply e1 e2) = do
|
||||
v1 <- eval e1
|
||||
v2 <- eval e2
|
||||
case (v1, v2) of
|
||||
(ValFun f_env var body, arg) ->
|
||||
localEnv (const $ envExtend var arg f_env) $ eval body
|
||||
(_, _) ->
|
||||
failure NonFunction
|
||||
eval (TryCatch e1 e2) =
|
||||
eval e1 `catch` eval e2
|
||||
168
a5/src/APL/Parser.hs
Normal file
168
a5/src/APL/Parser.hs
Normal file
@ -0,0 +1,168 @@
|
||||
module APL.Parser (parseAPL, keywords) where
|
||||
|
||||
import APL.AST (Exp (..), VName)
|
||||
import Control.Monad (void)
|
||||
import Data.Char (isAlpha, isAlphaNum, isDigit)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
( Parsec,
|
||||
choice,
|
||||
chunk,
|
||||
eof,
|
||||
errorBundlePretty,
|
||||
many,
|
||||
notFollowedBy,
|
||||
parse,
|
||||
satisfy,
|
||||
some,
|
||||
try,
|
||||
)
|
||||
import Text.Megaparsec.Char (space)
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
lexeme :: Parser a -> Parser a
|
||||
lexeme p = p <* space
|
||||
|
||||
keywords :: [String]
|
||||
keywords =
|
||||
[ "if",
|
||||
"then",
|
||||
"else",
|
||||
"true",
|
||||
"false",
|
||||
"let",
|
||||
"in",
|
||||
"try",
|
||||
"catch"
|
||||
]
|
||||
|
||||
lVName :: Parser VName
|
||||
lVName = lexeme $ try $ do
|
||||
c <- satisfy isAlpha
|
||||
cs <- many $ satisfy isAlphaNum
|
||||
let v = c : cs
|
||||
if v `elem` keywords
|
||||
then fail "Unexpected keyword"
|
||||
else pure v
|
||||
|
||||
lInteger :: Parser Integer
|
||||
lInteger =
|
||||
lexeme $ read <$> some (satisfy isDigit) <* notFollowedBy (satisfy isAlphaNum)
|
||||
|
||||
lString :: String -> Parser ()
|
||||
lString s = lexeme $ void $ chunk s
|
||||
|
||||
lKeyword :: String -> Parser ()
|
||||
lKeyword s = lexeme $ void $ try $ chunk s <* notFollowedBy (satisfy isAlphaNum)
|
||||
|
||||
lBool :: Parser Bool
|
||||
lBool =
|
||||
lexeme . try . choice $
|
||||
[ const True <$> lKeyword "true",
|
||||
const False <$> lKeyword "false"
|
||||
]
|
||||
|
||||
pAtom :: Parser Exp
|
||||
pAtom =
|
||||
choice
|
||||
[ CstInt <$> lInteger,
|
||||
CstBool <$> lBool,
|
||||
Var <$> lVName,
|
||||
lString "(" *> pExp <* lString ")"
|
||||
]
|
||||
|
||||
pFExp :: Parser Exp
|
||||
pFExp = chain =<< pAtom
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
y <- pAtom
|
||||
chain $ Apply x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pLExp :: Parser Exp
|
||||
pLExp =
|
||||
choice
|
||||
[ If
|
||||
<$> (lKeyword "if" *> pExp)
|
||||
<*> (lKeyword "then" *> pExp)
|
||||
<*> (lKeyword "else" *> pExp),
|
||||
Lambda
|
||||
<$> (lString "\\" *> lVName)
|
||||
<*> (lString "->" *> pExp),
|
||||
TryCatch
|
||||
<$> (lKeyword "try" *> pExp)
|
||||
<*> (lKeyword "catch" *> pExp),
|
||||
Let
|
||||
<$> (lKeyword "let" *> lVName)
|
||||
<*> (lString "=" *> pExp)
|
||||
<*> (lKeyword "in" *> pExp),
|
||||
pFExp
|
||||
]
|
||||
|
||||
pExp4 :: Parser Exp
|
||||
pExp4 = pLExp >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
lString "**"
|
||||
y <- pLExp
|
||||
Pow x <$> chain y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp3 :: Parser Exp
|
||||
pExp3 = pExp4 >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
lString "*"
|
||||
y <- pExp4
|
||||
chain $ Mul x y,
|
||||
do
|
||||
lString "/"
|
||||
y <- pExp4
|
||||
chain $ Div x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp2 :: Parser Exp
|
||||
pExp2 = pExp3 >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
lString "+"
|
||||
y <- pExp3
|
||||
chain $ Add x y,
|
||||
do
|
||||
lString "-"
|
||||
y <- pExp3
|
||||
chain $ Sub x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp1 :: Parser Exp
|
||||
pExp1 = pExp2 >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
lString "=="
|
||||
y <- pExp2
|
||||
chain $ Eql x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp :: Parser Exp
|
||||
pExp = pExp1
|
||||
|
||||
parseAPL :: FilePath -> String -> Either String Exp
|
||||
parseAPL fname s = case parse (space *> pExp <* eof) fname s of
|
||||
Left err -> Left $ errorBundlePretty err
|
||||
Right x -> Right x
|
||||
121
a5/src/APL/Tests.hs
Normal file
121
a5/src/APL/Tests.hs
Normal file
@ -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)
|
||||
]
|
||||
Reference in New Issue
Block a user