syntax.icl 33.3 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
417
418
419
420
421
422
423
424
425
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
	(<<<) file {dp_type_patterns_vars,dp_var,dp_rhs,dp_type_code}
			= writeVarPtrs (file <<< dp_var <<< " :: ")  dp_type_patterns_vars <<<  dp_type_code <<< " = " <<< dp_rhs

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
435
		
		
instance <<< TypeCodeExpression
where
	(<<<) file TCE_Empty
		= file
	(<<<) file (TCE_Var info_ptr)
436
		= file <<< "TCE_Var " <<< info_ptr
437
	(<<<) file (TCE_TypeTerm info_ptr)
438
		= file <<< "TCE_TypeTerm " <<< info_ptr
439
	(<<<) file (TCE_Constructor index cons exprs)
440
		= file <<< "TCE_Constructor " <<< index <<< ' ' <<< exprs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
441
	(<<<) file (TCE_Selector selectors info_ptr)
442
443
444
445
446
447
448
449
		= 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
450

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

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

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

468
instance <<< (NodeDef dst) | <<< dst 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
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
487
	(<<<) file (PE_Selection selector_kind expr selectors) =  file <<< expr <<< selector_kind <<< selectors
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
488
489
490
	(<<<) 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 <<< '}'
491
492
	(<<<) 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
493
494
495
496
	(<<<) 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
497
	(<<<) file (PE_Lambda _ exprs expr _) = file <<< '\\' <<< exprs <<< " -> " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
498
499
500
501
502
503
504
505
506
507
508
509
	(<<<) 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"

510
511
512
513
514
515
instance <<< ParsedSelectorKind
where
	(<<<) file ParsedNormalSelector			= file <<< "."
	(<<<) file (ParsedUniqueSelector False)	= file <<< "!"
	(<<<) file (ParsedUniqueSelector True)	= file <<< "!*"
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
516
517
518
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
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
	
instance <<< BackendBody
where
	(<<<) file {bb_args,bb_rhs} = file <<< bb_args <<< " = " <<< bb_rhs

instance <<< FunctionPattern
where
	(<<<) file (FP_Basic val (Yes var))
		= file <<< var <<< "=:" <<< val
	(<<<) file (FP_Basic val No)
		= file <<< val
	(<<<) file (FP_Algebraic constructor vars (Yes var))
		= file <<< var <<< "=:" <<< constructor <<< vars
	(<<<) file (FP_Algebraic constructor vars No)
		= file <<< constructor <<< vars
	(<<<) file (FP_Variable var) = file <<< var 
	(<<<) file (FP_Dynamic vars var type_code _)
		= writeVarPtrs (file <<< var <<< " :: ") vars <<<  type_code
	(<<<) file (FP_Empty) = file <<< '_' 


550
551
552
553
instance <<< FunKind
where
	(<<<) file (FK_Function False) = file <<< "FK_Function"
	(<<<) file (FK_Function True) = file <<< "Lambda"
554
	(<<<) file FK_NodeDefOrFunction = file <<< "FK_NodeDefOrFunction"
555
556
557
558
	(<<<) file FK_Macro = file <<< "FK_Macro"
	(<<<) file FK_Caf = file <<< "FK_Caf"
	(<<<) file FK_Unknown = file <<< "FK_Unknown"

559
560
instance <<< FunType 
where
561
	(<<<) file {ft_ident,ft_type} = file <<< ft_ident <<< "::" <<< ft_type
562

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
563
564
instance <<< FunDef
where
565
566
	(<<<) 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 <<< '.'
567
			<<< "C " <<< cb_args <<< " = " <<< cb_rhs <<< '\n'
568
//			<<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs 
569
570
	(<<<) 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 "  
571
//			<<< '[' <<< fi_free_vars <<< "]  [" <<< fi_local_vars <<< ']'
572
			<<< tb_args <<< '[' <<< fi_calls <<< ']' <<< "\n\t= " <<< tb_rhs <<< '\n'
573
//			<<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs 
574
575
576
577
	(<<<) file {fun_ident,fun_body=BackendBody body,fun_type=Yes type} = file // <<< type <<< '\n'
			<<< fun_ident <<< '.' <<< body <<< '\n'
	(<<<) file {fun_ident,fun_body=NoBody,fun_type=Yes type} = file // <<< type <<< '\n'
			<<< fun_ident <<< '.' <<< "Array function\n"
