syntax.icl 32.4 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
implementation module syntax

3
import StdEnv, compare_constructor // ,RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4

5
import scanner, general, Heap, typeproperties, utilities, compilerSwitches
6
import syntax
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7
8
9
10
11
12
13

instance toString Ident
where toString {id_name} = id_name

instance toString (Import from_symbol)
where toString {import_module} = toString import_module

14
15
16
17
18
19
instance == FunctionOrMacroIndex
	where
		(==) (FunctionOrIclMacroIndex f1) (FunctionOrIclMacroIndex f2) = f1==f2
		(==) (DclMacroIndex m1 f1) (DclMacroIndex m2 f2) = m1==m2 && f1==f2
		(==) _ _ = False

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20
21
22
23
24
25
26
/* Used for hashing identifiers */

class needs_brackets a :: a -> Bool

instance == BoundVar
where
	(==) varid1 varid2
27
		= varid1.var_ident == varid2.var_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

instance == Ident
where
	(==) id1 id2
		= id1.id_info == id2.id_info

instance needs_brackets AType
where
	needs_brackets {at_type}
		= needs_brackets at_type

instance needs_brackets Type
where
	needs_brackets (TA {type_arity} _)
		= type_arity > 0
43
44
	needs_brackets (TAS {type_arity} _ _)
		= type_arity > 0
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
45
46
47
48
	needs_brackets (_ --> _)
		= True
	needs_brackets (_ :@: _)
		= True
49
50
	needs_brackets (TArrow1 _)
		= True		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
51
52
53
54
55
56
57
/*	needs_brackets (TFA _ _)
		= True
*/	needs_brackets _
		= False

instance needs_brackets Expression
where
58
59
	needs_brackets (App {app_args})
		= not (isEmpty app_args)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
	needs_brackets (_ @ _)
		= True
	needs_brackets (Let _)
		= True
	needs_brackets (Case _)
		= True
	needs_brackets (Selection _ _ _)
		= True
	needs_brackets _
		= False

instance needs_brackets a
where
	needs_brackets _ = False

75
76
77
78
79
80
81
82
83
84
instance toString BasicType  where
	toString BT_Int = "Int"
	toString BT_Char = "Char"
	toString BT_Real = "Real"
	toString BT_Bool = "Bool"
	toString (BT_String _) = "String"
	toString BT_Dynamic = "Dynamic"
	toString BT_File = "File"
	toString BT_World = "World"
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
85
86
instance <<< BasicType
where
87
	(<<<) file bt			= file <<< toString bt
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
88
89
90

instance <<< TypeVar
where
91
92
//	(<<<) file varid = file <<< varid.tv_ident 
	(<<<) file varid = file <<< varid.tv_ident <<< "<" <<< varid.tv_info_ptr <<< ">"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
93
94
95

instance <<< AttributeVar
where
96
97
	(<<<) file {av_ident,av_info_ptr} = file <<< av_ident <<< "[" <<< av_info_ptr <<< "]"
//	(<<<) file {av_ident,av_info_ptr} = file <<< av_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
98
99
100

instance toString AttributeVar
where
101
102
	toString {av_ident,av_info_ptr} = toString av_ident + "[" + toString (ptrToInt av_info_ptr) + "]"
//	toString {av_ident,av_info_ptr} = toString av_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
103
104
105

instance <<< AType
where
106
107
	(<<<) file {at_attribute,at_type}
		= file <<< at_attribute <<< at_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
108

109
110
111
112
113
114
115
instance <<< TypeCons 
where
	(<<<) file (TypeConsSymb name) = file <<< name
	(<<<) file (TypeConsBasic basic_type) = file <<< basic_type
	(<<<) file TypeConsArrow = file <<< "(->)"
	(<<<) file (TypeConsVar tv) = file <<< tv

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
116
117
118
119
120
121
122
123
instance <<< TypeAttribute
where
	(<<<) file ta
		= file <<< toString ta

instance toString TypeAttribute
where
	toString (TA_Unique)
124
		= "*"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
125
	toString (TA_TempVar tav_number)
126
		= "u" + toString tav_number + ":"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
127
	toString (TA_Var avar)
128
		= toString avar + ":"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
129
	toString (TA_RootVar avar)
130
		= toString avar + ":)"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
131
	toString (TA_Anonymous)
132
		= "."
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
134
135
136
	toString TA_None
		= ""
	toString TA_Multi
		= "o "
137
138
	toString TA_MultiOfPropagatingConsVar
		= "@@ "
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
139
140
141
142
143
144
145
146
147
148
149
150
151
152
	toString (TA_List _ _)
		= "??? "

instance <<< Annotation
where
	(<<<) file an = file <<< toString an

instance toString Annotation
where
	toString AN_Strict	= "!" 
	toString _			= "" 

instance <<< ATypeVar
where
153
154
	(<<<) file {atv_attribute,atv_variable}
		= file <<< atv_attribute <<< atv_variable
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
155
156
157
158
159
160
161

instance <<< ConsVariable
where
	(<<<) file (CV tv)
		= file <<< tv
	(<<<) file (TempCV tv)
		= file <<<  "v" <<< tv <<< ' ' 
162
163
	(<<<) file (TempQCV tv)
		= file <<<  "E." <<< tv <<< ' ' 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
164

165
166
167
168
169
170
171
172
173
instance <<< StrictnessList
where
	(<<<) file (NotStrict)
		= file <<< 0
	(<<<) file (Strict s)
		= file <<< s
	(<<<) file (StrictList s l)
		= file <<< s <<< ' ' <<< l

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
174
175
176
177
178
179
180
181
instance <<< Type
where
	(<<<) file (TV varid)
		= file <<< varid
	(<<<) file (TempV tv_number)
		= file  <<< 'v' <<< tv_number <<< ' ' 
	(<<<) file (TA consid types)
		= file  <<< consid <<< " " <<< types
