summaryrefslogtreecommitdiff
path: root/paper/While/WhileCommon.icl
blob: a76458f278e7a12b6b024620e7ad1f36d963a118 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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 >>= toOp op r1
	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 = 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 = \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 = 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)