SaplParser.icl 13.1 KB
Newer Older
1
implementation module Sapl.SaplParser
2

3
import StdEnv, Data.Error
4
import Sapl.SaplTokenizer, Sapl.SaplStruct, Sapl.FastString
5

6 7 8
from Data.Map import :: Map
import qualified Data.Map as DM

9 10 11 12 13 14
(>>=) infixl 1
(>>=) f g = \st0 ->
		case f st0 of
			Ok (r, st1) = g r st1
			Error str		 = Error str

15 16 17
(>>|) infixl 1
(>>|) f g = f >>= \_ -> g

18 19 20 21 22 23 24 25 26 27 28
returnS r :== \s -> Ok (r,s)
returnE e :== \s -> Error e

mandatory errmsg (Just t, ts)
		= returnS (t, ts)
mandatory errmsg (Nothing, ts)
		= returnE (ts, errmsg)

incLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level + 1})
decLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level - 1})
getLevel :== \s -> Ok (s.ps_level, s)
29
addFunction name args :== \s -> Ok (name, {s & ps_functions = 'DM'.put (unpackVar name) args s.ps_functions})
30
addCAF name :== \s -> Ok (name, {s & ps_CAFs = 'DM'.put (unpackVar name) () s.ps_CAFs})
31
defaultState = {ps_level = 0, ps_constructors = 'DM'.newMap, ps_functions = 'DM'.newMap, ps_CAFs = 'DM'.newMap, ps_genFuns = []}
32

33 34
addConstructor name def :== \s -> Ok (name, {s & ps_constructors = 'DM'.put (unpackVar name) def s.ps_constructors})
checkConstructor name :== \s -> Ok (isJust ('DM'.get name s.ps_constructors), s)
35
addGenFun fun :== \s -> Ok (fun, {s & ps_genFuns = [fun:s.ps_genFuns]})
36 37 38

addConstructors conses = \s -> Ok (conses, {s & ps_constructors = foldl adddef s.ps_constructors conses})
where
39
	nr_cons = length conses
40
	adddef m (SaplConstructor name idx as) 
41
		= 'DM'.put (unpackVar name) {index = idx, nr_cons = nr_cons, nr_args = length as, args = as} m
42

43 44 45
// Add Tuple constructor if necessary
addTupleCons name | startsWith "_Tuple" name && size name > 6 =
		checkConstructor name
46
	>>= \b = if b (returnS ()) (addConstructor (NormalVar name 0) newdef >>| addGenFun newadt >>| returnS ())
47 48 49 50 51 52 53 54 55 56 57 58 59 60
where
	(newadt, newdef) = gendefs name

	gendefs name
		# idxpart = name % (6, size name)
		# (l,r) = case charIndex idxpart 1 '!' of
			(True, idx) = (toInt (idxpart % (0,idx-1)), toInt (idxpart % (idx+1,size idxpart)))
			(False, _)  = (toInt idxpart, 0)
		= (genadt l r, genrec l r)

	genrec nrargs s = {index = 0, nr_cons = 1, nr_args = nrargs, args = [genarg i s \\ i <- [1..nrargs]]}
	genadt nrargs s = FTADT (NormalVar name 0) [SaplConstructor (NormalVar name 0) 0 [genarg i s \\ i <- [1..nrargs]]]
	
	genarg i s | s bitand (1 << (i-1)) > 0
61 62
		= TypedVar (StrictVar "_" 0) NoType
		= TypedVar (NormalVar "_" 0) NoType	
63

64
addTupleCons _ = returnS ()
65

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
66 67 68
read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
read_int ts = returnS (Nothing, ts)

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
69 70 71
type [TTypeDef, TIdentifier type:ts] = returnS (Type type, ts)
type ts = returnS (NoType, ts) 

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
72 73
expr [TOpenParenthesis:ts] = 
				mexpr ts
74 75
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (Just t, tl ts)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
76
										  = returnE (ts, "Missing close parenthesisx")
77

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
78
expr [TLit lit:ts] = returnS (Just (SLit lit), ts)
79

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
80
expr [TIdentifier name:ts] = 
81 82
				getLevel
			>>= \level = returnS (NormalVar name level)
