blob: a9d733d016b41d26169e5fdd76980722124b6bb8 (
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
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 Sil.Parse
import StdBool
import StdChar
from StdFunc import o
import StdInt
import StdList
import StdString
import StdTuple
import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Functor
import Data.Maybe
from Text import <+
import GenEq
import Sil.Parse.Parser
import Sil.Syntax
import Sil.Util
derive gEq Token, Literal
instance == Token where == a b = gEq{|*|} a b
instance toString Token
where
toString TParenOpen = "("
toString TParenClose = ")"
toString TBraceOpen = "{"
toString TBraceClose = "}"
toString TComma = ","
toString TSemicolon = ";"
toString TAssign = ":="
toString (TLit l) = toString l
toString TIf = "if"
toString TWhile = "while"
toString TReturn = "return"
toString (TName s) = s
instance name Token
where
name (TLit _) = "literal"
name (TName _) = "name"
name t = toString t
instance toString ParseError
where
toString (Invalid loc sym) = "Invalid token '" <+ sym <+ "' while parsing a " <+ loc <+ "."
toString (Expected s) = "Expected " <+ s <+ "."
toString UnknownError = "Unknown error."
tokenise :: [Char] -> MaybeError ParseError [Token]
tokenise cs = reverse <$> tks cs []
where
tks :: [Char] [Token] -> MaybeError ParseError [Token]
tks [] t = pure t
tks ['(':r] t = tks r [TParenOpen :t]
tks [')':r] t = tks r [TParenClose:t]
tks ['{':r] t = tks r [TBraceOpen :t]
tks ['}':r] t = tks r [TBraceClose:t]
tks [',':r] t = tks r [TComma :t]
tks [';':r] t = tks r [TSemicolon :t]
tks [':':'=':r] t = tks r [TAssign :t]
tks ['i':'f' :s:r] t | isSpace s = tks r [TIf :t]
tks ['w':'h':'i':'l':'e' :s:r] t | isSpace s = tks r [TWhile :t]
tks ['r':'e':'t':'u':'r':'n':s:r] t | isSpace s = tks r [TReturn:t]
tks ['T':'r':'u':'e' :s:r] t | isSpace s = tks r [TLit $ BLit True:t]
tks ['F':'a':'l':'s':'e' :s:r] t | isSpace s = tks r [TLit $ BLit False:t]
tks cs=:[h:_] t
| isSpace h = tks (dropWhile isSpace cs) t
| isDigit h = tks numrest [TLit $ ILit $ toInt $ toString num:t]
| not (isNameChar h) = Error $ Invalid "name" h
| otherwise = tks namerest [TName $ toString name:t]
where
(name,namerest) = span isNameChar cs
(num,numrest) = span isDigit cs
isNameChar :: (Char -> Bool)
isNameChar = isAlpha
parse :: ([Token] -> MaybeError ParseError Program)
parse = fst o runParser program
program :: Parser Token Program
program = (\fs -> {p_funs=fs}) <$> some function <* eof
function :: Parser Token Function
function =
type >>= \t ->
name >>= \n ->
item TParenOpen >>= \_ ->
seplist TComma arg >>= \args ->
item TParenClose >>= \_ ->
item TBraceOpen >>= \_ ->
codeblock >>= \cb ->
item TBraceClose >>= \_ -> pure
{ f_type = t
, f_name = n
, f_args = args
, f_code = cb
}
codeblock :: Parser Token CodeBlock
codeblock = many initialisation >>= \i ->
many statement >>= \s ->
pure {cb_init=i, cb_content=s}
initialisation :: Parser Token Initialisation
initialisation =
type >>= \t ->
name >>= \n ->
item TSemicolon >>= \_ ->
pure {init_type=t, init_name=n}
statement :: Parser Token Statement
statement = (declaration
<|> liftM Application application
<|> return
/* <|> if`
<|> while*/) <* item TSemicolon
where
declaration :: Parser Token Statement
declaration = liftM2 Declaration name (item TAssign *> application)
application :: Parser Token Application
application
= liftM2 App name (item TParenOpen *> seplist TComma application <* item TParenClose)
<|> liftM Literal literal
<|> liftM Name name
return :: Parser Token Statement
return = liftM Return (item TReturn *> optional application)
name :: Parser Token Name
name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
where
isName (TName _) = True
isName _ = False
arg :: Parser Token Arg
arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
<?> Expected "argument"
type :: Parser Token Type
type
= type "Bool" TBool
<|> type "Int" TInt
<|> type "Void" TVoid
<?> Expected "type"
where
type s t = item (TName s) *> pure t
literal :: Parser Token Literal
literal = satisfy isLit >>= \(TLit lit) -> pure lit
where
isLit :: Token -> Bool
isLit (TLit _) = True
isLit _ = False
|