578

579
	(<<<) file {fun_ident} = file <<< fun_ident <<< "???" <<< '\n'
580

581
582
583
instance <<< FunctionBody
where
	(<<<) file (ParsedBody bodies) = file <<< bodies 
584
585
	(<<<) 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'
586
	(<<<) file (BackendBody body) = file <<< body <<< '\n'
587
	(<<<) file (Expanding vars) = file <<< "E " <<< vars 
588
	(<<<) file GeneratedBody = file <<< "Generic function\n"
589
	(<<<) file NoBody = file <<< "Array function\n"
590
	
591

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
592
593
instance <<< FunCall
where
594
	(<<<) file (FunCall fc_index fc_level)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
595
			= file <<< fc_index <<< '.' <<< fc_level
596
597
	(<<<) file (MacroCall module_index fc_index fc_level)
			= file <<< "MacroCall "<<< module_index <<<" "<<<fc_index <<< '.' <<< fc_level
598
599
	(<<<) file (DclFunCall module_index fc_index)
			= file <<< "DclFunCall "<<< module_index <<<" "<<<fc_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
600
601
602

instance <<< FreeVar
where
603
	(<<<) 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
604
605
606
607
608

instance <<< DynamicType
where
	(<<<) file {dt_uni_vars,dt_type}
		| isEmpty dt_uni_vars
609
610
			= file <<< "DynamicType" <<< dt_type
			= file <<< "DynamicType" <<< "A." <<< dt_uni_vars <<< ":" <<< dt_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
			

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)
628
629
630
631
632

instance toString TypeKind
where
	toString (KindVar _) 		= "**"
	toString KindConst			= "*"
633
	toString (KindArrow args) 	= "{" +++ (to_string args) +++ "->*}" 
634
635
636
637
638
	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
639
640
641
				
instance <<< TypeKind
where
642
643
644
645
646
647
648
649
650
651
652
	(<<<) file kind 		= file <<< (toString kind)

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

instance toString KindInfo
where
653
654
655
	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
656
	where
657
658
		withBrackets (KI_Arrow _ _) kind_str	= "(" +++ kind_str +++ ")"
		withBrackets _				kind_str	= kind_str
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
659
660
661
662

instance <<< TypeDefInfo
where
	(<<<) file {tdi_group,tdi_group_vars,tdi_cons_vars}
663
664
//		= 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
665
666
667
668
669
670

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

