implementation module WhileCommon import StdBool, StdInt, StdList, StdClass, StdString from StdFunc import o from GenEq import generic gEq import Common import WhileLexer import Yard derive gEq AExpr, Operator, BExpr, Comparator instance zero State where zero = \v -> Left (Runtime "Undefined") instance toString AExpr where toString (Var v) = v toString (Lit i) = toString i toString (Op a1 op a2) = "(" <+ a1 <+ " " <+ op <+ " " <+ a2 <+ ")" instance toString Operator where toString Add = "+"; toString Sub = "-" toString Mul = "*"; toString Div = "/" instance toString BExpr where toString (Bool b) = if b "true" "false" toString (Not b) = "~" <+ b toString (And b1 b2) = "(" <+ b1 <+ " & " <+ b2 <+ ")" toString (Or b1 b2) = "(" <+ b1 <+ " | " <+ b2 <+ ")" toString (Comp a1 cmp a2) = a1 <+ " " <+ cmp <+ " " <+ a2 instance toString Comparator where toString Eq = "="; toString Ne = "<>" toString Le = "<="; toString Lt = "<" toString Ge = ">="; toString Gt = ">" instance eval AExpr Int where eval :: AExpr State -> Either Error Int eval (Var v) st = st v eval (Lit i) _ = pure i eval (Op a1 op a2) st = eval a1 st >>= \r1 -> eval a2 st >>= app op r1 where app :: Operator Int Int -> Either Error Int app Div i 0 = Left (Runtime "Division by 0") app op i j = Right $ (case op of Add = (+); Sub = (-); Mul = (*); Div = (/)) i j instance eval BExpr Bool where eval (Bool b) st = pure b eval (Not b) st = not <$> eval b st eval (And b1 b2) st = liftM2 (&&) (eval b1 st) (eval b2 st) eval (Or b1 b2) st = liftM2 (||) (eval b1 st) (eval b2 st) eval (Comp a1 cmp a2) st = liftM2 (toCmp cmp) (eval a1 st) (eval a2 st) where toCmp :: Comparator -> Int Int -> Bool toCmp Eq = (==) toCmp Ne = (<>) toCmp Le = (<=) toCmp Lt = (<) toCmp Ge = (>=) toCmp Gt = (>) pbexpr :: Parser Token BExpr pbexpr = liftM2 Or pbconj (item OrToken *> pbexpr) <|> pbconj pbconj = liftM2 And pbnot (item AndToken *> pbconj) <|> pbnot pbnot = item NotToken *> pbnot <|> pbcomp pbcomp = liftM3 Comp paexpr (toComp <$> satisfy isCompToken) paexpr <|> pbconst pbconst = toBool <$> satisfy isBoolToken <|> item ParenOpen *> pbexpr <* item ParenClose paexpr :: Parser Token AExpr paexpr = liftOp Add pasub (item AddToken *> paexpr) <|> pasub pasub = liftM2 (foldl (\r->Op r Sub)) pamul (many (item SubToken *> pamul)) pamul = liftOp Mul padiv (item MulToken *> pamul) <|> padiv padiv = liftM2 (foldl (\r->Op r Div)) paref (many (item DivToken *> paref)) paref = Var o toVar <$> satisfy isVarToken <|> (\(LiteralToken i) -> Lit i) <$> satisfy isLiteralToken <|> item ParenOpen *> paexpr <* item ParenClose toComp EqToken = Eq; toComp NeToken = Ne toComp LeToken = Le; toComp LtToken = Lt toComp GeToken = Ge; toComp GtToken = Gt isCompToken t = isMember t [EqToken,NeToken,LeToken,LtToken,GeToken,GtToken] toBool (BoolToken b) = Bool b isBoolToken (BoolToken _) = True; isBoolToken _ = False toVar (VarToken v) = v isVarToken (VarToken _) = True; isVarToken _ = False isLiteralToken (LiteralToken _) = True; isLiteralToken _ = False liftOp :: Operator (m AExpr) (m AExpr) -> m AExpr | Monad m liftOp op a1 a2 = a1 >>= \r1 -> a2 >>= \r2 -> pure (Op r1 op r2)