summaryrefslogtreecommitdiff
path: root/paper/While/WhileCommon.icl
diff options
context:
space:
mode:
Diffstat (limited to 'paper/While/WhileCommon.icl')
-rw-r--r--paper/While/WhileCommon.icl94
1 files changed, 94 insertions, 0 deletions
diff --git a/paper/While/WhileCommon.icl b/paper/While/WhileCommon.icl
new file mode 100644
index 0000000..353f997
--- /dev/null
+++ b/paper/While/WhileCommon.icl
@@ -0,0 +1,94 @@
+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 variable")
+
+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 (Var v) st = st v
+ eval (Lit i) st = pure i
+ eval (Op a1 op a2) st = eval a1 st >>= \r1 -> eval a2 st >>= \r2 -> toOp op r1 r2
+ where
+ toOp :: Operator -> Int Int -> Either Error Int
+ toOp Add = \i j -> pure (i + j)
+ toOp Sub = \i j -> pure (i - j)
+ toOp Mul = \i j -> pure (i * j)
+ toOp Div = \i j -> if (j == 0) (Left (Runtime "Division by 0")) (pure (i / j))
+
+instance eval BExpr Bool
+where
+ eval (Bool b) st = pure b
+ eval (Not b) st = eval b st >>= pure o not
+ eval (And b1 b2) st = eval b1 st >>= \r -> eval b2 st >>= pure o ((&&) r)
+ eval (Or b1 b2) st = eval b1 st >>= \r -> eval b2 st >>= pure o ((||) r)
+ eval (Comp a1 cmp a2) st = eval a1 st >>= \r -> eval a2 st >>= pure o (toCmp cmp r)
+ where
+ toCmp :: Comparator -> Int Int -> Bool
+ toCmp Eq = \i j -> i == j
+ toCmp Ne = \i j -> i <> j
+ toCmp Le = \i j -> i <= j
+ toCmp Lt = \i j -> i < j
+ toCmp Ge = \i j -> i >= j
+ toCmp Gt = \i j -> i > j
+
+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 = Lt
+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)