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
Steffen Michels's avatar
Steffen Michels committed
5
import Sapl.Transform.VarReferences
6

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

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

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

19 20 21 22 23 24 25 26 27 28 29
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)
30
addFunction name args :== \s -> Ok (name, {s & ps_functions = 'DM'.put (unpackVar name) args s.ps_functions})
31
addCAF name :== \s -> Ok (name, {s & ps_CAFs = 'DM'.put (unpackVar name) () s.ps_CAFs})
32
defaultState = {ps_level = 0, ps_constructors = 'DM'.newMap, ps_functions = 'DM'.newMap, ps_CAFs = 'DM'.newMap, ps_genFuns = []}
33

34 35
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)
36
addGenFun fun :== \s -> Ok (fun, {s & ps_genFuns = [fun:s.ps_genFuns]})
37 38 39

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

44 45 46
// Add Tuple constructor if necessary
addTupleCons name | startsWith "_Tuple" name && size name > 6 =
		checkConstructor name
47
	>>= \b = if b (returnS ()) (addConstructor (NormalVar name 0) newdef >>| addGenFun newadt >>| returnS ())
48 49 50 51 52 53 54 55 56 57 58 59 60 61
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
62 63
		= TypedVar (StrictVar "_" 0) NoType
		= TypedVar (NormalVar "_" 0) NoType	
64

65
addTupleCons _ = returnS ()
66

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

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

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

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

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
81
expr [TIdentifier name:ts] = 
82 83
				getLevel
			>>= \level = returnS (NormalVar name level)
84
			>>= \t = addTupleCons name
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
85
			>>= \_ = args_expr ts
86
			>>= \(as, ts) = case as of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
87 88 89 90 91 92
								[] = 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
93 94
			>>= \(expr, ts) = type ts			
			>>= \(ty, ts) = read_int ts			
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
95 96 97
			>>= mandatory "Missing select index"
			>>= \(idx, ts) = args_expr ts
			>>= \(as, ts) = case as of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
								[] = 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
122 123 124 125 126 127 128 129

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")
130

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
131 132 133 134 135 136 137 138 139 140 141
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"
142 143 144

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

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
165 166 167 168 169 170 171
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] =
172 173 174 175 176
				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
177
			>>= \ts = body False ts
178 179
			>>= \(t, ts) = returnS (SLet t ds, ts)
			>>= decLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
180 181 182 183 184 185 186

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))
187
	
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
188
body simple [TOpenBracket:ts] = skip ts	// ABC code: skip it	
189 190 191 192 193
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
194
body simple ts = ((if simple sexpr expr) ts) >>= mandatory "Missing expression"
195

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

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

206 207
arg_pattern [TOpenParenthesis:TLit lit:ts] =
			case hd ts of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
208
				TCaseAssignmentOp = body False (tl ts)
209 210 211
							  = 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
212
							  = returnE (ts, "Missing close parenthesis3")
213

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

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

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

args_annotated ts = args_ ts []
where
237 238 239 240
	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]
241 242 243 244
	args_ ts as = returnS (reverse as, ts)

args_record ts = args_1 ts []
where
245 246 247 248
	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]	
249
	args_1 ts as = returnE (ts, "Missing argument")
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
250
	args_2 [TComma:ts] as = args_1 ts as
251 252 253 254 255 256
	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
257
		>>= \level = args_annotated ts 
258
		>>= \(ss,ts) = args_2 ts [SaplConstructor (NormalVar name level) i ss:cs] i
259 260 261 262 263 264 265 266 267 268
		
	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
269
						TCloseBracket = addConstructor (NormalVar name level) {index = 0, nr_cons = 1, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
270 271 272 273 274 275
									  = returnE (ts, "Missing close parenthesis3")

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

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

282 283 284 285 286 287 288 289 290
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 =
291
				getLevel
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
292
			>>= \level = body False ts
293 294 295
			>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)

typed_fun name type ts =
296 297 298 299 300 301
				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
302
			>>= \(func, ts) = body False ts 
303
			>>= \(t, ts) = if func 
304 305
							(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))
306 307 308 309

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

310 311 312
program ts fs = skip_newlines ts >>= \ts
	| isEmpty ts -> returnS (fs, ts)
	| otherwise  -> func ts >>= \(f, ts) -> program ts [f:fs]
313 314 315 316 317
		
parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse pts 
	# ts = map (\(PosToken _ _ t) = t) pts
	= case (program ts []) defaultState of
Steffen Michels's avatar
Steffen Michels committed
318
				Ok ((fts, _),ps) = Ok (fixReferences (ps.ps_genFuns ++ fts),ps)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
319
				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
320 321 322 323 324 325 326 327 328
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
329
	= case (body False ts) defaultState of
330
				Ok ((fts, _),ps) = Ok (fts,ps)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
331
				Error (ts, msg)  = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
332 333 334 335 336 337 338 339 340
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 &
341 342
	   ps_constructors = mergeMaps pst2.ps_constructors pst1.ps_constructors,
	   ps_functions    = mergeMaps pst2.ps_functions    pst1.ps_functions,
343 344
	   ps_CAFs         = mergeMaps pst2.ps_CAFs         pst1.ps_CAFs,
	   ps_genFuns	   = []}
345
where
346
	mergeMaps m1 m2 = 'DM'.putList ('DM'.toList m2) m1
347 348

mergeParserStates pst1 Nothing = pst1