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
|
module DSL.Parsing where
import Data.Char (isDigit, isSpace)
import DSL.Types
import DSL.BaseParsers
buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer
buildDSLLexer p f = do
str <- p
return DSLToken { tStr=str
, tData=f str
}
keywordL :: String -> TokenData -> DSLLexer
keywordL s d = buildDSLLexer (list s) (const d)
intrinsicL :: String -> Intrinsic -> DSLLexer
intrinsicL s i = keywordL s $ T_INTRINSIC i
wsL :: DSLLexer
wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE)
boolLiteralL :: DSLLexer
boolLiteralL = t `alt` f
where
t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True)
f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False)
intLiteralL :: DSLLexer
intLiteralL = buildDSLLexer go (T_INT_LITERAL . read)
where
go = do
sign <- optional $ token '-'
digits <- mult1 $ satisfy isDigit
result $ maybe digits (:digits) sign
mainLexer :: Parser Char [DSLToken]
mainLexer = phrase $ mult1 $ firstOf subLexers
where
subLexers = [wsL]
++ keywords
++ literals
++ intrinsics
keywords = map (uncurry keywordL) [ ("IF", T_IF)
, ("ELSE", T_ELSE)
, ("WHILE", T_WHILE)
, ("DO", T_DO)
, ("END", T_END)
]
literals = [ boolLiteralL
, intLiteralL
]
intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP)
, ("DROP", I_DROP)
, ("SWAP", I_SWAP)
, ("DUP", I_DUP)
, ("OVER", I_OVER)
, ("ROT", I_ROT)
, ("+", I_PLUS)
, ("-", I_MINUS)
, ("*", I_TIMES)
, ("/%", I_DIVMOD)
, ("!", I_NOT)
, ("&&", I_AND)
, ("||", I_OR)
, ("^", I_XOR)
, ("==", I_EQUAL)
, ("<", I_LESSTHAN)
, (">", I_GREATERTHAN)
]
stripWhitespace :: [DSLToken] -> [DSLToken]
stripWhitespace = filter $ not . (==T_WHITESPACE) . tData
------------------------------------------------------------------------------
-- Parsing
------------------------------------------------------------------------------
tokenDataP :: TokenData -> DSLParser DSLToken
tokenDataP t = satisfy $ (==t) . tData
wsP :: DSLParser ()
wsP = () <$ tokenDataP T_WHITESPACE
dataLiteralP :: DSLParser StackData
dataLiteralP = do
t <- anyToken
case tData t of
T_INT_LITERAL x -> result $ StackInt x
T_BOOL_LITERAL x -> result $ StackBool x
_ -> flunk
pushDataP :: DSLParser Operation
pushDataP = OpPushData <$> dataLiteralP
intrinsicP :: DSLParser Operation
intrinsicP = do
t <- anyToken
case tData 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 <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO
b <- mult blockP <* tokenDataP T_END
return $ BIf c b
ifElseP :: DSLParser Block
ifElseP = do
c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO
b1 <- mult blockP <* tokenDataP T_ELSE
b2 <- mult blockP <* tokenDataP T_END
return $ BIfElse c b1 b2
whileP :: DSLParser Block
whileP = do
c <- tokenDataP T_WHILE *> mult blockP <* tokenDataP T_DO
b <- mult blockP <* tokenDataP 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 str = do
(_, tokens) <- parse mainLexer str
(_, program) <- parse programP $ stripWhitespace tokens
return program
|