182
183
	(<<<) file (TAS consid types strictness)
		= file  <<< consid <<< ' ' <<< strictness <<< ' ' <<< types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
184
185
	(<<<) file (arg_type --> res_type)
		= file <<< arg_type <<< " -> " <<< res_type
186
187
188
189
190
191
//AA..		
	(<<<) file TArrow
		= file <<< "(->)"	
	(<<<) file (TArrow1 t)
		= file <<< "(->) " <<< t	
//..AA		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
192
193
194
195
	(<<<) file (type :@: types)
		= file <<< type <<< " @" <<< types
	(<<<) file (TB tb)
		= file <<< tb
196
	(<<<) file (TFA vars types)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
197
		= file <<< "A." <<< vars <<< ':' <<< types
198
	(<<<) file (TQV varid)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
		= file <<< "E." <<< varid
	(<<<) file (TempQV tv_number)
		= file  <<< "E." <<< tv_number <<< ' ' 
	(<<<) file TE
		= file <<< "### EMPTY ###"
/*
instance <<< [a] | <<< , needs_brackets a
where
	(<<<) file [] 		= file
	(<<<) file [x:xs]
		| needs_brackets x
			= file <<< " (" <<< x <<< ')' <<< xs
			= file <<< ' ' <<< x <<< xs
*/

instance <<< SymbolType
where
	(<<<) file st=:{st_vars,st_attr_vars}
		| st.st_arity == 0
218
219
			= write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_args_strictness <<< ' ' <<< st.st_result))
			= write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_args_strictness <<< ' ' <<< st.st_args <<< " -> " <<< st.st_result))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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

write_contexts [] file
	= file
write_contexts [tc : tcs] file
	= write_contexts2 tcs (file <<< " | " <<< tc) 
where
	write_contexts2 [] file
		= file
	write_contexts2 [tc : tcs] file
		= write_contexts2 tcs (file <<< " & " <<< tc)

instance <<< AttrInequality
where
	(<<<) file {ai_demanded,ai_offered}
		= file <<< ai_offered <<< " <= " <<< ai_demanded
	
write_inequalities [] file
	= file
write_inequalities [ineq:ineqs] file
	= write_remaining_inequalities ineqs (file <<< ',' <<< ineq)
where
	write_remaining_inequalities [] file
		= file
	write_remaining_inequalities [ineq:ineqs] file
		= write_remaining_inequalities ineqs (file <<< ' ' <<< ineq)

instance <<< TypeContext
where
248
	(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
249

250
251
252
253
254
255
256
257
258
259
instance <<< TCClass 
where
	(<<<) file (TCClass glob) = file <<< glob
	(<<<) file (TCGeneric {gtc_generic,gtc_kind}) = file <<< gtc_generic <<< gtc_kind

instance toString TCClass
where
	toString (TCClass clazz) = clazz.glob_object.ds_ident.id_name
	toString (TCGeneric {gtc_generic,gtc_kind}) = gtc_generic.glob_object.ds_ident.id_name +++ toString gtc_kind
	 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
260
261
instance <<< SymbIdent
where
262
	(<<<) file symb=:{symb_kind = SK_Function symb_index }
263
		= file <<< symb.symb_ident <<<  '@' <<< symb_index
264
	(<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index }
265
		= file <<< symb.symb_ident <<<  "[lm]@" <<< symb_index
266
	(<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index }
267
		= file <<< symb.symb_ident <<<  "[g]@" <<< symb_index
268
	(<<<) file symb=:{symb_kind = SK_LocalDclMacroFunction symb_index }
269
		= file <<< symb.symb_ident <<<  "[ldm]@" <<< symb_index
270
	(<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index }
271
		= file <<< symb.symb_ident <<<  "[o]@" <<< symb_index
272
	(<<<) file symb
273
		= file <<< symb.symb_ident 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
274
275
276

instance <<< TypeSymbIdent
where
277
	(<<<) file symb	= file <<< symb.type_ident <<< '.' <<< symb.type_index
278
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
279
280
281
instance <<< ClassSymbIdent
where
	(<<<) file symb	= file <<< symb.cs_name 
282
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
283
284
instance <<< BoundVar
where
285
286
	(<<<) file {var_ident,var_info_ptr,var_expr_ptr}
		= file <<< var_ident <<< "<I" <<< var_info_ptr <<< ", E" <<< var_expr_ptr <<< '>'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
287

288
instance <<< (Bind a b) | <<< a & <<< b 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
289
290
291
292
293
294
where
	(<<<) file {bind_src,bind_dst} = file <<< bind_dst <<<  " = " <<< bind_src 


instance <<< AlgebraicPattern
where
295
296
	//(<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " -> " <<< g.ap_expr
	(<<<) file g = file <<< '\n' <<< g.ap_symbol <<< g.ap_vars <<< "\n\t-> " <<< g.ap_expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
297
298
299

instance <<< BasicPattern
where
300
301
	//(<<<) file g = file <<< g.bp_value <<< " -> " <<< g.bp_expr
	(<<<) file g = file <<< '\n' <<< g.bp_value <<< "\n\t-> " <<< g.bp_expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
302
303
304

instance <<< CasePatterns
where
305
	(<<<) file (BasicPatterns type patterns) = file <<< " " <<<patterns
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
306
307
	(<<<) file (AlgebraicPatterns type patterns) = file <<< patterns
	(<<<) file (DynamicPatterns patterns) = file <<< patterns
308
	(<<<) file (OverloadedListPatterns type decons_expr patterns) = file <<< decons_expr <<< " " <<< patterns
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
309
310
	(<<<) file NoPattern = file 

311
312
313
314
instance <<< CheckedAlternative
where
	(<<<) file {ca_rhs} = file <<< ca_rhs

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
315
316
317
318
319
320
321
322
instance <<< Qualifier
where
	(<<<) file {qual_generators,qual_filter = Yes qual_filter} = file <<< qual_generators <<< "| " <<< qual_filter
	(<<<) file {qual_generators,qual_filter = No} = file <<< qual_generators

instance <<< Generator
where
	(<<<) file {gen_kind,gen_pattern,gen_expr}
323
324
325
326
327
		= file <<< gen_pattern <<< (gen_kind_to_string gen_kind) <<< gen_expr
	where
		gen_kind_to_string IsListGenerator = "<-"
		gen_kind_to_string IsOverloadedListGenerator = "<|-"
		gen_kind_to_string IsArrayGenerator = "<-:"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
328
329
330
331

instance <<< BasicValue
where
	(<<<) file (BVI int)	= file <<< int
332
	(<<<) file (BVInt int)	= file <<< int
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
333
334
335
336
337
338
339
	(<<<) file (BVC char)	= file <<< char
	(<<<) file (BVB bool)	= file <<< bool
	(<<<) file (BVR real)	= file <<< real
	(<<<) file (BVS string)	= file <<< string
	
instance <<< Sequence
where
340
341
342
343
	(<<<) file (SQ_From _ expr) = file <<< expr
	(<<<) file (SQ_FromTo _ from_expr to_expr) = file <<< from_expr <<< ".."  <<< to_expr
	(<<<) file (SQ_FromThen _ from_expr then_expr) = file <<< from_expr  <<< ',' <<< then_expr <<< ".."
	(<<<) file (SQ_FromThenTo _ from_expr then_expr to_expr) = file <<< from_expr  <<< ',' <<< then_expr <<< ".." <<< to_expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
344
345
346
347

instance <<< Expression
where
	(<<<) file (Var ident) = file <<< ident
Sjaak Smetsers's avatar
Sjaak Smetsers committed
348
	(<<<) file (App {app_symb, app_args, app_info_ptr})
349
350
351
352
		= case app_symb.symb_kind of
			SK_Generic _ kind 
				->  file <<< app_symb <<< kind <<< ' ' <<< app_args
			_ 	-> file <<< app_symb <<< ' ' <<< app_args
353
	(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< ") @ (" <<< a_exp <<< ')'
354
355
	(<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr}) 
			= write_binds "" (write_binds "!" (file <<< "let" <<< '\n') let_strict_binds) let_lazy_binds <<< "in\n" <<< let_expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
356
	where
357
		write_binds x file []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
358
			= file
359
		write_binds x file [bind : binds]
360
			= write_binds x (file <<< x <<< " " <<< bind) binds
361
 	(<<<) file (Case {case_expr,case_guards,case_default=No})
362
363
		//= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards
		= file <<< "case " <<< case_expr <<< " of" <<< case_guards
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
364
	(<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr})
