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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
/* Used for hashing identifiers */

class needs_brackets a :: a -> Bool

instance == BoundVar
where
	(==) varid1 varid2
		= varid1.var_name == varid2.var_name

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
Artem Alimarine's avatar
Artem Alimarine committed
91
92
//	(<<<) file varid = file <<< varid.tv_name 
	(<<<) file varid = file <<< varid.tv_name <<< "<" <<< varid.tv_info_ptr <<< ">"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
93
94
95

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

instance toString AttributeVar
where
Artem Alimarine's avatar
Artem Alimarine committed
101
102
	toString {av_name,av_info_ptr} = toString av_name + "[" + toString (ptrToInt av_info_ptr) + "]"
//	toString {av_name,av_info_ptr} = toString av_name
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
	toString (TA_List _ _)
		= "??? "
141
142
	toString TA_PA_BUG
		= PA_BUG "(E)" (abort "toString TA_PA_BUG")
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
143
144
145
146
147
148
149
150
151
152
153
154

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

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

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

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

167
168
169
170
171
172
173
174
175
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
176
177
178
179
180
181
182
183
instance <<< Type
where
	(<<<) file (TV varid)
		= file <<< varid
	(<<<) file (TempV tv_number)
		= file  <<< 'v' <<< tv_number <<< ' ' 
	(<<<) file (TA consid types)
		= file  <<< consid <<< " " <<< types
184
185
	(<<<) file (TAS consid types strictness)
		= file  <<< consid <<< ' ' <<< strictness <<< ' ' <<< types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
186
187
	(<<<) file (arg_type --> res_type)
		= file <<< arg_type <<< " -> " <<< res_type
188
189
190
191
192
193
//AA..		
	(<<<) file TArrow
		= file <<< "(->)"	
	(<<<) file (TArrow1 t)
		= file <<< "(->) " <<< t	
//..AA		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
194
195
196
197
	(<<<) file (type :@: types)
		= file <<< type <<< " @" <<< types
	(<<<) file (TB tb)
		= file <<< tb
198
	(<<<) file (TFA vars types)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
199
		= file <<< "A." <<< vars <<< ':' <<< types
200
	(<<<) file (TQV varid)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
		= 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
220
221
			= 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
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

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
250
	(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
251

252
253
254
255
256
257
258
259
260
261
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
262
263
instance <<< SymbIdent
where
264
265
266
	(<<<) file symb=:{symb_kind = SK_Function symb_index }
		= file <<< symb.symb_name <<<  '@' <<< symb_index
	(<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index }
267
		= file <<< symb.symb_name <<<  "[lm]@" <<< symb_index
268
	(<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index }
269
270
271
		= file <<< symb.symb_name <<<  "[g]@" <<< symb_index
	(<<<) file symb=:{symb_kind = SK_LocalDclMacroFunction symb_index }
		= file <<< symb.symb_name <<<  "[ldm]@" <<< symb_index
272
273
274
275
	(<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index }
		= file <<< symb.symb_name <<<  "[o]@" <<< symb_index
	(<<<) file symb
		= file <<< symb.symb_name 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
276
277
278

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

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


instance <<< AlgebraicPattern
where
297
298
	//(<<<) 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
299
300
301

instance <<< BasicPattern
where
302
303
	//(<<<) 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
304
305
306

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

313
314
315
316
instance <<< CheckedAlternative
where
	(<<<) file {ca_rhs} = file <<< ca_rhs

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
317
318
319
320
321
322
323
324
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}
325
326
327
328
329
		= 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
330
331
332
333

instance <<< BasicValue
where
	(<<<) file (BVI int)	= file <<< int
334
	(<<<) file (BVInt int)	= file <<< int
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
335
336
337
338
339
340
341
	(<<<) file (BVC char)	= file <<< char
	(<<<) file (BVB bool)	= file <<< bool
	(<<<) file (BVR real)	= file <<< real
	(<<<) file (BVS string)	= file <<< string
	
instance <<< Sequence
where
342
343
344
345
	(<<<) 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
346
347
348
349

instance <<< Expression
where
	(<<<) file (Var ident) = file <<< ident
Sjaak Smetsers's avatar
Sjaak Smetsers committed
350
	(<<<) file (App {app_symb, app_args, app_info_ptr})
351
352
353
354
		= case app_symb.symb_kind of
			SK_Generic _ kind 
				->  file <<< app_symb <<< kind <<< ' ' <<< app_args
			_ 	-> file <<< app_symb <<< ' ' <<< app_args
355
	(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< ") @ (" <<< a_exp <<< ')'
356
357
	(<<<) 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
358
	where
359
		write_binds x file []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
360
			= file
361
		write_binds x file [bind : binds]
362
			= write_binds x (file <<< x <<< " " <<< bind) binds
363
 	(<<<) file (Case {case_expr,case_guards,case_default=No})
364
365
		//= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards
		= file <<< "case " <<< case_expr <<< " of" <<< case_guards
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
366
	(<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr})
367
368
		//= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t->" <<< def_expr
		= file <<< "case " <<< case_expr <<< " of" <<< case_guards <<< "\n\t->" <<< def_expr
369
	(<<<) file (BasicExpr basic_value) = file <<< basic_value
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
370
371
372
373
374
375
376
377
378
379
380
381
	(<<<) 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'
*/
382
 	(<<<) file (Selection selector_kind expr selectors) = file <<< expr <<< selector_kind <<< selectors
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
383
384
385
	(<<<) 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