83
			>>= \t = addTupleCons name
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
84
			>>= \_ = args_expr ts
85
			>>= \(as, ts) = case as of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
86 87 88 89 90 91
								[] = returnS (Just (SVar t), ts)
								   = returnS (Just (SApplication (SVar t) as), ts)

expr [TSelectKeyword:ts] = 
				sexpr ts 
			>>= mandatory "Missing select expression"
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
92 93
			>>= \(expr, ts) = type ts			
			>>= \(ty, ts) = read_int ts			
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
94 95 96
			>>= mandatory "Missing select index"
			>>= \(idx, ts) = args_expr ts
			>>= \(as, ts) = case as of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
								[] = returnS (Just (SSelect expr ty idx), ts)
								   = returnS (Just (SApplication (SSelect expr ty idx) as), ts)

expr [TUpdateKeyword:ts] = 
				sexpr ts 
			>>= mandatory "Missing update expression"
			>>= \(expr, ts) = type ts
			>>= \(ty, ts) = upd_list ts
			>>= \(upds, ts) = returnS (Just (SUpdate expr ty upds), ts)
where
	upd_list [TOpenSquareBracket:ts] = 
				update_1 ts []
			>>=	\(us, ts) = case hd ts of
						TCloseSquareBracket = returnS (us, tl ts)
								      = returnE (ts, "Missing close square bracket")
	upd_list ts = returnE (ts, "Missing open bracket")

	update_1 [TLit (LInt idx),TColon:ts] as =
			 	expr ts
		 	>>= mandatory "Missing field update expression"
		 	>>= \(expr, ts) = update_2 ts [(idx, expr):as]
	update_1 ts as = returnE (ts, "Invalid field \"update\"")
	update_2 [TComma: ts] as = update_1 ts as
	update_2 ts as = returnS (reverse as, ts)	
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
121 122 123 124 125 126 127 128

expr ts = returnS (Nothing, ts)

sexpr [TOpenParenthesis:ts] = 
				mexpr ts
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (Just t, tl ts)
										  = returnE (ts, "Missing close parenthesisx")
129

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
130 131 132 133 134 135 136 137 138 139 140
sexpr [TLit lit:ts] = returnS (Just (SLit lit), ts)

sexpr [TIdentifier name:ts] = 
				getLevel
			>>= \level = returnS (NormalVar name level)
			>>= \t = addTupleCons name
			>>= \_ = returnS (Just (SVar t), ts)

sexpr ts = returnS (Nothing, ts)

mexpr ts = expr ts >>= mandatory "Missing expression"
141 142 143

letdefinitions ts = letdef_1 ts []
where
144 145
	letdef_1 [TIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as = 
				getLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
146
			>>= \level = body False ts 
147
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) (Type type)) t:as]
148 149
	letdef_1 [TIdentifier name, TAssignmentOp:ts] as = 
				getLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
150
			>>= \level = body False ts 
151 152 153
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) NoType) t:as]
	letdef_1 [TStrictIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as = 
				getLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
154
			>>= \level = body False ts 
155
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) (Type type)) t:as]			
156 157
	letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as = 
				getLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
158
			>>= \level = body False ts 
159
			>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) NoType) t:as]
160
	letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
161
	letdef_2 [TComma: ts] as = letdef_1 ts as
162 163
	letdef_2 ts as = returnS (reverse as, ts)

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
164 165 166 167 168 169 170
body simple [TOpenParenthesis:ts] = 
				body False ts
			>>=	\(t, ts) = case hd ts of
						TCloseParenthesis = returnS (t, tl ts)
										  = returnE (ts, "Missing close parenthesis")

body simple [TLetKeyword:ts] =
171 172 173 174 175
				incLevel ts
			>>= \ts = letdefinitions ts
			>>= \(ds, ts) = case hd ts of
					TInKeyword = returnS (tl ts)
							   = returnE (ts, "Missing \"in\" keyword")
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
176
			>>= \ts = body False ts
177 178
			>>= \(t, ts) = returnS (SLet t ds, ts)
			>>= decLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
179 180 181 182 183 184 185