365
366
		//= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t->" <<< def_expr
		= file <<< "case " <<< case_expr <<< " of" <<< case_guards <<< "\n\t->" <<< def_expr
367
	(<<<) file (BasicExpr basic_value) = file <<< basic_value
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
368
369
370
371
372
373
374
375
376
377
378
379
	(<<<) file (Conditional {if_cond,if_then,if_else}) =
			else_part (file <<< "IF " <<< if_cond <<< "\nTHEN\n" <<< if_then) if_else
	where
		else_part file No = file <<< '\n'
		else_part file (Yes else) = file <<< "\nELSE\n" <<< else <<< '\n'

/*	(<<<) file (Conditional {if_cond = {con_positive,con_expression},if_then,if_else}) =
			else_part (file <<< (if con_positive "IF " "IFNOT ") <<< con_expression <<< "\nTHEN\n" <<< if_then) if_else
	where
		else_part file No = file <<< '\n'
		else_part file (Yes else) = file <<< "\nELSE\n" <<< else <<< '\n'
*/
380
 	(<<<) file (Selection selector_kind expr selectors) = file <<< expr <<< selector_kind <<< selectors
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
381
382
383
	(<<<) file (Update expr1 selections expr2) =  file <<< '{' <<< expr1  <<< " & " <<<  selections <<< " = " <<< expr2 <<< '}'
	(<<<) file (RecordUpdate cons_symbol expression expressions) = file <<< '{' <<< cons_symbol <<< ' ' <<< expression <<< " & " <<< expressions <<< '}'
	(<<<) file (TupleSelect field field_nr expr) = file <<< expr <<<'.' <<< field_nr
384
//	(<<<) file (Lambda vars expr) = file <<< '\\' <<< vars <<< " -> " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
385
	(<<<) file WildCard = file <<< '_'
386
	(<<<) file (MatchExpr cons expr) = file <<< cons <<< " =: " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
	(<<<) file EE = file <<< "** E **"
388
	(<<<) file (NoBind _) = file <<< "** NB **"
389
390
	(<<<) file (DynamicExpr {dyn_expr,dyn_type_code})     = file <<< "dynamic " <<< dyn_expr <<< " :: " <<< dyn_type_code 
//	(<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code})     = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: dyn_uni_vars") dyn_uni_vars <<< "dyn_type_code=" <<< dyn_type_code 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
391
392
393
394
395
396
397
//	(<<<) file (TypeCase type_case)      = file <<< type_case
	(<<<) file (TypeCodeExpression type_code)      = file <<< type_code
	(<<<) file (Constant symb _ _ _)         = file <<<  "** Constant **" <<< symb

	(<<<) file (ABCCodeExpr code_sequence do_inline)      = file <<< (if do_inline "code inline\n" "code\n") <<< code_sequence
	(<<<) file (AnyCodeExpr input output code_sequence)   = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence

398
	(<<<) file (FreeVar {fv_ident})         	= file <<< fv_ident
399
	(<<<) file (ClassVariable info_ptr)         	= file <<< "ClassVariable " <<< info_ptr