671
instance <<< (TypeDef a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
672
where
673
674
	(<<<) file {td_ident, td_args, td_rhs}
		= file <<< ":: " <<< td_ident <<< ' ' <<< td_args <<< td_rhs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693

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
694
	(<<<) file {fs_ident} = file <<< fs_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
695
696
697
698
699
700
701
702
703

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

704
705
706
707
instance <<< GenericClassInfo 
where
	(<<<) file {gci_kind, gci_class} = file <<< gci_kind <<< ":" <<< gci_class 

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
708
709
710
711
712
713
714
instance <<< InstanceType
where
	(<<<) file it = write_contexts it.it_context (file <<< it.it_types) 

instance <<< RhsDefsOfType
where
	(<<<) file (ConsList cons_defs) = file <<< cons_defs
715
	(<<<) file (SelectorList _ _ _ sel_defs) = file <<< sel_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
716
717
718
719
720
	(<<<) file (TypeSpec type) = file <<< type
	(<<<) file _ = file

instance <<< ParsedConstructor
where
721
	(<<<) file {pc_cons_ident,pc_arg_types} = file <<< pc_cons_ident <<< pc_arg_types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
722
723
724

instance <<< ParsedSelector
where
725
	(<<<) file {ps_field_ident,ps_field_type} = file <<< ps_field_ident <<< ps_field_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
726
727
728
729
730
731
732
733


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

instance <<< ConsDef
where
734
	(<<<) file {cons_ident,cons_type} = file <<< cons_ident <<< " :: " <<< cons_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
735
736
737

instance <<< SelectorDef
where
738
	(<<<) file {sd__ident} = file <<< sd__ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
739
740
741

instance <<< ClassDef
where
742
	(<<<) file {class_ident} = file <<< class_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
743
744
745
746
747

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

748
instance <<< (Optional a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
749
750
751
752
where
	(<<<) file (Yes x) = file <<< x
	(<<<) file No = file
	
753
instance <<< (Module a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
754
where
755
	(<<<) file {mod_ident,mod_type,mod_defs} = file <<< mod_type <<< mod_ident <<< mod_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
756

757
instance <<< (CollectedDefinitions a b) | <<< a & <<< b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
758
759
760
761
762
763
764
765
766
767
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
768
769
	(<<<) file (PD_Generic {gen_ident}) = file <<< "generic " <<< gen_ident
	(<<<) file (PD_GenericCase {gc_ident,gc_type_cons}) = file <<< gc_ident <<< "{|" <<< gc_type_cons <<< "|}"
770
	 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
771
772
773
774
	(<<<) file _ = file

instance <<< Rhs
where
775
	(<<<) file {rhs_alts,rhs_locals} = file <<< rhs_alts <<< rhs_locals <<< '\n'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
776
777
778

instance <<< OptGuardedAlts
where
779
	(<<<) file (GuardedAlts guarded_exprs def_expr) = file <<< guarded_exprs <<< def_expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
	(<<<) 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

803
instance <<< (Global a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
804
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
805
	(<<<) file {glob_object,glob_module} = file <<< glob_object <<< "M:" <<< glob_module
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
806
807
808
809
810
811
812

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

813

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
814
815
816
817
instance <<< TypeVarInfo
where
	(<<<) file TVI_Empty				= file <<< "TVI_Empty"
	(<<<) file (TVI_Type _)				= file <<< "TVI_Type"
818
	(<<<) file (TVI_TypeVar ptr)		= file <<< (ptrToInt ptr) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
819
820
	(<<<) file (TVI_Forward	_) 			= file <<< "TVI_Forward"
	(<<<) file (TVI_SignClass _ _ _) 	= file <<< "TVI_SignClass"
821
	(<<<) file (TVI_AttrAndRefCount ta rc) 	= file <<< "TVI_AttrAndRefCount " <<< ta <<< " " <<< rc
822
823
824
825
826
827
	(<<<) 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
828
	(<<<) file (TVI_PropClass _ _ _) 	= file <<< "TVI_PropClass"
829
830
	(<<<) file (TVI_TypeKind kind_info_ptr) = file <<< "TVI_TypeKind " <<< (ptrToInt kind_info_ptr)
	(<<<) file (TVI_Kind kind) 			= file <<< "TVI_Kind" <<< kind
831
	(<<<) file (TVI_Expr expr) 			= file <<< "TVI_Expr " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
832

833
834
835
836
837
838
839
840
841
842
843
844
845
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
846
847
848
849
850
851
852
853
854
855
856
857
858
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])

859
860
instance <<< CoercionPosition
where
John van Groningen's avatar
John van Groningen committed
861
862
863
864
	(<<<) 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
865
866
	(<<<) file (CP_Expression expression) = show_expression file expression
	where
867
868
869
870
871
872
		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"
873
				= show_expression file (hd app_args)
874
			= file <<< readable symb_ident
875
876
877
878
879
880
881
882
883
		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)
884
			= file <<< "argument " <<< (elem_nr + 1) <<< " of " <<< ds_arity <<< "-tuple"
885
		show_expression file (BasicExpr bv)
886
			= file <<< bv
887
		show_expression file (MatchExpr _ expr)
888
889
890
891
			= file <<< "match expression"
		show_expression file _
			= file
		
892
893
instance <<< Declaration
  where
894
	(<<<) file (Declaration { decl_ident, decl_kind })
895
		= file <<< decl_ident <<< '<' <<< decl_ident.id_info <<< '>' <<< '(' <<< decl_kind <<< ')'
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913

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"
914
915
916
917
// AA..			
	(<<<) file
		STE_Generic
			= file <<< "STE_Generic"
918
919
920
	(<<<) file
		STE_GenericCase
			= file <<< "STE_GenericCase"
921
// ..AA
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
	(<<<) 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_???"

962
963
readable :: !Ident -> String // somewhat hacky
readable {id_name}
964
	| size id_name>0 && id_name.[0]=='_'
965
966
967
968
969
970
971
972
973
974
975
976
977
		| 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)
978
979
	= id_name

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
980
981
982
983
984
985
986
987
988
989
990
991
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

992
993
994
995
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
996
997
998
999
instance == Annotation
where
	(==) a1 a2 = equal_constructor a1 a2

1000
instance == OverloadedListType