body simple [TCaseKeyword:ts] = 
				body True ts		
			>>= \(expr, ts) = args_pattern ts
			>>= \(ps, ts) = if (isEmpty ps) 
							   (returnE (ts, "Missing case patterns"))
							   (returnS (SCase expr ps, ts))
186
	
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
187
body simple [TOpenBracket:ts] = skip ts	// ABC code: skip it	
188 189 190 191 192
where
	skip [TCloseBracket:ts] = returnS (SAbortBody, ts)
	skip [] = returnE ([], "Missing close bracket in ABC code definition")
	skip [t:ts] = skip ts
			
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
193
body simple ts = ((if simple sexpr expr) ts) >>= mandatory "Missing expression"
194

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
195
args_expr ts = args_ sexpr ts
László Domoszlai's avatar
László Domoszlai committed
196
args_pattern ts = args_ arg_pattern ts
197

László Domoszlai's avatar
László Domoszlai committed
198
args_ f ts = args` ts []
199
where
László Domoszlai's avatar
László Domoszlai committed
200
	args` ts as = f ts 
201
				>>= \(t, ts) = case t of
László Domoszlai's avatar
László Domoszlai committed
202
						Just r = args` ts [r:as]
203 204
							   = returnS (reverse as, ts)

205 206
arg_pattern [TOpenParenthesis:TLit lit:ts] =
			case hd ts of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
207
				TCaseAssignmentOp = body False (tl ts)
208 209 210
							  = returnE (ts, "Missing select assignment operator")
		>>=	\(t, ts) = case hd ts of
				TCloseParenthesis = returnS (Just (PLit lit, t), tl ts)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
211
							  = returnE (ts, "Missing close parenthesis3")
212

László Domoszlai's avatar
László Domoszlai committed
213 214
arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
			incLevel ts
215 216
		>>= \ts = addTupleCons cons
		>>= \_ = args ts
László Domoszlai's avatar
László Domoszlai committed
217
		>>= \(as, ts) = case hd ts of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
218
				TCaseAssignmentOp = body False (tl ts)
László Domoszlai's avatar
László Domoszlai committed
219 220
							  = returnE (ts, "Missing select assignment operator")
		>>=	\(t, ts) = case hd ts of
221
				TCloseParenthesis = returnS (Just (mbCons as, t), tl ts)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
222
							  = returnE (ts, "Missing close parenthesis4")
László Domoszlai's avatar
László Domoszlai committed
223
		>>= decLevel
224
where
225
	mbCons as = if (cons=="_") PDefault (PCons cons as)
László Domoszlai's avatar
László Domoszlai committed
226 227

arg_pattern ts = returnS (Nothing, ts)
228 229 230

args ts = args_ ts []
where
231
	args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as] 
232 233 234 235
	args_ ts as = returnS (reverse as, ts)

args_annotated ts = args_ ts []
where
236 237 238 239
	args_ [TIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_ ts [TypedVar (NormalVar name level) (Type type):as]
	args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [TypedVar (NormalVar name level) NoType:as] 
	args_ [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = args_ ts [TypedVar (StrictVar name 0) (Type type):as]
	args_ [TStrictIdentifier name:ts] as = args_ ts [TypedVar (StrictVar name 0) NoType:as]
240 241 242 243
	args_ ts as = returnS (reverse as, ts)

args_record ts = args_1 ts []
where
244 245 246 247
	args_1 [TIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (NormalVar name level) (Type type):as]
	args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (NormalVar name level) NoType:as]
	args_1 [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) (Type type):as]	
	args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) NoType:as]	
248
	args_1 ts as = returnE (ts, "Missing argument")
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
249
	args_2 [TComma:ts] as = args_1 ts as
250 251 252 253 254 255
	args_2 ts as = returnS (reverse as, ts)

args_adt ts = args_1 ts [] 0
where
	args_1 [TIdentifier name:ts] cs i = 
			getLevel 
László Domoszlai's avatar
László Domoszlai committed
256
		>>= \level = args_annotated ts 
257
		>>= \(ss,ts) = args_2 ts [SaplConstructor (NormalVar name level) i ss:cs] i
258 259 260 261 262 263 264 265 266 267
		
	args_1 ts cs _ = returnE (ts, "Missing argument")
	args_2 [TVerticalBar:ts] cs i = args_1 ts cs (i+1)
	args_2 ts cs _ = returnS (reverse cs, ts)

// record
constr [TTypeDef, TIdentifier name, TAssignmentOp, TOpenBracket: ts] =
				getLevel
			>>= \level = args_record ts
			>>= \(as, ts) = case hd ts of
268
						TCloseBracket = addConstructor (NormalVar name level) {index = 0, nr_cons = 1, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
269 270 271 272 273 274
									  = returnE (ts, "Missing close parenthesis3")

// ADT
constr [TTypeDef, TIdentifier name, TAssignmentOp: ts] =
				getLevel
			>>= \level = args_adt ts 
275 276
			>>= \(as, ts) = addConstructors as
			>>= \_ = returnS (FTADT (NormalVar name level) as, ts)
277 278 279 280

constr [TTypeDef:ts] = returnE (ts, "Invalid type definition")
constr ts = returnE (ts, "Not a type definition")

281 282 283 284 285 286 287 288 289
func [TIdentifier name, TTypeDef, TIdentifier type, TCAFAssignmentOp:ts] = typed_caf name (Type type) ts			
func [TIdentifier name, TCAFAssignmentOp:ts] = typed_caf name NoType ts
func [TIdentifier name, TTypeDef, TIdentifier type:ts] = typed_fun name (Type type) ts			
func [TIdentifier name:ts] = typed_fun name NoType ts

func ts=:[TTypeDef:_] = constr ts >>= \(f,ts) = returnS (f, ts)
func ts = returnE (ts, "Not a function or type definition")

typed_caf name type ts =
290
				getLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
291
			>>= \level = body False ts
292 293 294
			>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)

typed_fun name type ts =
295 296 297 298 299 300
				getLevel
			>>= \level = args_annotated ts 
			>>= \(as, ts) = case hd ts of
					TAssignmentOp	   = returnS (True, tl ts)
					TMacroAssignmentOp = returnS (False, tl ts)					
									   = returnE (ts, "Missing assignment operator")
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
301
			>>= \(func, ts) = body False ts 
302
			>>= \(t, ts) = if func 
303 304
							(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc (TypedVar tname type) t as, ts))
							(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro (TypedVar tname type) t as, ts))
305 306 307 308 309 310 311 312 313 314 315 316 317 318

skip_newlines [TEndOfLine:ts] = skip_newlines ts
skip_newlines ts = returnS ts

program ts fs =
			skip_newlines ts
		>>= \ts = func ts
		>>= \(f, ts) = skip_newlines ts
		>>= \ts = if (length ts == 0) (returnS ([f:fs], ts)) (program ts [f:fs])
		
parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse pts 
	# ts = map (\(PosToken _ _ t) = t) pts
	= case (program ts []) defaultState of
319
				Ok ((fts, _),ps) = Ok (ps.ps_genFuns ++ fts,ps)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
320
				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
321 322 323 324 325 326 327 328 329
where
	findpos rest_ts 
		# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
		= case hd rest_pts of
			PosToken lp cp _ = (lp, cp)
		
parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm,ParserState)		
parseExpr pts 
	# ts = map (\(PosToken _ _ t) = t) pts
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
330
	= case (body False ts) defaultState of
331
				Ok ((fts, _),ps) = Ok (fts,ps)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
332
				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
333 334 335 336 337 338 339 340 341
where
	findpos rest_ts 
		# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
		= case hd rest_pts of
			PosToken lp cp _ = (lp, cp)
		
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
mergeParserStates pst1 (Just pst2)
	= {pst1 &
342 343
	   ps_constructors = mergeMaps pst2.ps_constructors pst1.ps_constructors,
	   ps_functions    = mergeMaps pst2.ps_functions    pst1.ps_functions,
344 345
	   ps_CAFs         = mergeMaps pst2.ps_CAFs         pst1.ps_CAFs,
	   ps_genFuns	   = []}
346
where
347
	mergeMaps m1 m2 = 'DM'.putList ('DM'.toList m2) m1
348 349

mergeParserStates pst1 Nothing = pst1