parse.icl 132 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
implementation module parse
Pieter Koopman's avatar
Pieter Koopman committed
2

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
3
4
5
6
7
8
import StdEnv
import scanner, syntax, hashtable, utilities, predef

ParseOnly :== False
import RWSDebug

9
10
11
toLineAndColumn {fp_line, fp_col}
	=	{lc_line = fp_line, lc_column = fp_col}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
// +++ move to utilities?

groupBy :: (a a -> Bool) [a] -> [[a]]
groupBy eq []
    =   []
groupBy eq [h : t]
    =   [[h : this] : groupBy eq other]
    where
        (this, other)
            =   span (eq h) t

/*

Parser for Clean 2.0

Conventions:

- Parsing funtions with a name of the form try.. can fail without generating an error.
  The parser will try an other alternative.
- Parsing functions with a name of the form want.. should succeed. If these functions
  fail an error message is generated.
- Functions with names containing the character '_' are local functions.
- All functions should consume the tokens taken form the state or given as argument,
  or put these tokens back themselves.

*/

::	*ParseErrorAdmin = 
	{	pea_file	:: !*File
	,	pea_ok		:: !Bool
	}

:: *ParseState =
	{	ps_scanState		:: !ScanState
	,	ps_error			:: !*ParseErrorAdmin
	,	ps_skipping			:: !Bool
	,	ps_hash_table		:: !*HashTable
	,	ps_pre_def_symbols	:: !*PredefinedSymbols
	}
clean's avatar
clean committed
51
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
52
53
54
55
appScanState :: (ScanState -> ScanState) !ParseState -> ParseState
appScanState f pState=:{ps_scanState}
	#	ps_scanState = f ps_scanState
	=	{	pState & ps_scanState = ps_scanState }
clean's avatar
clean committed
56
57
58
59
60
61
*/
appScanState f pState:==appScanState pState
	where
	appScanState pState=:{ps_scanState}
		#	ps_scanState = f ps_scanState
		=	{	pState & ps_scanState = ps_scanState }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
62

clean's avatar
clean committed
63
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
64
65
66
67
accScanState :: (ScanState -> (.t,ScanState)) !ParseState -> (.t,ParseState)
accScanState f pState=:{ps_scanState}
	#	( x, ps_scanState) = f ps_scanState
	=	( x, {pState & ps_scanState = ps_scanState })
clean's avatar
clean committed
68
69
70
71
72
73
*/
accScanState f pState:== accScanState pState
	where
		accScanState pState=:{ps_scanState}
			#	( x, ps_scanState) = f ps_scanState
			=	( x, {pState & ps_scanState = ps_scanState })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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

makeStringTypeSymbol pState=:{ps_pre_def_symbols}
	#! string_id = ps_pre_def_symbols.[PD_StringType]
	= (MakeNewTypeSymbIdent string_id.pds_ident 0, pState)

makeListTypeSymbol arity pState=:{ps_pre_def_symbols}
	#! list_id = ps_pre_def_symbols.[PD_ListType]
	= (MakeNewTypeSymbIdent list_id.pds_ident arity, pState)

makeLazyArraySymbol arity pState=:{ps_pre_def_symbols}
	#! lazy_array_id = ps_pre_def_symbols.[PD_LazyArrayType]
	= (MakeNewTypeSymbIdent lazy_array_id.pds_ident arity, pState)

makeStrictArraySymbol arity	pState=:{ps_pre_def_symbols}
	#! strict_array_id = ps_pre_def_symbols.[PD_StrictArrayType]
	= (MakeNewTypeSymbIdent strict_array_id.pds_ident arity, pState)

makeUnboxedArraySymbol arity pState=:{ps_pre_def_symbols}
	#! unboxed_array_id = ps_pre_def_symbols.[PD_UnboxedArrayType]
	= (MakeNewTypeSymbIdent unboxed_array_id.pds_ident arity, pState)

makeTupleTypeSymbol form_arity act_arity  pState=:{ps_pre_def_symbols}
	#! tuple_id = ps_pre_def_symbols.[GetTupleTypeIndex form_arity]
	= (MakeNewTypeSymbIdent tuple_id.pds_ident act_arity, pState)

makeNilExpression pState=:{ps_pre_def_symbols}
	#! nil_id = ps_pre_def_symbols.[PD_NilSymbol]
	= (PE_List [PE_Ident nil_id.pds_ident], pState)

makeConsExpression a1 a2 pState=:{ps_pre_def_symbols}
	#! cons_id = ps_pre_def_symbols.[PD_ConsSymbol]
	= (PE_List [PE_Ident cons_id.pds_ident, a1, a2], pState)
	
class try a	 :: !Token !*ParseState -> (!Optional a, !*ParseState)
class want a :: !*ParseState -> (!a, !*ParseState)

110
111
112
113
114
115
116
stringToIdent s i p :== (ident,parse_state)
	where
		({boxed_ident=ident},parse_state) = stringToBoxedIdent s i p

//stringToIdent :: !String !IdentClass !*ParseState -> (!Ident, !*ParseState)
stringToBoxedIdent :: !String !IdentClass !*ParseState -> (!BoxedIdent, !*ParseState)
stringToBoxedIdent ident ident_class pState=:{ps_hash_table}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
117
118
119
	# (ident, ps_hash_table) = putIdentInHashTable ident ident_class ps_hash_table
	= (ident, { pState & ps_hash_table = ps_hash_table } )

120
121
122
123
124
125
126
internalIdent s p :== (ident,parse_state)
	where
		({boxed_ident=ident},parse_state) = internaBoxedlIdent s p

//internalIdent :: !String !*ParseState -> (!Ident, !*ParseState)
internaBoxedlIdent :: !String !*ParseState -> (!BoxedIdent, !*ParseState)
internaBoxedlIdent prefix pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
127
	# ({fp_line,fp_col},pState=:{ps_hash_table})	= getPosition pState