Sjaak Smetsers's avatar
Sjaak Smetsers committed
400

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
401
	(<<<) file (FailExpr _) = file <<< "** FAIL **"
Sjaak Smetsers's avatar
Sjaak Smetsers committed
402
	(<<<) file expr         				= abort ("<<< (Expression) [line 1290]" )//<<- expr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
	
404
405
406
407
408
instance <<< LetBind
where
	(<<<) file {lb_dst, lb_src}
		= file <<< lb_dst <<< " = " <<< lb_src <<< "\n"

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
409
410
411
412
413
414
415
416
instance <<< TypeCase
where
	(<<<) file {type_case_dynamic,type_case_patterns,type_case_default}
			= file <<< "typecase " <<< type_case_dynamic <<< "of\n" <<<
				type_case_patterns <<< type_case_default

instance <<< DynamicPattern
where
417
418
	(<<<) file {dp_var,dp_rhs,dp_type_code}
			= file <<< dp_var <<< " :: " <<< dp_type_code <<< " = " <<< dp_rhs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
419
420
421
422
423
424
425

writeVarPtrs file []
	= file
writeVarPtrs file vars
	= write_var_ptrs (file <<< '<') vars <<< '>'
	where
		write_var_ptrs file [var]
426
			= file <<< var
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427
		write_var_ptrs file [var : vars]
428
			= write_var_ptrs (file <<< var <<< '.') vars	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
429
430
431
432
433
434
		
instance <<< TypeCodeExpression
where
	(<<<) file TCE_Empty
		= file
	(<<<) file (TCE_Var info_ptr)
435
		= file <<< "TCE_Var " <<< info_ptr
436
	(<<<) file (TCE_TypeTerm info_ptr)
437
		= file <<< "TCE_TypeTerm " <<< info_ptr
438
439
	(<<<) file (TCE_Constructor cons exprs)
		= file <<< "TCE_Constructor " <<< ' ' <<< exprs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
440
	(<<<) file (TCE_Selector selectors info_ptr)
441
442
443
444
445
446
447
448
		= file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr
	(<<<) file (TCE_UniType vars type_code)
		= file <<< "TCE_UniType " <<< vars <<< " " <<< type_code

instance <<< (Ptr a)
where
	(<<<) file ptr
		= file <<< ptrToInt ptr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
449

450
451
instance <<< SelectorKind
where
452
453
 	(<<<) file NormalSelector = file <<< "."
 	(<<<) file NormalSelectorUniqueElementResult = file <<< "!*"
454
 	(<<<) file UniqueSelector = file <<< "!"
455

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
456
457
458
instance <<< Selection
where
	(<<<) file (RecordSelection selector _) = file <<< selector
459
	(<<<) file (ArraySelection {glob_object={ds_index}} _ index_expr) = file <<< '<' <<< ds_index <<< '>' <<< '[' <<< index_expr <<< ']'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
460
461
462
463
464
465
466
	(<<<) file (DictionarySelection var selections _ index_expr) = file <<< '(' <<< var <<< '.' <<< selections <<< ')' <<< '[' <<< index_expr <<< ']'

instance <<< LocalDefs
where
	(<<<) file (LocalParsedDefs defs) = file <<< defs
	(<<<) file (CollectedLocalDefs defs) = file <<< defs

467
instance <<< (NodeDef dst) | <<< dst 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
where
	(<<<) file {nd_dst,nd_alts,nd_locals} = file <<< nd_dst <<< nd_alts <<< nd_locals


instance <<< CollectedLocalDefs
where
	(<<<) file {loc_functions,loc_nodes}
		= file <<< loc_functions <<< loc_nodes
/*
	(<<<) file {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances}
		= file <<< def_types <<< def_constructors <<< def_selectors <<< def_macros <<< def_classes <<< def_members <<< def_instances
*/

instance <<< ParsedExpr
where
	(<<<) file (PE_List exprs) = file <<< exprs
	(<<<) file (PE_Tuple args) = file <<< '(' <<< args <<< ')'
	(<<<) file (PE_Basic basic_value) = file <<< basic_value
486
	(<<<) file (PE_Selection selector_kind expr selectors) =  file <<< expr <<< selector_kind <<< selectors
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
487
488
489
	(<<<) file (PE_Update expr1 selections expr2) =  file <<< '{' <<< expr1  <<< " & " <<<  selections <<< " = " <<< expr2 <<< '}'
	(<<<) file (PE_Record PE_Empty _ fields) = file <<< '{' <<< fields <<< '}'
	(<<<) file (PE_Record rec _ fields) = file <<< '{' <<< rec <<< " & " <<< fields <<< '}'
490
491
	(<<<) file (PE_ListCompr _ _ expr quals) = file <<< '[' <<< expr <<< " \\ " <<< quals <<< ']'
	(<<<) file (PE_ArrayCompr expr quals) = file <<< '{' <<< expr <<< " \\ " <<< quals <<< '}'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
492
493
494
495
	(<<<) file (PE_Sequ seq) = file <<< '[' <<< seq <<< ']'
	(<<<) file PE_Empty = file <<< "** E **"
	(<<<) file (PE_Ident symb) = file <<< symb
	(<<<) file PE_WildCard = file <<< '_'
Martin Wierich's avatar
Martin Wierich committed
496
	(<<<) file (PE_Lambda _ exprs expr _) = file <<< '\\' <<< exprs <<< " -> " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
497
498
499
500
501
502
503
504
505
506
507
508
	(<<<) file (PE_Bound bind) = file <<< bind
	(<<<) file (PE_Case _ expr alts) = file <<< "case " <<< expr <<< " of\n" <<< alts
	(<<<) file (PE_Let _ defs expr) = file <<< "let " <<< defs <<< " in\n" <<< expr
	(<<<) file (PE_DynamicPattern expr type) = file <<< expr <<< "::" <<< type
	(<<<) file (PE_Dynamic expr maybetype)
		= case maybetype of
			Yes type
				-> file <<< "dynamic " <<< expr <<< "::" <<< type
			No
				-> file <<< "dynamic " <<< expr
	(<<<) file _ = file <<< "some expression"