386
//	(<<<) file (Lambda vars expr) = file <<< '\\' <<< vars <<< " -> " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
	(<<<) file WildCard = file <<< '_'
388
	(<<<) file (MatchExpr cons expr) = file <<< cons <<< " =: " <<< expr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
389
	(<<<) file EE = file <<< "** E **"
390
	(<<<) file (NoBind _) = file <<< "** NB **"
391
392
	(<<<) 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
393
394
395
396
397
398
399
//	(<<<) 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

400
	(<<<) file (FreeVar {fv_name})         	= file <<< fv_name
401
	(<<<) file (ClassVariable info_ptr)         	= file <<< "ClassVariable " <<< info_ptr
Sjaak Smetsers's avatar
Sjaak Smetsers committed
402

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
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]
428
			= file <<< var
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
429
		write_var_ptrs file [var : vars]
430
			= write_var_ptrs (file <<< var <<< '.') vars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
431
432
433
434
435
436
437
		
		
instance <<< TypeCodeExpression
where
	(<<<) file TCE_Empty
		= file
	(<<<) file (TCE_Var info_ptr)
438
		= file <<< "TCE_Var " <<< info_ptr
439
	(<<<) file (TCE_TypeTerm info_ptr)
440
		= file <<< "TCE_TypeTerm " <<< info_ptr
441
	(<<<) file (TCE_Constructor index cons exprs)
442
		= file <<< "TCE_Constructor " <<< index <<< ' ' <<< exprs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
443
	(<<<) file (TCE_Selector selectors info_ptr)
444
445
446
447
448
449
450
451
		= 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
452

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

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

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

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

512
513
514
515
516
517
instance <<< ParsedSelectorKind
where
	(<<<) file ParsedNormalSelector			= file <<< "."
	(<<<) file (ParsedUniqueSelector False)	= file <<< "!"
	(<<<) file (ParsedUniqueSelector True)	= file <<< "!*"
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
550
551
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 <<< '_' 


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

561
562
563
564
instance <<< FunType 
where
	(<<<) file {ft_symb,ft_type} = file <<< ft_symb <<< "::" <<< ft_type

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
565
566
instance <<< FunDef
where
567
568
	(<<<) file {fun_symb,fun_body=ParsedBody bodies} = file <<< fun_symb <<< '.' <<< ' ' <<< bodies 
	(<<<) file {fun_symb,fun_body=CheckedBody {cb_args,cb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.'
569
			<<< "C " <<< cb_args <<< " = " <<< cb_rhs <<< '\n'
570
//			<<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs 
571
572
	(<<<) file {fun_symb,fun_body=TransformedBody {tb_args,tb_rhs},fun_info={fi_free_vars,fi_local_vars,fi_def_level,fi_calls}}
		= file <<< fun_symb <<< '.' <<< "T "  
573
//			<<< '[' <<< fi_free_vars <<< "]  [" <<< fi_local_vars <<< ']'
574
			<<< tb_args <<< '[' <<< fi_calls <<< ']' <<< "\n\t= " <<< tb_rhs <<< '\n'
575
//			<<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs 
576
577
	(<<<) file {fun_symb,fun_body=BackendBody body,fun_type=Yes type} = file // <<< type <<< '\n'
			<<< fun_symb <<< '.' <<< body <<< '\n'
578
579
	(<<<) file {fun_symb,fun_body=NoBody,fun_type=Yes type} = file // <<< type <<< '\n'
			<<< fun_symb <<< '.' <<< "Array function\n"
580

581
582
	(<<<) file {fun_symb} = file <<< fun_symb <<< "???" <<< '\n'

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

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

instance <<< FreeVar
where
605
	(<<<) file {fv_name,fv_info_ptr,fv_count} = file <<< fv_name <<< '.' <<< fv_count <<< '<' <<< fv_info_ptr <<< '>'
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
606
607
608
609
610

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

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)
630
631
632
633
634

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

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

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

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

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

673
instance <<< (TypeDef a) | <<< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
where
	(<<<) file {td_name, td_args, td_rhs}
		= file <<< ":: " <<< td_name <<< ' ' <<< td_args <<< td_rhs

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
	(<<<) file {fs_name} = file <<< fs_name

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

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

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

instance <<< RhsDefsOfType
where
	(<<<) file (ConsList cons_defs) = file <<< cons_defs
717
	(<<<) file (SelectorList _ _ _ sel_defs) = file <<< sel_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
	(<<<) file (TypeSpec type) = file <<< type
	(<<<) file _ = file

instance <<< ParsedConstructor
where
	(<<<) file {pc_cons_name,pc_arg_types} = file <<< pc_cons_name <<< pc_arg_types

instance <<< ParsedSelector
where
	(<<<) file {ps_field_name,ps_field_type} = file <<< ps_field_name <<< ps_field_type


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

instance <<< ConsDef
where
	(<<<) file {cons_symb,cons_type} = file <<< cons_symb <<< " :: " <<< cons_type

instance <<< SelectorDef
where
	(<<<) file {sd_symb} = file <<< sd_symb

instance <<< ClassDef
where
	(<<<) file {class_name} = file <<< class_name

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

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

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

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

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

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

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

815

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

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

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

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

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

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

994
995
996
997
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
998
999
1000
instance == Annotation
where
	(==) a1 a2 = equal_constructor a1 a2
For faster browsing, not all history is shown. View entire blame