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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
implementation module Sjit.Syntax
import StdEnv
import Control.Applicative
import Control.Monad
import Data.Either
from Data.Func import $
import Data.Functor
import Data.GenEq
import Data.Maybe
import Text.Parsers.Simple.Core
:: Token
= TIdent !String
| TInt !Int
| TTrue
| TFalse
| TIf
| TEq
| TComma
| TParenOpen
| TParenClose
derive gEq Token
instance == Token where == a b = a === b
instance toString Token
where
toString t = case t of
TIdent s -> "'" +++ s +++ "'"
TInt n -> toString n
TTrue -> "True"
TFalse -> "False"
TIf -> "if"
TEq -> "="
TComma -> ","
TParenOpen -> "("
TParenClose -> ")"
lex :: !String -> Either String [Token]
lex s = reverse <$> lex [] 0 (size s) s
where
lex :: ![Token] !Int !Int !String -> Either String [Token]
lex tks i e s | i >= e = Right tks
lex tks i e s = case s.[i] of
w | isSpace w
-> lex tks (i+1) e s
n | isIdent n
# (i,n) = readIdent isIdent [] i e s
# tk = case n of
"True" -> TTrue
"False" -> TFalse
"if" -> TIf
n -> TIdent n
-> lex [tk:tks] i e s
n | isFunnyIdent n
# (i,n) = readIdent isFunnyIdent [] i e s
# tk = case n of
"=" -> TEq
n -> TIdent n
-> lex [tk:tks] i e s
n | isDigit n
# (i,n) = readInt [] i e s
-> lex [TInt n:tks] i e s
',' -> lex [TComma: tks] (i+1) e s
'(' -> lex [TParenOpen: tks] (i+1) e s
')' -> lex [TParenClose:tks] (i+1) e s
c -> Left ("Unexpected character '" +++ {c} +++ "'")
isIdent :: !Char -> Bool
isIdent c = isAlpha c || c == '_'
isFunnyIdent :: !Char -> Bool
isFunnyIdent c = isMember c ['+-*/<>=']
readIdent :: !(Char -> Bool) ![Char] !Int !Int !String -> (!Int, !String)
readIdent ok cs i e s
| i >= e = (i,{c \\ c <- reverse cs})
# c = s.[i]
| ok c = readIdent ok [c:cs] (i+1) e s
| otherwise = (i,{c \\ c <- reverse cs})
readInt :: ![Char] !Int !Int !String -> (!Int, !Int)
readInt cs i e s
| i >= e = (i,toInt {#c \\ c <- reverse cs})
# c = s.[i]
| isDigit c = readInt [c:cs] (i+1) e s
| otherwise = (i,toInt {#c \\ c <- reverse cs})
function :: Parser Token Function
function =:
liftM3 make_fun ident (many arg) (pToken TEq *> expr)
where
make_fun :: !String ![String] !Expr -> Function
make_fun name args expr = {fun_name=name, fun_args=args, fun_expr=expr}
expr :: Parser Token Expr
expr
= rightAssoc (toks ["==","<>","<","<=",">",">="])
$ leftAssoc (toks ["+","-"])
$ leftAssoc (toks ["*","/"])
$ noInfix
where
tok :: !String -> Parser Token String
tok s = pToken (TIdent s) $> s
toks fs = case map tok fs of
[t:ts] -> foldr (<|>) t ts
rightAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
rightAssoc opp exprp = exprp >>= \e1 ->
optional (opp >>= \op -> rightAssoc opp exprp >>= \e -> pure (op,e)) >>=
pure o maybe e1 (\(op,e2) -> App op [e1,e2])
leftAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
leftAssoc opp exprp = exprp >>= \e1 ->
many (opp >>= \op -> exprp >>= \e -> pure (op,e)) >>=
foldM (\e (op,e2) -> pure $ App op [e,e2]) e1
noInfix :: Parser Token Expr
noInfix =
liftM2 App ident (pToken TParenOpen *> pSepBy expr (pToken TComma) <* pToken TParenClose)
<|> liftM3 If (pToken TIf *> expr) expr expr
<|> Var <$> ident
<|> Int <$> int
<|> Bool <$> bool
<|> (pToken TParenOpen *> expr <* pToken TParenClose)
ident :: Parser Token String
ident =: (\(TIdent n) -> n) <$> pSatisfy (\t->t=:TIdent _)
arg :: Parser Token String
arg =: ident
int :: Parser Token Int
int =: (\(TInt n) -> n) <$> pSatisfy (\t->t=:TInt _)
bool :: Parser Token Bool
bool =:
pToken TTrue $> True
<|> pToken TFalse $> False
parse_function :: !String -> Either String Function
parse_function s = lex s >>= \tks -> case parse function tks of
Right f -> Right f
Left _ -> Left "parsing failed"
parse_interactive_line :: !String -> Either String Function
parse_interactive_line s = lex s >>= \tks -> case parse function tks of
Right f -> Right f
Left _ -> case parse expr tks of
Right e -> Right {fun_name="main", fun_args=[], fun_expr=e}
Left _ -> Left "parsing failed"
|
