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
|
module DSL.Parsing where
import Data.Char (isDigit, isSpace)
import DSL.Types
import DSL.BaseParsers
buildDSLLexer :: Parser Char [Char] -> TokenTag -> DSLLexer
buildDSLLexer p t = do
str <- p
return Token { tStr=str, tTag=t }
fromStringL :: String -> TokenTag -> DSLLexer
fromStringL s t = buildDSLLexer (list s) t
fromTableL :: [(String, TokenTag)] -> DSLLexer
fromTableL table = firstOf $ map (uncurry fromStringL) table
wsL :: DSLLexer
wsL = buildDSLLexer (mult1 $ satisfy isSpace) T_WHITESPACE
keywordL :: DSLLexer
keywordL = fromTableL [ ("IF", T_IF)
, ("ELSE", T_ELSE)
, ("WHILE", T_WHILE)
, ("DO", T_DO)
, ("END", T_END)
]
intLiteralL :: DSLLexer
intLiteralL = buildDSLLexer go T_INT_LITERAL
where
go = do
sign <- optionalMaybe $ token '-'
digits <- mult1 $ satisfy isDigit
result $ maybe digits (:digits) sign
boolLiteralL :: DSLLexer
boolLiteralL = f "true" `alt` f "false"
where
f s = fromStringL s T_BOOL_LITERAL
stringLiteralL :: DSLLexer
stringLiteralL = buildDSLLexer go T_STRING_LITERAL
where
go = token '"' *> strChars <* token '"'
strChars = concat <$> mult strChar
strChar = list ['\\', '"'] `alt` (pure <$> satisfy (/='"'))
literalL :: DSLLexer
literalL = firstOf [ intLiteralL
, boolLiteralL
, stringLiteralL
]
intrinsicL :: DSLLexer
intrinsicL = fromTableL [ (".", T_INTRINSIC I_DUMP)
, ("DROP", T_INTRINSIC I_DROP)
, ("SWAP", T_INTRINSIC I_SWAP)
, ("DUP", T_INTRINSIC I_DUP)
, ("OVER", T_INTRINSIC I_OVER)
, ("ROT", T_INTRINSIC I_ROT)
, ("+", T_INTRINSIC I_PLUS)
, ("-", T_INTRINSIC I_MINUS)
, ("*", T_INTRINSIC I_TIMES)
, ("/%", T_INTRINSIC I_DIVMOD)
, ("!", T_INTRINSIC I_NOT)
, ("&&", T_INTRINSIC I_AND)
, ("||", T_INTRINSIC I_OR)
, ("^", T_INTRINSIC I_XOR)
, ("==", T_INTRINSIC I_EQUAL)
, ("<", T_INTRINSIC I_LESSTHAN)
, (">", T_INTRINSIC I_GREATERTHAN)
]
lexemeL :: DSLLexer
lexemeL = firstOf [ keywordL
, literalL
, intrinsicL
]
tokenizer :: Parser Char [Token]
tokenizer = optional wsL *> lexemeL `sepBy` wsL <* optional wsL
------------------------------------------------------------------------------
-- Parsing
------------------------------------------------------------------------------
tagP :: TokenTag -> DSLParser Token
tagP t = satisfy $ (==t) . tTag
wsP :: DSLParser ()
wsP = () <$ tagP T_WHITESPACE
dataLiteralP :: DSLParser StackData
dataLiteralP = do
Token { tTag=t, tStr=s } <- anyToken
case (t, s) of
(T_BOOL_LITERAL, "true") -> result $ StackBool True
(T_BOOL_LITERAL, "false") -> result $ StackBool False
(T_INT_LITERAL, _) -> result $ StackInt $ read s
(T_STRING_LITERAL, _) -> result $ StackString s
_ -> flunk
pushDataP :: DSLParser Operation
pushDataP = OpPushData <$> dataLiteralP
intrinsicP :: DSLParser Operation
intrinsicP = do
t <- anyToken
case tTag t of
T_INTRINSIC i -> result $ OpIntrinsic i
_ -> flunk
operationP :: DSLParser Operation
operationP = firstOf [ pushDataP
, intrinsicP
]
linearP :: DSLParser Block
linearP = BLinear <$> mult1 operationP
ifP :: DSLParser Block
ifP = do
c <- tagP T_IF *> mult blockP <* tagP T_DO
b <- mult blockP <* tagP T_END
return $ BIf c b
ifElseP :: DSLParser Block
ifElseP = do
c <- tagP T_IF *> mult blockP <* tagP T_DO
b1 <- mult blockP <* tagP T_ELSE
b2 <- mult blockP <* tagP T_END
return $ BIfElse c b1 b2
whileP :: DSLParser Block
whileP = do
c <- tagP T_WHILE *> mult blockP <* tagP T_DO
b <- mult blockP <* tagP T_END
return $ BWhile c b
blockP :: DSLParser Block
blockP = firstOf [ whileP
, ifElseP
, ifP
, linearP
]
programP :: DSLParser Program
programP = phrase $ mult1 blockP
stringToProgram :: String -> Maybe Program
stringToProgram = fmap snd . parse (chain tokenizer programP)
|