128
129
130
// MW4 was: (changed to make it compatible with conventions used in postparse)
// 	  case_string									= prefix +++ toString fp_line +++ "_" +++ toString fp_col
	  case_string									= prefix +++ ";" +++ toString fp_line +++ ";" +++ toString fp_col
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
	  (case_ident, ps_hash_table)					= putIdentInHashTable case_string IC_Expression ps_hash_table
	= (case_ident, { pState & ps_hash_table = ps_hash_table } )

erroneousIdent = { id_name = "", id_info = nilPtr }

/*
	Some general overloaded parsing routines
*/

wantSequence :: !Token !Context !*ParseState -> (!.[a],!*ParseState) | want a
wantSequence separator context pState
	# (first, pState) = want pState
	  (token, pState) = nextToken context pState
	| separator == token
		# (rest, pState) = wantSequence separator context pState
		= ([first : rest], pState)
	// otherwise // separator <> token
	= ([first], tokenBack pState)
/*
optionalSequence start_token separator context pState
	# (token, pState) = nextToken context pState
	| token == start_token
		= wantSequence separator context pState
		= ([], tokenBack pState)
*/
parseList try_fun pState :== parse_list pState // try_fun *
//parseList try_fun pState = parse_list pState
	where
	//	parse_list :: !*ParseState -> (tree, *ParseState)
		parse_list pState
			# (succ, tree, pState) = try_fun pState
			| succ
				# (trees, pState) = parse_list pState
				= ([tree : trees], pState)
			= ([], pState)

//wantSepList msg sep_token context try_fun pState = want_list msg pState
wantSepList msg sep_token context try_fun pState :== want_list msg pState // try_fun (sep_token tryfun)*
	where
		want_list msg pState
			# (succ, tree, pState) = try_fun pState
			| succ
			 	# (token, pState) = nextToken context pState
			 	| token == sep_token
					# (trees, pState) = optSepList sep_token context try_fun pState
					= ([tree : trees], pState)
				// otherwise // token <> sep_token
					= ([tree], tokenBack pState)
				# (token, pState) = nextToken GeneralContext pState
180
				= ([tree], parseError ("wantList of "+msg) (Yes token) msg pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

//optSepList sep_token context try_fun pState = want_list msg pState
optSepList sep_token context try_fun pState :== want_list pState // [ try_fun (sep_token tryfun)* ]
	where
		want_list pState
			# (succ, tree, pState) = try_fun pState
			| succ
			 	# (token, pState) = nextToken context pState
			 	| token == sep_token
					# (trees, pState) = want_list pState
					= ([tree : trees], pState)
				// otherwise // token <> sep_token
					= ([tree], tokenBack pState)
			= ([], pState)

//wantList msg try_fun pState = want_list msg pState
wantList msg try_fun pState :== want_list msg pState // try_fun +
	where
		want_list msg pState
			# (succ, tree, pState) = try_fun pState
			| succ
				# (trees, pState) = parseList try_fun pState
				= ([tree : trees], pState)
				# (token, pState) = nextToken GeneralContext pState
205
				= ([tree], parseError ("wantList of "+msg) (Yes token) msg pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
/*
instance want (a,b) | want a & want b
where
	want pState
		# (x, pState) = want pState
		  (y, pState) = want pState
		= ((x,y), pState)
*/
wantIdents :: !Context !IdentClass !ParseState -> (![Ident], !ParseState)
wantIdents context ident_class pState
	# (first_name, pState) = want pState
	  (first_ident, pState) = stringToIdent first_name ident_class pState
	  (token, pState) = nextToken context pState
	| token == CommaToken
		# (rest, pState) = wantIdents context ident_class pState
		= ([first_ident : rest], pState)
	= ([first_ident], tokenBack pState)

optionalPriority :: !Bool !Token !ParseState -> (Priority, !ParseState)
optionalPriority isinfix (PriorityToken prio) pState
	= (prio, pState)
optionalPriority isinfix token pState
	| isinfix
		= (DummyPriority, tokenBack pState)
		= (NoPrio, tokenBack pState)

/*
	Modules
*/

::	ParseContext	:== Int

cICLContext			:== 1
cGlobalContext		:== 2
cDCLContext			:== 0
cLocalContext		:== 1

SetGlobalContext iclmodule
	| iclmodule
		= cICLContext bitor cGlobalContext
		= cDCLContext bitor cGlobalContext
		
SetLocalContext context 	:== context bitand (bitnot cGlobalContext)

isLocalContext context	:== context bitand cGlobalContext == 0
isGlobalContext context	:== not (isLocalContext context)

isDclContext context	:== context bitand cICLContext == 0
isIclContext context	:== not (isDclContext context)

cWantIclFile :== True	
cWantDclFile :== False	

Martin Wierich's avatar
Martin Wierich committed
259
wantModule :: !Bool !Ident !Position !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
260
	-> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files)
Martin Wierich's avatar
Martin Wierich committed
261
wantModule iclmodule file_id=:{id_name} import_file_position hash_table error searchPaths pre_def_symbols files
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
262
263
	# file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl")
	= case openScanner file_name searchPaths files of
264
265
266
267
268
269
270
271
		(Yes scanState, files)
			# hash_table=set_hte_mark (if iclmodule 1 0) hash_table
			# (ok,mod,hash_table,file,pre_def_symbols,files) = initModule file_name scanState hash_table error pre_def_symbols files
			# hash_table=set_hte_mark 0 hash_table
			->(ok,mod,hash_table,file,pre_def_symbols,files)
		(No, files)
			-> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in
			  (False, mod, hash_table, error <<< import_file_position <<< ":could not open " <<< file_name <<< "\n", pre_def_symbols, files)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
272
where
273
274
275
	initModule :: String ScanState !*HashTable !*File !*PredefinedSymbols *Files
				-> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files)
	initModule file_name scanState hash_table error pre_def_symbols files
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
		# (succ, mod_type, mod_name, scanState) = try_module_header iclmodule scanState
		| succ
			# pState				=	{ ps_scanState = scanState
										, ps_error = { pea_file = error, pea_ok = True }
										, ps_skipping = False
										, ps_hash_table = hash_table
										, ps_pre_def_symbols = pre_def_symbols
										}
			  pState				= verify_name mod_name id_name file_name pState
		  	  (mod_ident, pState)	= stringToIdent mod_name IC_Module pState
		  	  pState				= check_layout_rule pState
		  	  (defs, pState)		= want_definitions (SetGlobalContext iclmodule) pState
			  {ps_scanState,ps_hash_table,ps_error,ps_pre_def_symbols}
			  						= pState
			  defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics")
						[PD_Import imports \\ PD_Import imports <- defs]
						defs
			  mod					= { mod_name = mod_ident, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = defs }
			= ( ps_error.pea_ok
			  , mod, ps_hash_table
			  , ps_error.pea_file
			  , ps_pre_def_symbols
			  , closeScanner ps_scanState files
			  )
		// otherwise // ~ succ