509
510
511
512
513
514
instance <<< ParsedSelectorKind
where
	(<<<) file ParsedNormalSelector			= file <<< "."
	(<<<) file (ParsedUniqueSelector False)	= file <<< "!"
	(<<<) file (ParsedUniqueSelector True)	= file <<< "!*"
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
515
516
517
518
519
520
521
522
523
524
525
526
527
528
instance <<< ParsedSelection
where
	(<<<) file (PS_Record selector _)	= file <<< selector
	(<<<) file (PS_Array index_expr)	= file <<< '[' <<< index_expr <<< ']'
	(<<<) file PS_Erroneous				= file <<< "Erroneous selector" // PK

instance <<< CaseAlt
where
	(<<<) file {calt_pattern,calt_rhs} = file <<< calt_pattern <<< " -> " <<< calt_rhs

instance <<< ParsedBody
where
	(<<<) file {pb_args,pb_rhs} = file <<< pb_args <<< " = " <<< pb_rhs

529
530
531
532
instance <<< FunKind
where
	(<<<) file (FK_Function False) = file <<< "FK_Function"
	(<<<) file (FK_Function True) = file <<< "Lambda"
533
	(<<<) file FK_NodeDefOrFunction = file <<< "FK_NodeDefOrFunction"
534
535
536
537
	(<<<) file FK_Macro = file <<< "FK_Macro"
	(<<<) file FK_Caf = file <<< "FK_Caf"
	(<<<) file FK_Unknown = file <<< "FK_Unknown"

538
539
instance <<< FunType 
where
540
	(<<<) file {ft_ident,ft_type} = file <<< ft_ident <<< "::" <<< ft_type