301
302
303
304
		# ({fp_line}, scanState) = getPosition scanState
		  mod = { mod_name = file_id, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = [] }
		= (False, mod, hash_table, error <<< '[' <<< file_name <<< ',' <<< fp_line <<< "]: incorrect module header",
			pre_def_symbols, closeScanner scanState files)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336

	try_module_header :: !Bool !ScanState -> (!Bool,!ModuleKind,!String,!ScanState)
	try_module_header is_icl_mod scanState
		# (token, scanState) = nextToken GeneralContext scanState
		| is_icl_mod
			| token == ModuleToken
				# (token, scanState) = nextToken GeneralContext scanState
				= try_module_name token MK_Main scanState
			| token == ImpModuleToken 
				= try_module_token MK_Module scanState
			| token == SysModuleToken
				= try_module_token MK_System scanState
				= (False, MK_None, "", tokenBack scanState)
		| token == DefModuleToken
		  	= try_module_token MK_Module scanState
		| token == SysModuleToken
		  	= try_module_token MK_System scanState
			= (False, MK_None, "", tokenBack scanState)

	try_module_token :: !ModuleKind !ScanState -> (!Bool,!ModuleKind!,!String,!ScanState)
	try_module_token mod_type scanState
		# (token, scanState) = nextToken GeneralContext scanState
		| token == ModuleToken
			# (token, scanState) = nextToken GeneralContext scanState
 			= try_module_name token mod_type scanState
			= (False, mod_type, "", tokenBack scanState)

	try_module_name (IdentToken name) mod_type scanState
		= (True, mod_type, name, scanState) //-->> ("module",name)
	try_module_name token mod_type scanState
		= (False, mod_type, "", tokenBack scanState)
	
337
	verify_name name id_name file_name pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
338
339
		| name == id_name
	  		= pState
340
341
342
			# ({fp_line}, pState=:{ps_error={pea_file}}) = getPosition pState
 			  pea_file = pea_file <<< '[' <<< file_name <<< ',' <<< fp_line <<< "]: module name \"" <<< name 
	  						<<< "\" does not match file name\n"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
			= { pState & ps_error = { pea_file = pea_file, pea_ok = False }}

	check_layout_rule pState
		# (token, pState)	= nextToken GeneralContext pState
		  use_layout		= token <> SemicolonToken && token <> EndOfFileToken // '&& token <> EndOfFileToken' to handle end groups of empty modules
		| use_layout		= appScanState (setUseLayout use_layout) (tokenBack pState)
							= appScanState (setUseLayout use_layout) pState

	want_definitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState)
	want_definitions context pState
		= want_acc_definitions [] pState
	where
		want_acc_definitions :: ![ParsedDefinition] !ParseState -> (![ParsedDefinition], !ParseState)
		want_acc_definitions acc pState
			# (defs, pState)	= wantDefinitions context pState
			  acc				= acc ++ defs
			  pState			= wantEndModule pState
			  (token, pState)	= nextToken FunctionContext pState
			| token == EndOfFileToken
				= (acc,  pState)
				# pState		= parseError "want definitions" (Yes token) "End of file" pState
				  pState		= wantEndOfDefinition "definitions" pState
				= want_acc_definitions acc pState
/*
	[Definition] on local and global level
*/

wantDefinitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState)
wantDefinitions context pState
	= parseList (tryDefinition context) pState

DummyPriority	:== Prio LeftAssoc 9

cHasPriority 	:== True
cHasNoPriority	:== False

tryDefinition :: !ParseContext !ParseState -> (!Bool, ParsedDefinition, !ParseState)
tryDefinition context pState
	# (token, pState)			= nextToken GeneralContext pState
	  (fname, linenr, pState)	= getFileAndLineNr pState
	= try_definition context token (LinePos fname linenr) pState
where
	try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState)
	try_definition context DoubleColonToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
387
388
389
390
		| ~(isGlobalContext context)
			= (False,abort "no def(3)",parseError "definition" No "type definitions are only at the global level" pState)
			# (def, pState) = wantTypeDef context pos pState
			= (True, def, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
391
	try_definition _ ImportToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
392
393
		| ~(isGlobalContext context)
			= (False,abort "no def(3)",parseError "definition" No "imports are only at the global level" pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
394
395
396
397
398
399
400
401
		# (token, pState) = nextToken FunctionContext pState
		| token == CodeToken && isIclContext context
		# (importedObjects, pState) = wantCodeImports pState
		= (True, PD_ImportedObjects importedObjects, pState)
		# pState = tokenBack pState
		# (imports, pState) = wantImports pState
   		= (True, PD_Import imports, pState)
	try_definition _ FromToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
402
403
404
405
		| ~(isGlobalContext context)
			= (False,abort "no def(3)",parseError "definition" No "imports are only at the global level" pState)
			# (imp, pState) = wantFromImports pState
	   		= (True, PD_Import [imp], pState) -->> imp
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
406
407
408
409
410
411
/*	try_definition _ ExportToken pos pState
		# (exports, pState) = wantExportDef pState
   		= (True, PD_Export exports, pState)
	try_definition _ ExportAllToken pos pState
   		= (True, PD_Export ExportAll, pState)
*/	try_definition context ClassToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
412
413
414
415
		| ~(isGlobalContext context)
			= (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState)
	   		# (classdef, pState) = wantClassDefinition context pos pState
	   		= (True, classdef, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
416
	try_definition context InstanceToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
417
418
419
420
		| ~(isGlobalContext context)
			= (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState)
	   		# (instdef, pState) = wantInstanceDeclaration context pos pState
	   		= (True, instdef, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
	try_definition context token pos pState
		| isLhsStartToken token
			# (lhs, pState) = want_lhs_of_def token pState
		      (token, pState) = nextToken FunctionContext pState
		      (def, pState) = want_rhs_of_def context lhs token (determine_position lhs pos) pState //-->> token
			= (True, def, pState) -->>  def
			with
				determine_position (Yes (name, _), _)	(LinePos f l) = FunPos f l name.id_name
		 		determine_position lhs           		pos           = pos
		= (False, abort "no def(1)", tokenBack pState)

	want_lhs_of_def :: !Token !ParseState -> (!(Optional (Ident, Bool), ![ParsedExpr]), !ParseState)
	want_lhs_of_def token pState
		# (succ, fname, is_infix, pState) = try_function_symbol token pState
		| succ
			# (args, pState) = parseList trySimpleLhsExpression pState
			= ((Yes (fname, is_infix), args), pState)
			# (_, exp, pState) = trySimpleLhsExpression pState
			= ((No, [exp]), pState)
	where
		try_function_symbol :: !Token !ParseState -> (!Bool, Ident, !Bool, !ParseState) // (Success, Ident, Infix, ParseState)
		try_function_symbol (IdentToken name) pState
			# (id, pState) = stringToIdent name IC_Expression pState
			= (True, id, False, pState)
		try_function_symbol OpenToken pState
			# (token, pState) = nextToken FunctionContext pState
			= case token of
				(IdentToken name)
					# (token, pState) = nextToken FunctionContext pState
					| CloseToken == token
						# (id, pState) = stringToIdent name IC_Expression pState
						-> (True, id, True, pState)
						-> (False, abort "no name", False, tokenBack (tokenBack (tokenBack pState)))
				_
					-> (False,  abort "no name", False, tokenBack (tokenBack pState))
		try_function_symbol token pState
			= (False, abort "name", False, tokenBack pState)

	want_rhs_of_def :: !ParseContext !(Optional (Ident, Bool), [ParsedExpr]) !Token !Position !ParseState -> (ParsedDefinition, !ParseState)
	want_rhs_of_def context (opt_name, args) DoubleColonToken pos pState
		# (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState
		  (tspec, pState) = want pState		//	SymbolType
		| isDclContext context
			# (specials, pState) = optionalSpecials pState
			= (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition (1)" pState)
			= (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) SP_None, wantEndOfDefinition "type definition (2)" pState)
	want_rhs_of_def context (opt_name, args) (PriorityToken prio) pos pState
		# (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState
		  (token, pState) = nextToken TypeContext pState
		| token == DoubleColonToken
		  	# (tspec, pState) = want pState
			| isDclContext context
				# (specials, pState) = optionalSpecials pState
				= (PD_TypeSpec pos name prio (Yes tspec) specials, wantEndOfDefinition "type definition (3)" pState)
				= (PD_TypeSpec pos name prio (Yes tspec) SP_None, wantEndOfDefinition "type definition (4)" pState)
			= (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type defenition (5)" (tokenBack pState))
	want_rhs_of_def context (No, args) token pos pState
Pieter Koopman's avatar
Pieter Koopman committed
478
		# pState			= want_node_def_token pState token
Pieter Koopman's avatar
Pieter Koopman committed
479
480
		//  localsExpected	= isNotEmpty args || isGlobalContext context
		  (rhs, pState)		= wantRhs isEqualToken False (tokenBack pState) // PK localsExpected -> False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
481
482
483
484
485
486
487
488
489
490
491
		| isGlobalContext context
 			= (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState)
 			= (PD_NodeDef pos (combine_args args) rhs, pState)
	where		
		want_node_def_token s EqualToken		= s
		want_node_def_token s DefinesColonToken = replaceToken EqualToken s
		want_node_def_token s token				= parseError "RHS" (Yes token) "defines token (= or =:)" s

		combine_args [arg]	= arg
		combine_args args	= PE_List args
	want_rhs_of_def context (Yes (name, False), []) token pos pState
Pieter Koopman's avatar
Pieter Koopman committed
492
		| isIclContext context && isLocalContext context && (token == DefinesColonToken || token == EqualToken) && isLowerCaseName name.id_name
Pieter Koopman's avatar
Pieter Koopman committed
493
			# (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
494
495
496
497
498
499
500
501
502
503
504
			= (PD_NodeDef pos (PE_Ident name) rhs, pState)
	want_rhs_of_def context (Yes (name, is_infix), args) token pos pState
		# (fun_kind, code_allowed, pState)  = token_to_fun_kind pState token
		  (token, pState) = nextToken FunctionContext pState
		| isIclContext context && token == CodeToken
			# (rhs, pState) = wantCodeRhs pState
			| code_allowed
  				= (PD_Function pos name is_infix args rhs fun_kind, pState)
  			// otherwise // ~ code_allowed
  				= (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" pState)
		# pState = tokenBack (tokenBack pState)
Pieter Koopman's avatar
Pieter Koopman committed
505
506
		  localsExpected = isNotEmpty args || isGlobalContext context
		  (rhs, pState) = wantRhs isRhsStartToken localsExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
507
		= case fun_kind of
508
			FK_Function _  | isDclContext context
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
509
				->	(PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState)
Pieter Koopman's avatar
Pieter Koopman committed
510
			FK_Caf | isNotEmpty args
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
511
512
513
				->	(PD_Function pos name is_infix []   rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
  			_	->	(PD_Function pos name is_infix args rhs fun_kind, pState)
	where
514
515
516
		token_to_fun_kind s BarToken			= (FK_Function cNameNotLocationDependent, False,  s)
		token_to_fun_kind s (SeqLetToken _)		= (FK_Function cNameNotLocationDependent, False,  s)
		token_to_fun_kind s EqualToken			= (FK_Function cNameNotLocationDependent, True,  s)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
517
		token_to_fun_kind s ColonDefinesToken	= (FK_Macro, False, s)
518
		token_to_fun_kind s DoubleArrowToken	= (FK_Function cNameNotLocationDependent, True, s)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
		token_to_fun_kind s DefinesColonToken	= (FK_Caf, False, s)
		token_to_fun_kind s token 				= (FK_Unknown, False, parseError "RHS" (Yes token) "defines token (=, => or =:) or argument" s)

	check_name_and_fixity No hasprio pState
		= (erroneousIdent, False, parseError "Definition" No "identifier" pState)
	check_name_and_fixity (Yes (name,is_infix)) hasprio pState
		| not is_infix	&& hasprio	//	XXXXXXX
			= (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState)
			= (name, is_infix, pState)

isEqualToken :: !Token -> Bool
isEqualToken EqualToken			= True
isEqualToken _					= False

isRhsStartToken :: !Token -> Bool
isRhsStartToken EqualToken			= True
isRhsStartToken ColonDefinesToken	= True
isRhsStartToken DefinesColonToken	= True
isRhsStartToken _					= False

optionalSpecials :: !ParseState -> (!Specials, !ParseState)
optionalSpecials pState
	# (token, pState) = nextToken TypeContext pState
	| token == SpecialToken
		# (specials, pState) = wantList "<special statement>" try_substitutions pState
		= (SP_ParsedSubstitutions specials, wantEndGroup "specials" pState)
	// otherwise // token <> SpecialToken
		= (SP_None, tokenBack pState)
where
	try_substitutions pState
		# (succ, type_var, pState) = tryTypeVar pState
		| succ
			# (subst, pState) = want_rest_substitutions type_var pState
			= (True, subst, wantEndOfDefinition "substitution" pState)
			= (False, [], pState)
	
	want_rest_substitutions type_var pState
		# pState = wantToken GeneralContext "specials" EqualToken pState
		  (type, pState) = want pState
		  (token, pState) = nextToken GeneralContext pState
		| token == CommaToken
			# (next_type_var, pState) = want pState
			  (substs, pState) = want_rest_substitutions next_type_var pState
			= ([{ bind_src = type, bind_dst = type_var } : substs], pState)
			= ([{ bind_src = type, bind_dst = type_var }], tokenBack pState)
/*
	For parsing right-hand sides of functions only
*/

wantCodeRhs :: !ParseState -> (Rhs, !ParseState)
wantCodeRhs pState
	# (expr, pState)	= want_code_expr pState
571
	  (file_name, line_nr, pState)	= getFileAndLineNr pState // MW++
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
572
573
574
575
	= (	{ rhs_alts		= UnGuardedExpr
							{ ewl_nodes		= []
							, ewl_locals	= LocalParsedDefs []
							, ewl_expr		= expr
576
							, ewl_position	= LinePos file_name line_nr // MW++
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
							}
		, rhs_locals	= LocalParsedDefs []
		}
	  , wantEndOfDefinition "code rhs" pState
	  )
where
	want_code_expr :: !ParseState -> (!ParsedExpr, !ParseState)
	want_code_expr pState
		# (token, pState) = nextToken CodeContext pState
		= case token of
			OpenToken
				#	(input, pState)	= want_bindings [] True pState
					pState			= wantToken CodeContext "input bindings of code block" CloseToken pState
					pState			= wantToken CodeContext "output bindings of code block" OpenToken pState
					(out, pState)	= want_bindings [] False pState
					pState			= wantToken CodeContext "output bindings of code block" CloseToken pState
					(token, pState)	= nextToken CodeContext pState
				->	case token of
						CodeBlockToken the_code
							-> (PE_Any_Code input out the_code, pState)
						_	-> (PE_Any_Code input out []  , parseError "code rhs (any code)" (Yes token) "code block" pState)
			InlineToken
			 	#	(token, pState) = nextToken CodeContext pState
			 	->	case token of
			 			CodeBlockToken the_code
			 				-> (PE_ABC_Code the_code True, pState)
			 			token
			 				-> (PE_ABC_Code [] True,  parseError "inline code" (Yes token) "code block" pState)
			CodeBlockToken the_code
				-> (PE_ABC_Code the_code False, pState)
			token
				-> (PE_Empty, parseError "code rhs" (Yes token) "<code rhs>" pState)

	want_bindings :: !(CodeBinding Ident) !Bool !ParseState -> (!CodeBinding Ident, !ParseState)
	want_bindings acc mayBeEmpty pState
		# (token, pState)	= nextToken CodeContext pState
		= case token of
			IdentToken name
				#	(token, pState)	= nextToken CodeContext pState
				|	token == EqualToken || token == DefinesColonToken
					#	(token, pState)	= nextToken CodeContext pState
					->	case token of
							IdentToken value
								#	(ident, pState)	= stringToIdent name IC_Expression pState
									acc				= [{ bind_dst = ident, bind_src = value }: acc]
									(token, pState)	= nextToken CodeContext pState
								|	token == CommaToken
									->	want_bindings acc mayBeEmpty pState
								//	token <> CommaToken
									->	(reverse acc, tokenBack pState)
							token
								-> (acc, parseError "bindings in code block" (Yes token) "value" pState)
				//	token <> EqualToken && token <> DefinesColonToken
					->	(acc, parseError "bindings in code block" (Yes token) "= or =:" pState)
			CloseToken
				| mayBeEmpty
					-> (acc, tokenBack pState) // to handle empty input bindings
					-> (acc, parseError "code bindings" (Yes token) "output bindings" pState)
			token
				-> (acc, parseError "bindings in code block" (Yes token) "identifier" pState)
/*
	For parsing right-hand sides of functions and case expressions
*/


/* Syntax:
	FunctionAltDefRhs	=	FunctionBody						// Rhs
							[ LocalFunctionAltDefs ]
	FunctionBody		=	exprWithLocals						// OptGuardedAlts	: GuardedAlts
						|	GuardedAlts 						//					: UnGuardedExpr
	GuardedAlts			=	{ [ LetBefore ] '|' [ StrictLet ] Guard FunctionBody }+ [ ExprWithLocals ]
	ExprWithLocals		=	[ LetBefore ] sep RootExpression endOfDefinition [ LocalFunctionDefs ]
*/

Pieter Koopman's avatar
Pieter Koopman committed
651
652
wantRhs :: !(!Token -> Bool) !Bool !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs
wantRhs separator localsExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
653
	# (alts, pState)	= want_LetsFunctionBody separator pState
Pieter Koopman's avatar
Pieter Koopman committed
654
	  (locals, pState)	= optionalLocals WhereToken localsExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
655
656
657
658
659
660
661
662
663
664
665
	= ({ rhs_alts = alts, rhs_locals = locals}, pState)
where
	want_LetsFunctionBody :: !(!Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) 
	want_LetsFunctionBody sep pState
		# (token, pState)			= nextToken FunctionContext pState
		  (nodeDefs, token, pState)	= want_LetBefores token pState
		= want_FunctionBody token nodeDefs [] sep pState

	want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
	want_FunctionBody BarToken nodeDefs alts sep pState
//		#	(lets, pState)				= want_StrictLet pState // removed from 2.0
666
		#	(file_name, line_nr, pState)= getFileAndLineNr pState // MW4++
667
			(token, pState)				= nextToken FunctionContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
668
669
670
671
672
673
		|	token == OtherwiseToken
			#	(token, pState)				= nextToken FunctionContext pState
				(nodeDefs2, token, pState)	= want_LetBefores token pState
			=	case token of
				BarToken
					#	pState = parseError "RHS: default alternative" No "root expression instead of guarded expression" pState
Pieter Koopman's avatar
Pieter Koopman committed
674
675
					->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
				_	->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
676
677
		|	token == LetToken True
			#	pState	= parseError "RHS" No "No 'let!' in this version of Clean" pState
Pieter Koopman's avatar
Pieter Koopman committed
678
			=	root_expression True token nodeDefs (reverse alts) sep pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
679
680
681
682
683
684
685
686
		#	(guard, pState)				= wantRhsExpressionT token pState
			(token, pState)				= nextToken FunctionContext pState
			(nodeDefs2, token, pState)	= want_LetBefores token pState
		|	token == BarToken // nested guard
			#	(position, pState)			= getPosition pState
				offside						= position.fp_col
				(expr, pState)				= want_FunctionBody token nodeDefs2 [] sep pState
				pState						= wantEndNestedGuard (default_found expr) offside pState
687
688
// MW4 was:				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
689
												alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
690
691
692
693
				(token, pState)				= nextToken FunctionContext pState
				(nodeDefs, token, pState)	= want_LetBefores token pState
			=	want_FunctionBody token nodeDefs [alt:alts] sep pState
		// otherwise
Pieter Koopman's avatar
Pieter Koopman committed
694
			#	(expr, pState)				= root_expression True token nodeDefs2 [] sep pState
695
696
// MW4 was:				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
697
												alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
698
699
700
				(token, pState)				= nextToken FunctionContext pState
				(nodeDefs, token, pState)	= want_LetBefores token pState
			=	want_FunctionBody token nodeDefs [alt:alts] sep pState
701
702
703
704
705
// MW4..
	  where
	  	guard_ident line_nr
			= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
// ..MW4
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
706
	want_FunctionBody token nodeDefs alts sep pState
Pieter Koopman's avatar
Pieter Koopman committed
707
		=	root_expression localsExpected token nodeDefs (reverse alts) sep pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
708
	
Pieter Koopman's avatar
Pieter Koopman committed
709
710
	root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
	root_expression withExpected token nodeDefs [] sep pState
711
712
		# (file_name, line_nr, pState)	= getFileAndLineNr pState // MW++
		  (expr,pState) = want_OptExprWithLocals withExpected token nodeDefs sep pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
713
714
		=	case expr of
				Yes expr -> ( UnGuardedExpr expr, pState)
715
716
				No		 -> ( UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs [],
												ewl_position = LinePos file_name line_nr}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
717
718
							, parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState
							)
Pieter Koopman's avatar
Pieter Koopman committed
719
720
	root_expression withExpected token nodeDefs alts sep pState
		# (expr,pState) = want_OptExprWithLocals withExpected token nodeDefs sep pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
721
722
723
724
725
		= (GuardedAlts alts expr, pState)
	
	default_found (GuardedAlts _ No)	= False
	default_found _						= True

Pieter Koopman's avatar
Pieter Koopman committed
726
727
728
729
	want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !(Token -> Bool) !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState)
	want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs sep pState
		= want_OptExprWithLocals True EqualToken nodeDefs sep (replaceToken EqualToken pState)
	want_OptExprWithLocals withExpected token nodeDefs sep pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
730
		| sep token
731
732
		# (file_name, line_nr, pState)	= getFileAndLineNr pState // MW++
		  (expr, pState)	= wantExpression cIsNotAPattern pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
		  pState			= wantEndRootExpression pState
Pieter Koopman's avatar
Pieter Koopman committed
734
		  (locals,pState)	= optionalLocals WithToken withExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
735
736
737
		= ( Yes	{ ewl_nodes		= nodeDefs
				, ewl_expr		= expr
				, ewl_locals	= locals
738
				, ewl_position	= LinePos file_name line_nr // MW++
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
				}
		  , pState
		  )
		= (No, tokenBack pState)
	
/*	want_StrictLet :: !ParseState -> ([NodeDefWithLocals] , !ParseState) // Removed from the language !?
	want_StrictLet pState
		# (token, pState)	= nextToken FunctionContext pState
		| token == LetToken True
			# (let_defs, pState)	= wantList "<sequential node defs>" (try_LetDef True) pState
			  pState				= wantToken FunctionContext "strict let" InToken pState
			= (let_defs, pState)
		= ([], tokenBack pState)
*/ 
	want_LetBefores :: !Token !ParseState -> (![NodeDefWithLocals], !Token, !ParseState)
	want_LetBefores (SeqLetToken strict) pState
		# (let_defs, pState)				= wantList "<sequential node defs>" (try_LetDef strict) pState
		  (token, pState)					= nextToken FunctionContext pState
		  (token, pState)					= opt_End_Group token pState
		  (more_let_defs, token, pState)	= want_LetBefores token pState
		= (let_defs ++ more_let_defs, token, pState)
		where
			opt_End_Group token pState
			 #	(ss_useLayout, pState) = accScanState UseLayout pState
			 |	ss_useLayout
			 	| token == EndGroupToken
			 		= nextToken FunctionContext pState
			 	// otherwise // token <> EndGroupToken
			 		= (ErrorToken "End group missing in let befores", parseError "RHS: Let befores" (Yes token) "Generated End Group (due to layout)" pState)
			 |	otherwise // not ss_useLayout
			 =	(token, pState)
	want_LetBefores token pState
		= ([], token, pState)
	
	try_LetDef :: !Bool !ParseState -> (!Bool, NodeDefWithLocals, !ParseState)
	try_LetDef strict pState
		# (succ, lhs_exp, pState)	= trySimpleLhsExpression pState
		| succ
			# pState			= wantToken FunctionContext "let definition" EqualToken pState
778
779
			  (file_name, line_nr, pState)
			  					= getFileAndLineNr pState // MW++
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
780
781
			  (rhs_exp, pState) = wantExpression cIsNotAPattern pState
			  pState			= wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp)
Pieter Koopman's avatar
Pieter Koopman committed
782
	  	  	  (locals , pState) = optionalLocals WithToken localsExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
783
784
785
786
787
788
			=	( True
				, {	ndwl_strict	= strict
				  ,	ndwl_def	= { bind_dst = lhs_exp
				  				  , bind_src = rhs_exp
				  				  }
				  , ndwl_locals	= locals
789
790
				  , ndwl_position
				  				= LinePos file_name line_nr // MW++
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
791
792
793
794
795
796
				  }
				, pState
				)
		// otherwise // ~ succ
			= (False, abort "no definition", pState)

Pieter Koopman's avatar
Pieter Koopman committed
797
798
optionalLocals :: !Token !Bool !ParseState -> (!LocalDefs, !ParseState)
optionalLocals dem_token localsExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
799
800
801
802
    # (off_token, pState) = nextToken FunctionContext pState
	| dem_token == off_token
		= wantLocals pState
	# (ss_useLayout, pState) = accScanState UseLayout pState
Pieter Koopman's avatar
Pieter Koopman committed
803
	| off_token == CurlyOpenToken && ~ ss_useLayout && localsExpected
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
		= wantLocals (tokenBack pState)
	// otherwise
		= (LocalParsedDefs [], tokenBack pState)

wantLocals :: !ParseState -> (LocalDefs, !ParseState)
wantLocals pState
	# pState			= wantBeginGroup "local definitions" pState
	  (defs, pState)	= wantDefinitions cLocalContext pState
	= (LocalParsedDefs defs, wantEndLocals pState)

/*
	imports and exports
*/

wantImports :: !ParseState -> (![ParsedImport], !ParseState)
wantImports pState
	# (names, pState) = wantIdents FunctionContext IC_Module pState
	  (file_name, line_nr, pState)	= getFileAndLineNr pState
	  pState = wantEndOfDefinition "imports" pState
Martin Wierich's avatar
Martin Wierich committed
823
	= (map (\name -> { import_module = name, import_symbols = [], import_file_position = LinePos file_name line_nr}) names, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
824
825
826
827
828
829
830
831
832

wantFromImports :: !ParseState -> (!ParsedImport, !ParseState)
wantFromImports pState
	# (mod_name, pState) = want pState
	  (mod_ident, pState) = stringToIdent mod_name IC_Module pState
	  pState = wantToken GeneralContext "from imports" ImportToken pState
	  (file_name, line_nr, pState)	= getFileAndLineNr pState
	  (import_symbols, pState) = wantSequence CommaToken GeneralContext pState
	  pState = wantEndOfDefinition "from imports" pState
Martin Wierich's avatar
Martin Wierich committed
833
	= ( { import_module = mod_ident, import_symbols = import_symbols, import_file_position = LinePos file_name line_nr }, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858

instance want ImportedObject where
	want pState
		# (token, pState) = nextToken GeneralContext pState
		| token == IdentToken "library"
	  		# (token, pState) = nextToken GeneralContext pState
			= want_import_string token cIsImportedLibrary pState
			= want_import_string token cIsImportedObject pState
		where		
			want_import_string :: Token Bool ParseState -> (ImportedObject, ParseState)
			want_import_string (StringToken string) isLibrary pState
				=	({io_is_library = isLibrary, io_name = string}, pState)
			want_import_string token isLibrary pState
				=	({io_is_library = isLibrary, io_name = ""}, parseError "import code declaration" (Yes token) "imported item" pState)

wantCodeImports :: !ParseState -> (![ImportedObject], !ParseState)
wantCodeImports pState
	# pState = wantToken GeneralContext "import code declaration" FromToken pState
	  (importObjects, pState) = wantSequence CommaToken GeneralContext pState
	= (importObjects, wantEndOfDefinition "import code declaration" pState)

instance want ImportDeclaration
where
	want pState
		# (token, pState) = nextToken GeneralContext pState
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
// MW5..
		= (switch_import_syntax want_1_3_import_declaration want_2_0_import_declaration) token pState

want_1_3_import_declaration token pState
	= case token of
			IdentToken name
				#	(fun_id, pState)		= stringToIdent name IC_Expression pState
					(type_id, pState)		= stringToIdent name IC_Type pState
					(class_id, pState)		= stringToIdent name IC_Class pState
				->	(ID_OldSyntax [fun_id, type_id, class_id], pState)
			token
				#	(fun_id, pState)		= stringToIdent "dummy" IC_Expression pState
				->	( ID_Function { ii_ident = fun_id, ii_extended = False }
					, parseError "from import" (Yes token) "imported item" pState
					)

want_2_0_import_declaration token pState
// ..MW5
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
		= case token of
			DoubleColonToken
				# (name, pState)				= wantUpperCaseName "import type" pState
				  (type_id, pState)				= stringToIdent name IC_Type pState
				  (ii_extended, token, pState)	= optional_extension_with_next_token pState
				| token == OpenToken
				  	#	(conses, pState)			= want_names (wantUpperCaseName "import type (..)") IC_Expression CloseToken pState
				  	->	(ID_Type { ii_ident = type_id, ii_extended = ii_extended } (Yes conses), pState)
				| token == CurlyOpenToken
				  	#	(fields, pState) = want_names (wantLowerCaseName "import record fields") (IC_Field type_id) CurlyCloseToken pState
				  	->	(ID_Record { ii_ident = type_id, ii_extended = ii_extended } (Yes fields), pState)
				  	->	(ID_Type { ii_ident = type_id, ii_extended = ii_extended } No, tokenBack pState)
			ClassToken
				# (name, pState)				= want pState
				  (class_id, pState)			= stringToIdent name IC_Class pState
				  (ii_extended, token, pState)	= optional_extension_with_next_token pState
				| token == OpenToken
				  	#	(members, pState)			= want_names want IC_Expression CloseToken pState
				  	->	(ID_Class { ii_ident = class_id, ii_extended = ii_extended } (Yes members), pState)
				  	->	(ID_Class { ii_ident = class_id, ii_extended = ii_extended } No, pState)
			InstanceToken
				#	(class_name, pState)	= want pState
					(ii_extended, pState)	= optional_extension pState
					(types, pState)			= wantList "instance types" tryBrackType pState
					(class_id, pState)		= stringToIdent class_name IC_Class pState
					(inst_id, pState)		= stringToIdent class_name (IC_Instance types) pState
					(context, pState)		= optionalContext pState
				->	(ID_Instance { ii_ident = class_id, ii_extended = ii_extended } inst_id (types,context), pState)
			IdentToken fun_name
				#	(fun_id, pState)		= stringToIdent fun_name IC_Expression pState
					(ii_extended, pState)	= optional_extension pState
				->	(ID_Function { ii_ident = fun_id, ii_extended = ii_extended }, pState)
			token
				#	(fun_id, pState)		= stringToIdent "dummy" IC_Expression pState
				->	( ID_Function { ii_ident = fun_id, ii_extended = False }
					, parseError "from import" (Yes token) "imported item" pState
					)
	where				
		want_names want_fun ident_kind close_token pState
			# (token, pState) = nextToken FunctionContext pState
			| token == DotDotToken
				= ([], wantToken FunctionContext "import declaration" close_token pState)
				= want_list_of_names want_fun ident_kind close_token (tokenBack pState)

		want_list_of_names want_fun ident_kind close_token pState
			# (name, pState) = want_fun pState
			  (name_id, pState)	= stringToIdent name ident_kind pState
			  (ii_extended, token, pState) = optional_extension_with_next_token pState
			| token == CommaToken
				# (names, pState) = want_list_of_names want_fun ident_kind close_token pState
				= ([{ ii_ident = name_id, ii_extended = ii_extended } : names], pState)
			| token == close_token
				= ([{ ii_ident = name_id, ii_extended = ii_extended }], pState)
				= ([{ ii_ident = name_id, ii_extended = ii_extended }], parseError "ImportDeclaration" (Yes token) ")" pState)
			
		optional_extension pState
			# (token, pState) = nextToken FunctionContext pState
			| token == DotDotToken
				= (True, pState)
				= (False, tokenBack pState)			
			
		optional_extension_with_next_token pState
			# (token, pState) = nextToken FunctionContext pState
			| token == DotDotToken
				# (token, pState) = nextToken FunctionContext pState
				= (True, token, pState)
				= (False, token, pState)

/*						
wantExportDef :: !ParseState -> (!Export, !ParseState)
wantExportDef pState
	# (name, pState) = want pState
	  (ident, pState) = stringToIdent name IC_Class pState
	  (types, pState) = wantList "instance types" trySimpleType pState
	  pState = wantEndOfDefinition "exports" pState
	= ({ export_class = ident, export_types = types}, pState)
*/
/*
	Classes and instances
*/

cIsAGlobalContext		:== True
cIsNotAGlobalContext	:== False

cMightBeAClass			:== True
cIsNotAClass			:== False

		
wantClassDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantClassDefinition context pos pState
	# (might_be_a_class, class_or_member_name, prio, pState) = want_class_or_member_name pState
	  (class_variables, pState) = wantList "class variable(s)" try_class_variable pState
	  (class_arity, class_args, class_cons_vars) = convert_class_variables class_variables 0 0
	  (contexts, pState) = optionalContext pState
  	  (token, pState) = nextToken TypeContext pState
  	| token == DoubleColonToken
		= want_overloaded_function pos class_or_member_name prio class_arity class_args class_cons_vars contexts pState
	| might_be_a_class
Pieter Koopman's avatar
Pieter Koopman committed
975
976
		# (begin_members, pState) = begin_member_group token pState
		| begin_members
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
977
			# (class_id, pState) = stringToIdent class_or_member_name IC_Class pState
Pieter Koopman's avatar
Pieter Koopman committed
978
		 	  (members, pState) = wantDefinitions (SetLocalContext context) pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
979
980
981
  		  	  class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args,
	    					class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars,
	    					class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }}
Pieter Koopman's avatar
Pieter Koopman committed
982
983
	    	  pState = wantEndGroup "class" pState
			= (PD_Class class_def members, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
984
985
986
987
988
989
990
991
992
993
994
995
		| isEmpty contexts
			= (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>: contexts" pState)
		// otherwise
			# pState = tokenBack pState
			  (class_id, pState) = stringToIdent class_or_member_name IC_Class pState
  			  class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args,
							class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, 
							class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }}
	  		  pState = wantEndOfDefinition "class definition" pState
			= (PD_Class class_def [], pState)
		= (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>" pState)
	where
Pieter Koopman's avatar
Pieter Koopman committed
996
997
998
999
1000
		begin_member_group token pState // For JvG layout
			# (token, pState)
				= case token of
					SemicolonToken	->	nextToken TypeContext pState
					_				->	(token, pState)