541

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
542
543
instance <<< FunDef
where
544
545
	(<<<) file {fun_ident,fun_body=ParsedBody bodies} = file <<< fun_ident <<< '.' <<< ' ' <<< bodies 
	(<<<) file {fun_ident,fun_body=CheckedBody {cb_args,cb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_ident <<< '.'
546
			<<< "C " <<< cb_args <<< " = " <<< cb_rhs <<< '\n'
547
//			<<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs 
548
549
	(<<<) file {fun_ident,fun_body=TransformedBody {tb_args,tb_rhs},fun_info={fi_free_vars,fi_local_vars,fi_def_level,fi_calls}}
		= file <<< fun_ident <<< '.' <<< "T "  
550
//			<<< '[' <<< fi_free_vars <<< "]  [" <<< fi_local_vars <<< ']'
551
			<<< tb_args <<< '[' <<< fi_calls <<< ']' <<< "\n\t= " <<< tb_rhs <<< '\n'
552
//			<<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs 
553
554
	(<<<) file {fun_ident,fun_body=NoBody,fun_type=Yes type} = file // <<< type <<< '\n'
			<<< fun_ident <<< '.' <<< "Array function\n"
555

556
	(<<<) file {fun_ident} = file <<< fun_ident <<< "???" <<< '\n'
557

558
559
560
instance <<< FunctionBody
where
	(<<<) file (ParsedBody bodies) = file <<< bodies 
561
562
	(<<<) file (CheckedBody {cb_args,cb_rhs}) = file <<< "C " <<< cb_args <<< " = " <<< cb_rhs <<< '\n'
	(<<<) file (TransformedBody {tb_args,tb_rhs}) = file <<< "T "  <<< tb_args <<< " = " <<< tb_rhs <<< '\n'
563
	(<<<) file (Expanding vars) = file <<< "E " <<< vars 
564
	(<<<) file GeneratedBody = file <<< "Generic function\n"
565
	(<<<) file NoBody = file <<< "Array function\n"
566
	
567

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
568
569
instance <<< FunCall
where
570
	(<<<) file (FunCall fc_index fc_level)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
571
			= file <<< fc_index <<< '.' <<< fc_level
572
573
	(<<<) file (MacroCall module_index fc_index fc_level)
			= file <<< "MacroCall "<<< module_index <<<" "<<<fc_index <<< '.' <<< fc_level
574
575
	(<<<) file (DclFunCall module_index fc_index)
			= file <<< "DclFunCall "<<< module_index <<<" "<<<fc_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
576
577
578

instance <<< FreeVar
where
579
	(<<<) file {fv_ident,fv_info_ptr,fv_count} = file <<< fv_ident <<< '.' <<< fv_count <<< '<' <<< fv_info_ptr <<< '>'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
581
582
583
584

instance <<< DynamicType
where
	(<<<) file {dt_uni_vars,dt_type}
		| isEmpty dt_uni_vars
585
586
			= file <<< "DynamicType" <<< dt_type
			= file <<< "DynamicType" <<< "A." <<< dt_uni_vars <<< ":" <<< dt_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
			

instance <<< SignClassification
where
	(<<<) file {sc_pos_vect,sc_neg_vect} = write_signs file sc_pos_vect sc_neg_vect 0
	where
		write_signs file sc_pos_vect sc_neg_vect index
			| sc_pos_vect == 0 && sc_neg_vect == 0
				= file
			#	index_bit = (1 << index)
			| sc_pos_vect bitand index_bit == 0
				| sc_neg_vect bitand index_bit == 0
					= write_signs (file <<< 'O') sc_pos_vect sc_neg_vect (inc index)
					= write_signs (file <<< '-') sc_pos_vect (sc_neg_vect bitand (bitnot index_bit)) (inc index)
				| sc_neg_vect bitand index_bit == 0
					= write_signs (file <<< '+') (sc_pos_vect bitand (bitnot index_bit)) sc_neg_vect (inc index)
					= write_signs (file <<< 'T') (sc_pos_vect bitand (bitnot index_bit)) (sc_neg_vect bitand (bitnot index_bit)) (inc index)
604
605
606
607
608

instance toString TypeKind
where
	toString (KindVar _) 		= "**"
	toString KindConst			= "*"
609
	toString (KindArrow args) 	= "{" +++ (to_string args) +++ "->*}" 
610
611
612
613
614
	where
		to_string []		= "??????" 
		to_string [k]		= toString k  
		to_string [k:ks]	= (toString k) +++ "->" +++ (to_string ks)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
615
616
617
				
instance <<< TypeKind
where
618
619
620
621
622
623
624
625
626
627
628
	(<<<) file kind 		= file <<< (toString kind)

instance == TypeKind 
where
	(==) KindConst KindConst = True
	(==) (KindArrow xs) (KindArrow ys) = xs == ys
	(==) _ _ = False
				

instance toString KindInfo
where
629
630
631
	toString (KI_Var ptr) 				= "*" +++ toString (ptrToInt ptr)
	toString (KI_Const) 				= "*"
	toString (KI_Arrow kind1 kind2)		= withBrackets kind1 (toString kind1) +++ " -> " +++ toString kind2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
632
	where
633
634
		withBrackets (KI_Arrow _ _) kind_str	= "(" +++ kind_str +++ ")"
		withBrackets _				kind_str	= kind_str
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
635
636
637
638

instance <<< TypeDefInfo
where
	(<<<) file {tdi_group,tdi_group_vars,tdi_cons_vars}
639
640
//		= file <<< '[' <<< tdi_group <<< '=' <<< tdi_group_vars <<< '=' <<< tdi_cons_vars <<< ']'
		= file <<< '[' <<< tdi_group_vars <<< '=' <<< tdi_cons_vars <<< ']'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
641
642
643
644
645
646

instance <<< DefinedSymbol
where
	(<<<) file {ds_ident}
		= file <<< ds_ident 

647
instance <<< (TypeDef a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
648
where
649
650
	(<<<) file {td_ident, td_args, td_rhs}
		= file <<< ":: " <<< td_ident <<< ' ' <<< td_args <<< td_rhs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669

instance <<< TypeRhs
where
	(<<<) file (SynType type)
		= file <<< " :== " <<< type 
	(<<<) file (AlgType data)
		= file <<< " = " <<< data 
	(<<<) file (RecordType record)
		= file <<< " = " <<< '{' <<< record <<< '}'
	(<<<) file _
		= file 


instance <<< RecordType
where
	(<<<) file {rt_fields} = iFoldSt (\index file -> file <<< rt_fields.[index]) 0 (size rt_fields) file

instance <<< FieldSymbol
where
670
	(<<<) file {fs_ident} = file <<< fs_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
671
672
673
674
675
676
677
678
679

/*
	where
		write_data_defs file []
			= file
		write_data_defs file [d:ds]
			= write_data_defs (file <<< d <<< '\n') ds
*/

680
681
682
683
instance <<< GenericClassInfo 
where
	(<<<) file {gci_kind, gci_class} = file <<< gci_kind <<< ":" <<< gci_class 

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
684
685
686
687
688
689
690
instance <<< InstanceType
where
	(<<<) file it = write_contexts it.it_context (file <<< it.it_types) 

instance <<< RhsDefsOfType
where
	(<<<) file (ConsList cons_defs) = file <<< cons_defs
691
	(<<<) file (SelectorList _ _ _ sel_defs) = file <<< sel_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
692
693
694
695
696
	(<<<) file (TypeSpec type) = file <<< type
	(<<<) file _ = file

instance <<< ParsedConstructor
where
697
	(<<<) file {pc_cons_ident,pc_arg_types} = file <<< pc_cons_ident <<< pc_arg_types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
698
699
700

instance <<< ParsedSelector
where
701
	(<<<) file {ps_field_ident,ps_field_type} = file <<< ps_field_ident <<< ps_field_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
702
703
704
705
706
707
708
709


instance <<< ModuleKind
where
	(<<<) file kind 		= file

instance <<< ConsDef
where
710
	(<<<) file {cons_ident,cons_type} = file <<< cons_ident <<< " :: " <<< cons_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
711
712
713

instance <<< SelectorDef
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
714
	(<<<) file {sd_ident} = file <<< sd_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
715
716
717

instance <<< ClassDef
where
718
	(<<<) file {class_ident} = file <<< class_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
719
720
721
722
723

instance <<< ClassInstance
where
	(<<<) file {ins_class,ins_type} = file <<< ins_class <<< " :: " <<< ins_type

724
instance <<< (Optional a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
725
726
727
728
where
	(<<<) file (Yes x) = file <<< x
	(<<<) file No = file
	
729
instance <<< (Module a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
730
where
731
	(<<<) file {mod_ident,mod_type,mod_defs} = file <<< mod_type <<< mod_ident <<< mod_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
732

733
instance <<< (CollectedDefinitions a b) | <<< a & <<< b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
734
735
736
737
738
739
740
741
742
743
where
	(<<<) file {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances}
		= file

instance <<< ParsedDefinition
where
	(<<<) file (PD_Function _ name _ exprs rhs _ ) = file <<< name <<< exprs <<< " = " <<< rhs
	(<<<) file (PD_NodeDef  _ pattern rhs) = file <<< pattern <<< " =: " <<< rhs
	(<<<) file (PD_TypeSpec _ name prio st sp) = file <<< name <<< st
	(<<<) file (PD_Type td) = file <<< td
744
745
	(<<<) file (PD_Generic {gen_ident}) = file <<< "generic " <<< gen_ident
	(<<<) file (PD_GenericCase {gc_ident,gc_type_cons}) = file <<< gc_ident <<< "{|" <<< gc_type_cons <<< "|}"
746
	 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
747
748
749
750
	(<<<) file _ = file

instance <<< Rhs
where
751
	(<<<) file {rhs_alts,rhs_locals} = file <<< rhs_alts <<< rhs_locals <<< '\n'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
752
753
754

instance <<< OptGuardedAlts
where
755
	(<<<) file (GuardedAlts guarded_exprs def_expr) = file <<< guarded_exprs <<< def_expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
	(<<<) file (UnGuardedExpr unguarded_expr) = file <<< unguarded_expr

instance <<< ExprWithLocalDefs
where
	(<<<) file {ewl_expr,ewl_locals} = file <<< ewl_expr <<< ewl_locals

instance <<< GuardedExpr
where
	(<<<) file {alt_nodes,alt_guard,alt_expr} = file <<< '|' <<< alt_guard <<< alt_expr


instance <<< IndexRange
where
	(<<<) file {ir_from,ir_to}
		| ir_from == ir_to
			= file
			= file <<< ir_from <<< "---" <<< ir_to

instance <<< Ident
where
//	(<<<) file {id_name,id_index} = file <<< id_name <<< '.' <<< id_index
	(<<<) file {id_name} = file <<< id_name

779
instance <<< (Global a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
780
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
781
	(<<<) file {glob_object,glob_module} = file <<< glob_object <<< "M:" <<< glob_module
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
782
783
784
785
786
787
788

instance <<< Position
where
	(<<<) file (FunPos file_name line func) = file <<< '[' <<< file_name <<< ',' <<< line <<< ',' <<< func <<< ']'
	(<<<) file (LinePos file_name line) = file <<< '[' <<< file_name <<< ',' <<< line <<< ']'
	(<<<) file _ = file

789

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
790
791
792
793
instance <<< TypeVarInfo
where
	(<<<) file TVI_Empty				= file <<< "TVI_Empty"
	(<<<) file (TVI_Type _)				= file <<< "TVI_Type"
794
	(<<<) file (TVI_TypeVar ptr)		= file <<< (ptrToInt ptr) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
795
796
	(<<<) file (TVI_Forward	_) 			= file <<< "TVI_Forward"
	(<<<) file (TVI_SignClass _ _ _) 	= file <<< "TVI_SignClass"
797
	(<<<) file (TVI_AttrAndRefCount ta rc) 	= file <<< "TVI_AttrAndRefCount " <<< ta <<< " " <<< rc
798
799
800
801
802
803
	(<<<) file (TVI_CorrespondenceNumber n) = file <<< "TVI_CorrespondenceNumber " <<< n
	(<<<) file (TVI_AType at) 			= file <<< "TVI_AType " <<< at
	(<<<) file TVI_Used					= file <<< "TVI_Used"
	(<<<) file (TVI_TypeCode	_)		= file <<< "TVI_TypeCode"
	(<<<) file (TVI_CPSLocalTypeVar	_)	= file <<< "TVI_CPSLocalTypeVar"		
	(<<<) file (TVI_Kinds _)		= file <<< "TVI_Kinds"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
804
	(<<<) file (TVI_PropClass _ _ _) 	= file <<< "TVI_PropClass"
805
806
	(<<<) file (TVI_TypeKind kind_info_ptr) = file <<< "TVI_TypeKind " <<< (ptrToInt kind_info_ptr)
	(<<<) file (TVI_Kind kind) 			= file <<< "TVI_Kind" <<< kind
807
	(<<<) file (TVI_Expr expr) 			= file <<< "TVI_Expr " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
808

809
810
811
812
813
814
815
816
817
818
819
820
821
instance <<< AttrVarInfo
where
	(<<<) file AVI_Empty				= file <<< "AVI_Empty"
	(<<<) file (AVI_Attr attr)			= file <<< "AVI_Attr " <<< attr
	(<<<) file (AVI_AttrVar av_info_ptr) = file <<< "AVI_AttrVar " <<< ptrToInt av_info_ptr
	(<<<) file (AVI_Forward temp_attr_id) = file <<< "AVI_Forward " <<< temp_attr_id 
	(<<<) file (AVI_CorrespondenceNumber n) = file <<< "AVI_CorrespondenceNumber " <<< n
	(<<<) file AVI_Used					= file <<< "AVI_Used"
	(<<<) file (AVI_Count n) 			= file <<< "AVI_Count " <<< n
	(<<<) file (AVI_SequenceNumber n) 	= file <<< "AVI_SequenceNumber " <<< n
	(<<<) file AVI_Collected 			= file <<< "AVI_Collected"

	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
822
823
824
825
826
827
828
829
830
831
832
833
834
instance <<< (Import from_symbol) | <<< from_symbol
where
	(<<<) file {import_module, import_symbols}
		= file <<< "import " <<< import_module <<< import_symbols

instance <<< ImportDeclaration
where
	(<<<) file (ID_Function ident)			= file <<< ident
	(<<<) file (ID_Class ident optIdents)	= file <<< "class " <<< ident <<< optIdents
	(<<<) file (ID_Type ident optIdents)	= file <<< ":: " <<< ident <<< optIdents
	(<<<) file (ID_Record ident optIdents)	= file <<< ident <<< " { " <<< optIdents <<< " } "
	(<<<) file (ID_Instance i1 i2 tup)		= file <<< "instance " <<< i1 <<< i2 <<< tup // !ImportedIdent !Ident !(![Type],![TypeContext])

835
836
instance <<< CoercionPosition
where
John van Groningen's avatar
John van Groningen committed
837
838
839
840
	(<<<) file (CP_FunArg fun_name arg_nr)
		= file <<< "argument " <<< arg_nr <<< " of " <<< readable fun_name
	(<<<) file (CP_LiftedFunArg fun_name arg_name)
		= file <<< "lifted argument " <<< arg_name <<< " of " <<< readable fun_name
841
842
	(<<<) file (CP_Expression expression) = show_expression file expression
	where
843
844
845
846
847
848
		show_expression file (Var {var_ident})
			= file <<< var_ident
		show_expression file (FreeVar {fv_ident})
			= file <<< fv_ident
		show_expression file (App {app_symb={symb_ident}, app_args})
			| symb_ident.id_name=="_dummyForStrictAlias"
849
				= show_expression file (hd app_args)
850
			= file <<< readable symb_ident
851
852
853
854
855
856
857
858
859
		show_expression file (fun @ fun_args)
			= show_expression file fun
		show_expression file (Case {case_ident=No})
			= file <<< "(case ... )"
		show_expression file (Selection _ expr selectors)
			= file <<< "selection"
		show_expression file (Update expr1 selectors expr2)
			= file <<< "update"
		show_expression file (TupleSelect {ds_arity} elem_nr expr)
860
			= file <<< "argument " <<< (elem_nr + 1) <<< " of " <<< ds_arity <<< "-tuple"
861
		show_expression file (BasicExpr bv)
862
			= file <<< bv
863
		show_expression file (MatchExpr _ expr)
864
865
866
867
			= file <<< "match expression"
		show_expression file _
			= file
		
868
869
instance <<< Declaration
  where
870
	(<<<) file (Declaration { decl_ident, decl_kind })
871
		= file <<< decl_ident <<< '<' <<< decl_ident.id_info <<< '>' <<< '(' <<< decl_kind <<< ')'
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889

instance <<< STE_Kind
where
	(<<<) file
		(STE_FunctionOrMacro _)
			= file <<< "STE_FunctionOrMacro"
	(<<<) file
		STE_Type
			= file <<< "STE_Type"
	(<<<) file
		STE_Constructor
			= file <<< "STE_Constructor"
	(<<<) file
		(STE_Selector _)
			= file <<< "STE_Selector"
	(<<<) file
		STE_Class
			= file <<< "STE_Class"
890
891
892
893
// AA..			
	(<<<) file
		STE_Generic
			= file <<< "STE_Generic"
894
895
896
	(<<<) file
		STE_GenericCase
			= file <<< "STE_GenericCase"
897
// ..AA
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
	(<<<) file
		(STE_Field _)
			= file <<< "STE_Field"
	(<<<) file
		STE_Member
			= file <<< "STE_Member"
	(<<<) file
		(STE_Instance _)
			= file <<< "STE_Instance"
	(<<<) file
		(STE_Variable _) 
			= file <<< "STE_Variable"
	(<<<) file
		(STE_TypeVariable _) 
			= file <<< "STE_TypeVariable"
	(<<<) file
		(STE_TypeAttribute _)
			= file <<< "STE_TypeAttribute"
	(<<<) file
		(STE_BoundTypeVariable _)
			= file <<< "STE_BoundTypeVariable"
	(<<<) file
		(STE_Imported a b)
			= file <<< "STE_Imported (" <<< a <<< ")" <<< b 
	(<<<) file
		STE_DclFunction
			= file <<< "STE_DclFunction"
	(<<<) file
		(STE_Module _)
			= file <<< "STE_Module"
	(<<<) file
		STE_ClosedModule
			= file <<< "STE_ClosedModule"
	(<<<) file
		STE_Empty 
			= file <<< "STE_Empty"
	(<<<) file
		_ 
			= file <<< "STE_???"

938
939
readable :: !Ident -> String // somewhat hacky
readable {id_name}
940
	| size id_name>0 && id_name.[0]=='_'
941
942
943
944
945
946
947
948
949
950
951
952
953
		| id_name=="_Cons" || id_name=="_Nil"
			= "list constructor"
		| id_name=="_!Cons" || id_name=="_!Nil"
			= "! list constructor"
		| id_name=="_#Cons" || id_name=="_#Nil"
			= "# list constructor"
		| id_name=="_Cons!" || id_name=="_Nil!"
			= "list constructor !"
		| id_name=="_!Cons!" || id_name=="_!Nil!"
			= "! list constructor !"
		| id_name=="_#Cons!" || id_name=="_#Nil!"
			= "# list constructor !"
			= id_name%(1, size id_name-1)
954
955
	= id_name

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
956
957
958
959
960
961
962
963
964
965
966
967
instance <<< ImportedIdent
where
	(<<<) file {ii_ident, ii_extended}	= file <<< ii_ident <<< ' ' <<< ii_extended

instance == ModuleKind
where
	(==) mk1 mk2 = equal_constructor mk1 mk2

instance == TypeAttribute
where
	(==) attr1 attr2 = equal_constructor attr1 attr2

968
969
970
971
instance == GlobalIndex
where
	(==) gi1 gi2 = gi1.gi_module == gi2.gi_module && gi1.gi_index == gi2.gi_index

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
972
973
974
975
instance == Annotation
where
	(==) a1 a2 = equal_constructor a1 a2

976
977
978
979
instance == OverloadedListType
where
	(==) a1 a2 = equal_constructor a1 a2
	
980
981
982
983
984
985
986
EmptySymbolTableEntry :== EmptySymbolTableEntryCAF.boxed_symbol_table_entry

EmptySymbolTableEntryCAF :: BoxedSymbolTableEntry
EmptySymbolTableEntryCAF =: {boxed_symbol_table_entry = { ste_kind = STE_Empty, ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = abort_empty_SymbolTableEntry } }

abort_empty_SymbolTableEntry :: a
abort_empty_SymbolTableEntry = abort "empty SymbolTableEntry"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
987
988


989
990
991
992
newTypeSymbIdentCAF :: TypeSymbIdent;
newTypeSymbIdentCAF =: MakeTypeSymbIdentMacro { glob_object = NoIndex, glob_module = NoIndex } {id_name="",id_info=nilPtr} 0

MakeTypeSymbIdentMacro type_index name arity
993
	:== {	type_ident = name, type_arity = arity, type_index = type_index,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
994
			type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }}