generics1.icl

//**************************************************************************************
// Generic programming features 
//**************************************************************************************

implementation module generics1

import StdEnv
import check
from checktypes import createClassDictionaries
from transform import ::Group
import genericsupport
import compilerSwitches

//****************************************************************************************
//	tracing
//****************************************************************************************
traceGenerics context message x
	//:== traceValue context message x
	:== x



//**************************************************************************************
// Data types
//**************************************************************************************

:: FunDefs :== {#FunDef}
:: Modules :== {#CommonDefs}
:: DclModules :== {#DclModule}
:: Groups :== {!Group}
:: FunsAndGroups :== (!Index, !Index, ![FunDef], ![Group])

:: *GenericState = 
	{ gs_modules :: !*Modules
	, gs_exprh :: !*ExpressionHeap
	, gs_genh :: !*GenericHeap
	, gs_varh :: !*VarHeap
	, gs_tvarh :: !*TypeVarHeap
	, gs_avarh :: !*AttrVarHeap 
	, gs_error :: !*ErrorAdmin
	, gs_symtab :: !*SymbolTable
	, gs_dcl_modules :: !*DclModules
	, gs_td_infos :: !*TypeDefInfos
	, gs_funs :: !*{#FunDef}
	, gs_groups :: {!Group}
	// non-unique, read only
	, gs_predefs :: !PredefinedSymbols
	, gs_main_module :: !Index
	, gs_used_modules :: !NumberSet
	}


//**************************************************************************************
// Exported functions
//**************************************************************************************

convertGenerics :: 
		!Int 					// index of the main dcl module
		!NumberSet				// set of used modules
		!{#CommonDefs} 			// common definitions of all modules
		!{!Group} 				// groups of functions
		!*{# FunDef} 			// functions
		!*TypeDefInfos 			// type definition information of all modules
		!*Heaps 				// all heaps
		!*HashTable 			// needed for what creating class dictionaries
		!*PredefinedSymbols 	// predefined symbols
		!u:{# DclModule}		// dcl modules
		!*ErrorAdmin 			// to report errors
	->  ( !{#CommonDefs}		// common definitions of all modules
		, !{!Group}				// groups of functions
		, !*{# FunDef}			// function definitions
		, ![IndexRange]			// index ranges of generated functions
		, !*TypeDefInfos		// type definition infos
		, !*Heaps				// all heaps
		, !*HashTable			// needed for creating class dictinaries
		, !*PredefinedSymbols	// predefined symbols	
		, !u:{# DclModule}		// dcl modules
		, !*ErrorAdmin			// to report errors
		)
convertGenerics
		main_dcl_module_n 
		used_module_numbers
		modules 
		groups 
		funs 
		td_infos 
		heaps
		hash_table 
		u_predefs 
		dcl_modules 
		error

	//#! td_infos = td_infos ---> "************************* generic phase started ******************** "
	//#! funs = dump_funs 0 funs
	//#! dcl_modules = dump_dcl_modules 0 dcl_modules
		
	#! modules = {x \\ x <-: modules} 			// unique copy
	#! dcl_modules = { x \\ x <-: dcl_modules } 	// unique copy
	#! size_predefs = size u_predefs
	#! (predefs, u_predefs) = arrayCopyBegin u_predefs size_predefs // non-unique copy

	#! td_infos = clearTypeDefInfos td_infos
		//---> ("used module numbers ", main_dcl_module_n, numberSetToList used_module_numbers)
	#! (modules, heaps) = clearGenericDefs modules heaps

	# {hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}, hp_expression_heap} = heaps
	# gs = 
		{ gs_modules = modules
		, gs_symtab = hash_table.hte_symbol_heap
		, gs_dcl_modules = dcl_modules
		, gs_td_infos = td_infos
		, gs_exprh = hp_expression_heap	
		, gs_genh = hp_generic_heap	
		, gs_varh = hp_var_heap
		, gs_tvarh = th_vars
		, gs_avarh = th_attrs
		, gs_error = error	
		, gs_funs = funs
		, gs_groups = groups	
		, gs_predefs = predefs
		, gs_main_module = main_dcl_module_n
		, gs_used_modules = used_module_numbers
		} 

	# (generic_ranges, gs) = convert_generics gs

	#	{ 	gs_modules = modules, gs_symtab, gs_dcl_modules = dcl_modules, gs_td_infos = td_infos, 
			gs_genh = hp_generic_heap, gs_varh = hp_var_heap, gs_tvarh = th_vars, gs_avarh = th_attrs, 
			gs_exprh = hp_expression_heap,	
			gs_error = error, gs_funs = funs, gs_groups = groups,
			gs_predefs = predefs, gs_main_module = main_dcl_module_n, gs_used_modules = used_module_numbers} = gs
	#! hash_table = { hash_table & hte_symbol_heap = gs_symtab }
	#! heaps = 
		{ hp_expression_heap = hp_expression_heap
		, hp_var_heap = hp_var_heap
		, hp_generic_heap = hp_generic_heap
		, hp_type_heaps = { th_vars = th_vars, th_attrs = th_attrs }
		}	
		
	//#! funs = dump_funs 0 funs
	//#! dcl_modules = dump_dcl_modules 0 dcl_modules
	//#! error = error ---> "************************* generic phase completed ******************** "
	//| True = abort "generic phase aborted for testing\n"		
	= (modules, groups, funs, generic_ranges, td_infos, heaps, hash_table, u_predefs, dcl_modules, error)
where

	convert_generics :: !*GenericState -> (![IndexRange], !*GenericState)
	convert_generics gs		
		#! (iso_range, gs) = buildGenericRepresentations gs
		#! (ok, gs) = gs_ok gs
		| not ok = ([], gs)	
		
		#! gs = buildClasses gs			
		#! (ok, gs) = gs_ok gs
		| not ok = ([], gs)	

		#! (instance_range, gs) = convertGenericCases gs
		#! (ok, gs) = gs_ok gs
		| not ok = ([], gs)	

		#! gs = convertGenericTypeContexts gs

		= ([iso_range,instance_range], gs)

	gs_ok :: !*GenericState -> (!Bool, !*GenericState)
	gs_ok gs=:{gs_error} 
		#! ok = gs_error.ea_ok
		= (ok, {gs & gs_error = gs_error})

	dump_funs n funs 
		| n == size funs
			= funs
			#! ({fun_ident, fun_type, fun_body}, funs) = funs ! [n]
			#! funs = funs
				//---> ("icl function ", fun_ident, n, fun_type, fun_body) 
			=  dump_funs (inc n) funs
	dump_dcl_modules n dcl_modules
		| n == size dcl_modules
			= dcl_modules			
			# ({dcl_functions}, dcl_modules) = dcl_modules ! [n]				
			= dump_dcl_modules (inc n) (dump_dcl_funs 0 dcl_functions dcl_modules)
				//---> ("dcl module", n)		
	dump_dcl_funs n dcl_funs dcl_modules
		| n == size dcl_funs
			= dcl_modules
			# {ft_ident, ft_type} = dcl_funs.[n]
			= dump_dcl_funs (inc n) dcl_funs dcl_modules
				//---> ("dcl function", ft_ident, n, ft_type)


//****************************************************************************************
// clear stuff that might have been left over
// from compilation of other icl modules
//****************************************************************************************

clearTypeDefInfos td_infos
	= clear_modules 0 td_infos
where
	clear_modules n td_infos
		| n == size td_infos
			= td_infos
			#! (td_infos1, td_infos) = replace td_infos n {}
			#! td_infos1 = clear_td_infos 0 td_infos1
			#! (_, td_infos) = replace td_infos n td_infos1
			= clear_modules (inc n) td_infos 
			
	clear_td_infos n td_infos 			
		| n == size td_infos
			= td_infos
			#! (td_info, td_infos) = td_infos![n]
			#! td_infos = {td_infos & [n] = {td_info & tdi_gen_rep = No}}
			= clear_td_infos (inc n) td_infos 

clearGenericDefs modules heaps
	= clear_module 0 modules  heaps
where	
	clear_module n modules heaps
		| n == size modules
			= (modules, heaps)
			#! ({com_generic_defs}, modules) = modules![n]
			#! (com_generic_defs, heaps) = updateArraySt clear_generic_def {x\\x<-:com_generic_defs} heaps 			
			#! modules = {modules & [n].com_generic_defs = com_generic_defs}
			= clear_module (inc n) modules heaps
			
	clear_generic_def _ generic_def=:{gen_ident,gen_info_ptr} heaps=:{hp_generic_heap}
		#! (gen_info, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
		#! gen_info = 
			{ gen_info 
			& gen_cases = []
			, gen_classes = createArray 32 []
			}	
		#! hp_generic_heap = writePtr gen_info_ptr gen_info hp_generic_heap
		= (generic_def, {heaps & hp_generic_heap = hp_generic_heap})
		
//****************************************************************************************
//	generic type representation
//****************************************************************************************

// generic representation is built for each type argument of
// generic cases of the current module
buildGenericRepresentations :: !*GenericState -> (!IndexRange, !*GenericState)
buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
	#! (size_funs, gs_funs) = usize gs_funs
	#! size_groups = size gs_groups
	#! ({com_gencase_defs}, gs_modules) = gs_modules ! [gs_main_module]
	
	#! gs = { gs & gs_modules = gs_modules, gs_funs = gs_funs, gs_groups = gs_groups }			
	#! ((new_fun_index, new_group_index, new_funs, new_groups), gs) 
		= foldArraySt on_gencase com_gencase_defs ((size_funs, size_groups, [], []), gs)

	# {gs_funs, gs_groups} = gs
	#! gs_funs = arrayPlusRevList gs_funs new_funs
	#! gs_groups = arrayPlusRevList gs_groups new_groups

	#! range = {ir_from = size_funs, ir_to = new_fun_index}

	= (range, {gs & gs_funs = gs_funs, gs_groups = gs_groups})
where 

	on_gencase index 
			case_def=:{gc_type_cons=TypeConsSymb {type_index={glob_module,glob_object}, type_ident},
			 	gc_ident, gc_body=GCB_FunIndex fun_index, gc_pos} 
			(funs_and_groups, gs=:{gs_modules, gs_td_infos, gs_funs})
		#! (type_def, gs_modules) = gs_modules![glob_module].com_type_defs.[glob_object]
		#! (td_info, gs_td_infos) = gs_td_infos![glob_module, glob_object]
		#! type_def_gi = {gi_module=glob_module,gi_index=glob_object}
		#! ({fun_body}, gs_funs) = gs_funs ! [fun_index]
		#! gs = {gs & gs_modules = gs_modules, gs_td_infos = gs_td_infos, gs_funs = gs_funs}
		
		= case fun_body of
			TransformedBody _ 
				// does not need a generic representation
				-> (funs_and_groups, gs)
				
			GeneratedBody	
				// needs a generic representation
				
				-> case type_def.td_rhs of
					SynType _
						#  gs_error = reportError gc_ident gc_pos ("cannot derive a generic instance for a synonym type " +++ type_def.td_ident.id_name) gs.gs_error
						-> (funs_and_groups, {gs & gs_error = gs_error})	
					AbstractType _
						#  gs_error = reportError gc_ident gc_pos ("cannot derive a generic instance for an abstract type "  +++ type_def.td_ident.id_name) gs.gs_error
						-> (funs_and_groups, {gs & gs_error = gs_error})	
					_ 
						-> case td_info.tdi_gen_rep of
							Yes _ 
								-> (funs_and_groups, gs)
									//---> ("generic representation is already built", type_ident)
							No 
								#! (gen_type_rep, funs_and_groups, gs)
									= buildGenericTypeRep type_def_gi funs_and_groups gs
				
								#! td_info = {td_info & tdi_gen_rep = Yes gen_type_rep}
								# {gs_td_infos} = gs	
								#! gs_td_infos = {gs_td_infos & [glob_module, glob_object] = td_info} 
								# gs = {gs & gs_td_infos = gs_td_infos }
								-> (funs_and_groups, gs)					
									//---> ("build generic representation", type_ident)
	on_gencase _ _ st = st

:: ConsInfo = {ci_cons_info :: DefinedSymbol, ci_field_infos :: [DefinedSymbol]}
	
buildGenericTypeRep :: 
		!GlobalIndex 			// type def index
		!(!Index,!Index,![FunDef],![Group]) 
		!*GenericState 
	->	( !GenericTypeRep
		, !(!Index, !Index, ![FunDef], ![Group])
		, !*GenericState
		)
buildGenericTypeRep type_index funs_and_groups
		gs=:{gs_modules, gs_predefs, gs_main_module, gs_error, gs_td_infos,
			gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
		
	# heaps = 
		{ hp_expression_heap = gs_exprh
		, hp_var_heap = gs_varh
		, hp_generic_heap = gs_genh
		, hp_type_heaps = { th_vars = gs_tvarh, th_attrs = gs_avarh }
		}	
		
	# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]

	# (type_info, cons_infos, funs_and_groups, gs_modules, heaps, gs_error) 
		= buildTypeDefInfo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups gs_modules heaps gs_error

	# (atype, (gs_modules, gs_td_infos, heaps, gs_error)) 
		= buildStructType type_index type_info cons_infos gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
	
	# (from_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionFrom type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error

	# (to_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionTo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error

	# (iso_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionIso type_def from_fun_ds to_fun_ds gs_main_module gs_predefs funs_and_groups heaps gs_error

	# {hp_expression_heap, hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}} = heaps
	# gs =
		{ gs 
		& gs_modules = gs_modules
		, gs_td_infos = gs_td_infos
		, gs_error = gs_error
		, gs_avarh = th_attrs
		, gs_tvarh = th_vars
		, gs_varh = hp_var_heap
		, gs_genh = hp_generic_heap
		, gs_exprh = hp_expression_heap
		}
	= ({gtr_type=atype,gtr_iso=iso_fun_ds}, funs_and_groups, gs)
		//---> ("buildGenericTypeRep", type_def.td_ident, atype)
	
//========================================================================================
//	the structure type
//========================================================================================

convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbols !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) 
	-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToGenTypeStruct ident pos predefs type st
	= convert type st	
where	
	convert {at_type=TA type_symb args, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=TAS type_symb args _, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=(CV tv) :@: args} st
		#! (args, st) = mapSt convert args st
		= (GTSAppVar tv args, st)  

	convert {at_type=x --> y} st
		#! (x, st) = convert x st
		#! (y, st) = convert y st
		//= (GTSAppCons (KindArrow [KindConst, KindConst]) [x,y], st)  
		= (GTSArrow x y, st)  
		
	convert {at_type=TV tv} st
		= (GTSVar tv, st)  
	convert {at_type=TB _} st
		= (GTSAppCons KindConst [], st)  
	convert {at_type=type} (modules, td_infos, heaps, error) 
		# error = reportError ident pos ("can not build generic representation for this type", type) error
		= (GTSE, (modules, td_infos, heaps, error))

	convert_type_app {type_index} attr args (modules, td_infos, heaps, error)	
		# (type_def, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
		= case type_def.td_rhs of 
			SynType atype
				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps 
				-> convert {at_type = expanded_type, at_attribute = attr} 
					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
			_ 	
				#! {pds_module, pds_def} = predefs.[PD_UnboxedArrayType]
				| 	type_index.glob_module == pds_module
					&& type_index.glob_object == pds_def
					&& (case args of [{at_type=TB _}] -> True; _ -> False)
					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
				| otherwise	
					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
					#! (args, st) = mapSt  convert args (modules, td_infos, heaps, error)
					-> (GTSAppCons kind args, st)  

// the structure type of a genric type can often be simplified
// because bimaps for types not containing generic variables are indentity bimaps
simplifyStructOfGenType :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplifyStructOfGenType gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} 
	| True
		#! th_vars = foldSt mark_type_var gvars th_vars
		#! (type, th_vars) = simplify type th_vars
		#! th_vars = foldSt clear_type_var gvars th_vars 
		= (type, { heaps & hp_type_heaps = { hp_type_heaps & th_vars = th_vars}})
	| otherwise
		= (type, heaps)			
where
	simplify t=:(GTSAppCons KindConst [])  st
		= (t, st)
	simplify (GTSAppCons kind=:(KindArrow kinds) args) st
		# formal_arity = length kinds
		# actual_arity = length args
		# (contains_gen_vars, st) = occurs_list args st
		| formal_arity == actual_arity && not contains_gen_vars
			= (GTSAppCons KindConst [], st)
		| otherwise
			# (args, st) = mapSt simplify args st
			=(GTSAppCons kind args, st)
	simplify (GTSArrow x y) st
		# (x, st) = simplify x st
		# (y, st) = simplify y st
		= (GTSArrow x y, st)		
	simplify (GTSAppVar tv args) st
		# (args, st) = mapSt simplify args st
		= (GTSAppVar tv args, st)	
	simplify t=:(GTSVar tv) st
		= (t, st)
	simplify t st 
		= abort "invalid generic type structure\n"
			//---> ("invalid generic type structure", t)
		
	occurs (GTSAppCons _ args) st 	= occurs_list args st
	occurs (GTSAppVar tv args) st 	= occurs_list [GTSVar tv: args] st		
	occurs (GTSVar tv) st			= type_var_occurs tv st
	occurs (GTSArrow x y) st 		= occurs_list [x,y] st
	occurs (GTSCons _ arg) st 		= occurs arg st	
	occurs (GTSField _ arg) st 		= occurs arg st	
	occurs (GTSObject _ arg) st 	= occurs arg st	
	occurs GTSE st 					= (False, st)

	occurs_list [] st = (False, st)
	occurs_list [x:xs] st 
		# (x, st) = occurs x st
		# (xs, st) = occurs_list xs st
		= (x || xs, st)   

	type_var_occurs tv th_vars
		# (tv_info, th_vars) = readPtr tv.tv_info_ptr th_vars
		= case tv_info of
			TVI_Empty = (False, th_vars) 
			TVI_Used = (True, th_vars)
			_ = abort "invalid type var info"	
				---> ("type var is not empty", tv, tv_info)		

	mark_type_var tv=:{tv_info_ptr} th_vars 
		# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
		= case tv_info of
			TVI_Empty = writePtr tv_info_ptr TVI_Used th_vars 
			_ = abort "type var is not empty"
				--->  ("type var is not empty", tv, tv_info)

	clear_type_var {tv_info_ptr} th_vars
		= writePtr tv_info_ptr TVI_Empty th_vars 

	
buildStructType ::
		!GlobalIndex				// type def global index
		!DefinedSymbol 				// type_info
		![ConsInfo]					// constructor and field info symbols
		!PredefinedSymbols
		(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
	-> 	( !GenTypeStruct			// the structure type
		, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
		)
buildStructType {gi_module,gi_index} type_info cons_infos predefs (modules, td_infos, heaps, error)
	# (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index]	
	//# (common_defs, modules) = modules ! [gi_module]	
	= build_type type_def type_info cons_infos (modules, td_infos, heaps, error)	
		//---> ("buildStructureType", td_ident, atype)	
where
	build_type {td_rhs=AlgType alts, td_ident, td_pos} type_info cons_infos st
		# (cons_args, st) = zipWithSt (build_alt td_ident td_pos) alts cons_infos st
		# type = build_sum_type cons_args
		# type = SwitchGenericInfo (GTSObject type_info type) type
		= (type, st) 

	build_type 
			{td_rhs=RecordType {rt_constructor}, td_ident, td_pos} 
			type_info  [{ci_cons_info, ci_field_infos}] 
			(modules, td_infos, heaps, error)		
		# ({cons_type={st_args}}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]	
		# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
		
		# args = SwitchGenericInfo [GTSField fi arg \\ arg <- args & fi <- ci_field_infos] args
			
		# prod_type = build_prod_type args		
		# type = SwitchGenericInfo (GTSCons ci_cons_info prod_type) prod_type
		# type = SwitchGenericInfo (GTSObject type_info type) type
		= (type, st)		

/*		
	build_type {td_rhs=SynType type,td_ident, td_pos} cons_infos common_defs st
		= convertATypeToGenTypeStruct td_ident td_pos type st
*/
	build_type {td_rhs=SynType type,td_ident, td_pos} type_info cons_infos (modules, td_infos, heaps, error)
		# error = reportError td_ident td_pos "cannot build a generic representation of a synonym type" error
		= (GTSE, (modules, td_infos, heaps, error))
	build_type td=:{td_rhs=(AbstractType _),td_ident, td_arity, td_args, td_pos} type_info cdis (modules, td_infos, heaps, error)
		# error = reportError td_ident td_pos "cannot build a generic representation of an abstract type" error
		= (GTSE, (modules, td_infos, heaps, error))
		
	build_alt td_ident td_pos cons_def_sym=:{ds_index} {ci_cons_info} (modules, td_infos, heaps, error)
		# ({cons_type={st_args}}, modules) = modules![gi_module].com_cons_defs.[ds_index]	
		# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)	
		# prod_type = build_prod_type args		
		# type = SwitchGenericInfo (GTSCons ci_cons_info prod_type) prod_type		
		= (type, st)		

	build_prod_type :: [GenTypeStruct] -> GenTypeStruct
	build_prod_type types 
		= listToBin build_pair build_unit types	
	where
		build_pair x y = GTSAppCons (KindArrow [KindConst, KindConst]) [x, y]	
		build_unit = GTSAppCons KindConst []	
		
	build_sum_type :: [GenTypeStruct] -> GenTypeStruct
	build_sum_type types
		= listToBin build_either build_void types
	where
		build_either x y = GTSAppCons (KindArrow [KindConst, KindConst]) [x, y]	
		build_void = abort "sanity check: no alternatives in a type\n"		
		
// build a product of types
buildProductType :: ![AType] !PredefinedSymbols -> AType
buildProductType types predefs 
	= listToBin build_pair build_unit types
where
	build_pair x y = buildPredefTypeApp PD_TypePAIR [x, y] predefs	
	build_unit  = buildPredefTypeApp PD_TypeUNIT [] predefs

// build a sum of types		
buildSumType :: ![AType] !PredefinedSymbols -> AType
buildSumType types predefs 
	= listToBin build_either build_void types
where
	build_either x y = buildPredefTypeApp PD_TypeEITHER [x, y] predefs	
	build_void  = abort "sum of zero types\n"

// build a binary representation of a list
listToBin :: (a a -> a) a [a] -> a 
listToBin bin tip [] = tip
listToBin bin tip [x] = x
listToBin bin tip xs
	# (l,r) = splitAt ((length xs) / 2) xs
	= bin (listToBin bin tip l) (listToBin bin tip r)

// build application of a predefined type constructor 
buildPredefTypeApp :: !Int [AType] !PredefinedSymbols -> AType
buildPredefTypeApp predef_index args predefs
	# {pds_module, pds_def} = predefs.[predef_index]
	# pds_ident = predefined_idents.[predef_index]
	# global_index = {glob_module = pds_module, glob_object = pds_def}
	# type_symb = MakeTypeSymbIdent global_index pds_ident (length args) 		  
	= makeAType (TA type_symb args) TA_Multi


//========================================================================================
//	build type infos
//========================================================================================
buildTypeDefInfo :: 
		!Index 				// type def module
		!CheckedTypeDef		// the type definition
		!Index				// icl module
		!PredefinedSymbols		
		!FunsAndGroups
		!*Modules
		!*Heaps
		!*ErrorAdmin
	-> 	( DefinedSymbol	// type info
		, ![ConsInfo]
		, !FunsAndGroups
		, !*Modules
		, !*Heaps
		, !*ErrorAdmin
		)
buildTypeDefInfo td_module td=:{td_rhs = AlgType alts} main_module_index predefs funs_and_groups modules heaps error
	= buildTypeDefInfo2 td_module td alts [] main_module_index predefs funs_and_groups modules heaps error

buildTypeDefInfo td_module td=:{td_rhs=RecordType {rt_constructor, rt_fields}} main_module_index predefs funs_and_groups modules heaps error
	= buildTypeDefInfo2 td_module td [rt_constructor] [x\\x<-:rt_fields] main_module_index predefs funs_and_groups modules heaps error

buildTypeDefInfo td_module td=:{td_rhs = SynType type, td_ident, td_pos} main_module_index predefs funs_and_groups modules heaps error
	# error = reportError td_ident td_pos "cannot build constructor uinformation for a synonym type" error
	= buildTypeDefInfo2 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error

buildTypeDefInfo td_module td=:{td_rhs = AbstractType _, td_ident, td_pos} main_module_index predefs funs_and_groups modules heaps error
	# error = reportError td_ident td_pos "cannot build constructor uinformation for an abstract type" error
	= buildTypeDefInfo2 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error

buildTypeDefInfo2 td_module td alts fields main_module_index predefs funs_and_groups modules heaps error
	= SwitchGenericInfo 
		(buildTypeDefInfo1 td_module td alts fields main_module_index predefs funs_and_groups modules heaps error) 
		(dummy, funs_and_groups, modules, heaps, error) 
where
	dummy_ds = {ds_index = -1, ds_arity = 0, ds_ident = makeIdent "<dummy_generic_info>"} 
	dummy = (dummy_ds, repeatn (length alts) dummy_ds)

buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module_index predefs (fun_index, group_index, funs, groups) modules heaps error

	# num_conses = length alts
	# num_fields = length fields
	# new_group_index = inc group_index

	# type_def_dsc_index = fun_index
	# first_cons_dsc_index = fun_index + 1
	# cons_dsc_indexes = [first_cons_dsc_index .. first_cons_dsc_index + num_conses - 1]
	# first_field_dsc_index = first_cons_dsc_index + num_conses
	# field_dsc_indexes = [first_field_dsc_index .. first_field_dsc_index + num_fields - 1]
	# new_fun_index = first_field_dsc_index + num_fields

	# group = {group_members = [fun_index .. new_fun_index - 1]}
	# new_groups = [group:groups]
	
	# type_def_dsc_ds = {ds_arity=0, ds_ident=makeIdent("tdi_"+++td_ident.id_name), ds_index=type_def_dsc_index}
	# cons_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent("cdi_"+++ds_ident.id_name), ds_index=i} \\ 
		{ds_ident} <- alts & i <- cons_dsc_indexes]
	# field_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent("fdi_"+++fs_ident.id_name), ds_index=i} \\ 
		{fs_ident} <- fields & i <- field_dsc_indexes]
	
	# (type_def_dsc_fun, heaps) = build_type_def_dsc group_index cons_dsc_dss type_def_dsc_ds heaps	
	
	# (cons_dsc_funs, (modules, heaps)) = zipWithSt (build_cons_dsc group_index type_def_dsc_ds field_dsc_dss) cons_dsc_dss alts (modules, heaps) 
	
	# (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index (hd cons_dsc_dss)) field_dsc_dss fields (modules, heaps)
	 
	// NOTE: reverse order (new functions are added at the head) 
	# new_funs = (reverse field_dsc_funs) ++ (reverse cons_dsc_funs) ++ [type_def_dsc_fun] ++ funs 
	
	# funs_and_groups = (new_fun_index, new_group_index, new_funs, new_groups)

	# (type_info_ds, (funs_and_groups, heaps)) 
		= build_type_info type_def_dsc_ds (funs_and_groups, heaps)
	
	# (cons_info_dss, (funs_and_groups, heaps)) 
		= mapSt build_cons_info cons_dsc_dss (funs_and_groups, heaps)

	# (field_info_dss, (funs_and_groups, heaps)) 
		= mapSt build_field_info field_dsc_dss (funs_and_groups, heaps)

	# cons_infos = case (cons_info_dss, field_info_dss) of
		([cons_info_ds], field_infos) -> [{ci_cons_info = cons_info_ds, ci_field_infos = field_infos}] 	 
		(cons_info_dss, []) -> [{ci_cons_info=x,ci_field_infos=[]}\\x<-cons_info_dss]
		_ -> abort "generics.icl sanity check: fields in non-record type\n"


	= (type_info_ds, cons_infos, funs_and_groups, modules, heaps, error)
where

	build_type_def_dsc group_index cons_info_dss {ds_index, ds_ident}  heaps	
		# td_name_expr = makeStringExpr td_ident.id_name
		# td_arity_expr = makeIntExpr td_arity
		# num_conses_expr = makeIntExpr (length alts)
		# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
		# (td_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps
		
		# (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor 
			[ td_name_expr
			, td_arity_expr
			, num_conses_expr 
			, td_conses_expr
			// TODO: module_name_expr
			] 
			predefs heaps	
						
		# fun = makeFunction ds_ident ds_index group_index [] body_expr No main_module_index td_pos		
		= (fun, heaps)

	build_cons_dsc group_index type_def_info_ds field_dsc_dss cons_info_ds cons_ds (modules, heaps)
		# ({cons_ident, cons_type, cons_priority,cons_index}, modules)	
			= modules! [td_module].com_cons_defs.[cons_ds.ds_index]  		
		# name_expr 			 = makeStringExpr cons_ident.id_name
		# arity_expr 			 = makeIntExpr cons_type.st_arity
		# (prio_expr, heaps)	 = make_prio_expr cons_priority heaps
		# (type_def_expr, heaps) = buildFunApp main_module_index type_def_info_ds [] heaps
		# (type_expr, heaps) 	 = make_type_expr cons_type heaps 			
		# (field_exprs, heaps)   = mapSt (\x st->buildFunApp main_module_index x [] st) field_dsc_dss heaps
		# (fields_expr, heaps)   =  makeListExpr field_exprs predefs heaps 
		# cons_index_expr		 = makeIntExpr cons_index
		# (body_expr, heaps) 
			= buildPredefConsApp PD_CGenericConsDescriptor 
				[ name_expr 
				, arity_expr
				, prio_expr
				, type_def_expr
				, type_expr
				, fields_expr 
				, cons_index_expr
				]  
				predefs heaps

		# fun = makeFunction cons_info_ds.ds_ident cons_info_ds.ds_index group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))
	where
		make_prio_expr NoPrio heaps
			= buildPredefConsApp PD_CGenConsNoPrio [] predefs heaps
		make_prio_expr (Prio assoc prio) heaps
			# assoc_predef = case assoc of
				NoAssoc 	-> PD_CGenConsAssocNone 
				LeftAssoc 	-> PD_CGenConsAssocLeft
				RightAssoc 	-> PD_CGenConsAssocRight
			# (assoc_expr, heaps) = buildPredefConsApp assoc_predef [] predefs heaps 	
			# prio_expr = makeIntExpr prio		
			= buildPredefConsApp PD_CGenConsPrio [assoc_expr, prio_expr] predefs heaps 

		make_type_expr {st_args, st_result} heaps		
			# (arg_exprs, heaps) = mapSt make_expr1 st_args heaps		
			# (result_expr, heaps) = make_expr1 st_result heaps
			= curry arg_exprs result_expr heaps  
		where
		
			curry [] result_expr heaps 
				= (result_expr, heaps)
			curry [x:xs] result_expr heaps
				# (y, heaps) = curry xs result_expr heaps
				= make_arrow x y heaps
		
			make_expr1 :: !AType !*Heaps -> (!Expression, !*Heaps)
			make_expr1 {at_type} heaps = make_expr at_type heaps
		
			make_expr :: !Type !*Heaps -> (!Expression, !*Heaps)
			make_expr (TA type_symb arg_types) heaps
				# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
				# (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps 
				= make_apps type_cons arg_exprs heaps
			make_expr (TAS type_symb arg_types _) heaps
				# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
				# (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps 
				= make_apps type_cons arg_exprs heaps
			make_expr (x --> y) heaps
				# (x, heaps) = make_expr1 x heaps
				# (y, heaps) = make_expr1 y heaps				
				= make_arrow x y heaps
			make_expr TArrow heaps 
				= make_type_cons "(->)" heaps
			make_expr (TArrow1 type) heaps
				# (arg_expr, heaps) = make_expr1 type heaps 
				# (arrow_expr, heaps) = make_type_cons "(->)" heaps
				= make_app arrow_expr arg_expr heaps
			make_expr (CV {tv_ident} :@: arg_types) heaps
				# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
				# (tv_expr, heaps) = make_type_var tv_ident.id_name heaps					
				= make_apps tv_expr arg_exprs heaps
			make_expr (TB bt) heaps
				= make_type_cons (toString bt) heaps	
			make_expr (TV {tv_ident}) heaps 
				= make_type_var tv_ident.id_name heaps 
			make_expr (GTV {tv_ident}) heaps 
				= make_type_var tv_ident.id_name heaps 
			make_expr (TQV {tv_ident}) heaps 
				= make_type_var tv_ident.id_name heaps
			make_expr TE heaps
				= make_type_cons "<error>" heaps	 
			make_expr _ heaps 
				= abort "type does not match\n"
		
			make_apps x [] heaps 
				= (x, heaps)
			make_apps x [y:ys] heaps
				# (z, heaps) = make_app x y heaps	
				= make_apps z ys heaps 
		
			make_type_cons name heaps
				# name_expr = makeStringExpr name
				= buildPredefConsApp PD_CGenTypeCons [name_expr] predefs heaps
			make_type_var name heaps
				# name_expr = makeStringExpr name
				= buildPredefConsApp PD_CGenTypeVar [name_expr] predefs heaps									
			make_arrow x y heaps = buildPredefConsApp PD_CGenTypeArrow [x, y] predefs heaps
			make_app x y heaps = buildPredefConsApp PD_CGenTypeApp [x, y] predefs heaps 	 

	build_field_dsc group_index cons_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
		# name_expr = makeStringExpr fs_ident.id_name
		# ({sd_field_nr}, modules)	
			= modules! [td_module].com_selector_defs.[fs_index]  		
		# index_expr = makeIntExpr sd_field_nr
		# (cons_expr, heaps) = buildFunApp main_module_index cons_dsc_ds [] heaps				
		# (body_expr, heaps) 
			= buildPredefConsApp PD_CGenericFieldDescriptor 
				[ name_expr 
				, index_expr
				, cons_expr
				]  
				predefs heaps
		# fun = makeFunction field_dsc_ds.ds_ident field_dsc_ds.ds_index group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))
		
	build_cons_info cons_dsc_ds (funs_and_groups, heaps)
		# ident = makeIdent ("g"+++cons_dsc_ds.ds_ident.id_name)	

		# (cons_dsc_expr, heaps) = buildFunApp main_module_index cons_dsc_ds [] heaps

		# (body_expr, heaps) 
			= buildPredefConsApp PD_GenericConsInfo [cons_dsc_expr] predefs heaps		

		# (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
		= (def_sym, (funs_and_groups, heaps))

	build_field_info field_dsc_ds (funs_and_groups, heaps)
		# ident = makeIdent ("g"+++field_dsc_ds.ds_ident.id_name)	

		# (field_dsc_expr, heaps) = buildFunApp main_module_index field_dsc_ds [] heaps

		# (body_expr, heaps) 
			= buildPredefConsApp PD_GenericFieldInfo [field_dsc_expr] predefs heaps		

		# (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
		= (def_sym, (funs_and_groups, heaps))

	build_type_info type_dsc_ds (funs_and_groups, heaps)
		# ident = makeIdent ("g"+++type_dsc_ds.ds_ident.id_name)	

		# (type_dsc_expr, heaps) = buildFunApp main_module_index type_dsc_ds [] heaps

		# (body_expr, heaps) 
			= buildPredefConsApp PD_GenericTypeInfo [type_dsc_expr] predefs heaps		

		# (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
		= (def_sym, (funs_and_groups, heaps))



//========================================================================================
//	conversions functions
//========================================================================================

// buildConversionIso
buildConversionIso :: 
		!CheckedTypeDef		// the type definition
		!DefinedSymbol		// from fun
		!DefinedSymbol	 	// to fun
		!Index				// main module
		!PredefinedSymbols		
		(!Index, !Index, ![FunDef], ![Group])
		!*Heaps
		!*ErrorAdmin
	-> 	( !DefinedSymbol
		, (!Index, !Index, ![FunDef], ![Group])
		, !*Heaps
		, !*ErrorAdmin
		)
buildConversionIso 
		type_def=:{td_ident, td_pos}
		from_fun 
		to_fun
		main_dcl_module_n
		predefs
		funs_and_groups
		heaps 
		error
	#! (from_expr, heaps) 	= buildFunApp main_dcl_module_n from_fun [] heaps
	#! (to_expr, heaps) 	= buildFunApp main_dcl_module_n to_fun [] heaps	
	#! (iso_expr, heaps) 	= build_iso to_expr from_expr heaps
	
	#! ident = makeIdent ("iso" +++ td_ident.id_name)
	#! (def_sym, funs_and_groups) = buildFunAndGroup ident [] iso_expr No main_dcl_module_n td_pos funs_and_groups
	= (def_sym, funs_and_groups, heaps, error)
		//---> ("buildConversionIso", td_ident, let (_,_,fs,_) = funs_and_groups in hd fs)
where
	build_iso to_expr from_expr heaps 
		= buildPredefConsApp PD_ConsBimap [to_expr, from_expr] predefs heaps	
		
// conversion from type to generic
buildConversionTo ::
		!Index				// type def module
		!CheckedTypeDef 	// the type def
		!Index 				// main module
		!PredefinedSymbols
		!(!Index, !Index, ![FunDef], ![Group])
		!*Heaps	
		!*ErrorAdmin
	-> 	( !DefinedSymbol
		, (!Index, !Index, ![FunDef], ![Group])
		, !*Heaps
		, !*ErrorAdmin	
		)
buildConversionTo		
		type_def_mod 
		type_def=:{td_rhs, td_ident, td_index, td_pos} 
		main_module_index
		predefs
		funs_and_groups
		heaps
		error
	# (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps 
	# (body_expr, heaps, error) = 
		build_expr_for_type_rhs type_def_mod td_index td_rhs arg_expr heaps error
	# fun_name = makeIdent ("fromGenericTo" +++ td_ident.id_name)
	| not error.ea_ok
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)	
			//---> ("buildConversionTo failed", td_ident)
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)
			//---> ("buildConversionTo", td_ident, let (_,_,fs,_) = funs_and_groups in hd fs)
where
	// build conversion for type rhs
	build_expr_for_type_rhs :: 
			!Int 				// type def module
			!Int 				// type def index 
			!TypeRhs			// type def rhs 
			!Expression			// expression of the function argument variable   
			!*Heaps 
			!*ErrorAdmin
		-> 	( !Expression		// generated expression
			, !*Heaps	// state
			, !*ErrorAdmin
			)
 	build_expr_for_type_rhs type_def_mod type_def_index (AlgType def_symbols) arg_expr heaps error
		= build_expr_for_conses False type_def_mod type_def_index def_symbols arg_expr heaps error
	build_expr_for_type_rhs type_def_mod type_def_index (RecordType {rt_constructor}) arg_expr heaps error		
		= build_expr_for_conses True type_def_mod type_def_index [rt_constructor] arg_expr  heaps error
	build_expr_for_type_rhs type_def_mod type_def_index (AbstractType _) arg_expr  heaps error
		#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" error
		= (EE, heaps, error)
	build_expr_for_type_rhs type_def_mod type_def_index (SynType _) arg_expr  heaps error
		#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" error
		= (EE, heaps, error)
	
	// build conversion for constructors of a type def 	
	build_expr_for_conses is_record type_def_mod type_def_index cons_def_syms arg_expr heaps error
		# (case_alts, heaps, error) = 
			build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms  heaps error
		# case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts
		# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
		= (case_expr, heaps, error)	
			//---> (free_vars, case_expr)		
	
	// build conversions for constructors 	
	build_exprs_for_conses :: !Bool !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
		-> ([AlgebraicPattern], !*Heaps, !*ErrorAdmin)
	build_exprs_for_conses is_record i n type_def_mod [] heaps error = ([], heaps, error) 	
	build_exprs_for_conses is_record i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
		#! (alt, heaps, error) = build_expr_for_cons is_record i n type_def_mod cons_def_sym heaps error
		#! (alts, heaps, error) =  build_exprs_for_conses is_record (i+1) n type_def_mod cons_def_syms heaps error 		
		= ([alt:alts], heaps, error)
					
	// build conversion for a constructor	
	build_expr_for_cons :: !Bool !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin 
		-> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
	build_expr_for_cons is_record i n type_def_mod cons_def_sym=:{ds_ident, ds_arity} heaps error	
		#! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]]
		#! (var_exprs, vars, heaps) = buildVarExprs names heaps 

		#! (arg_exprs, heaps) = build_fields (SwitchGenericInfo True False && is_record) var_exprs heaps
			with
				build_fields False var_exprs heaps = (var_exprs, heaps)
				build_fields True var_exprs heaps = mapSt build_field var_exprs heaps
				build_field var_expr heaps = buildPredefConsApp PD_ConsFIELD [var_expr] predefs heaps 

		#! (expr, heaps) = build_prod arg_exprs predefs heaps
		#! (expr, heaps) = SwitchGenericInfo (build_cons expr heaps) (expr, heaps)
			with 
				build_cons expr heaps = buildPredefConsApp PD_ConsCONS [expr] predefs heaps						
		#! (expr, heaps) = build_sum i n expr predefs heaps
				
		#! (expr, heaps) = SwitchGenericInfo (build_object expr heaps) (expr, heaps)
			with 
				build_object expr heaps = buildPredefConsApp PD_ConsOBJECT [expr] predefs heaps						
						
		#! alg_pattern = {
			ap_symbol = {glob_module = type_def_mod, glob_object = cons_def_sym},
			ap_vars = vars,
			ap_expr = expr,
			ap_position = NoPos
			}
		= (alg_pattern, heaps, error)	
	
	
	build_sum :: !Int !Int !Expression !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
	build_sum i n expr predefs heaps
		| n == 0 	= abort "build sum of zero elements\n"
		| i >= n	= abort "error building sum"
		| n == 1 	= (expr, heaps)
		| i < (n/2) 
			# (expr, heaps) = build_sum i (n/2) expr predefs heaps
			= build_left expr heaps
		| otherwise
			# (expr, heaps) = build_sum (i - (n/2)) (n - (n/2)) expr predefs heaps
			= build_right expr heaps
	where
		build_left x heaps = buildPredefConsApp PD_ConsLEFT [x] predefs heaps
		build_right x heaps = buildPredefConsApp PD_ConsRIGHT [x] predefs heaps
				
	build_prod :: ![Expression] !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
	build_prod [] predefs heaps = build_unit heaps
	where
		build_unit heaps = buildPredefConsApp PD_ConsUNIT [] predefs heaps 	
	build_prod [expr] predefs heaps = (expr, heaps)
	build_prod exprs predefs heaps
		# (lexprs, rexprs) = splitAt ((length exprs)/2) exprs  
		# (lexpr, heaps) = build_prod lexprs predefs heaps
		# (rexpr, heaps) = build_prod rexprs predefs heaps
		= build_pair lexpr rexpr heaps
	where
		build_pair x y heaps = buildPredefConsApp PD_ConsPAIR [x, y] predefs heaps
			
buildConversionFrom	::	
		!Index				// type def module
		!CheckedTypeDef 	// the type def
		!Index 				// main module
		!PredefinedSymbols
		!(!Index, !Index, ![FunDef], ![Group])
		!*Heaps	
		!*ErrorAdmin
	-> 	( !DefinedSymbol
		, (!Index, !Index, ![FunDef], ![Group])
		, !*Heaps
		, !*ErrorAdmin	
		)
buildConversionFrom		
		type_def_mod 
		type_def=:{td_rhs, td_ident, td_index, td_pos} 
		main_module_index
		predefs
		funs_and_groups
		heaps
		error
	# (body_expr, arg_var, heaps, error) = 
		build_expr_for_type_rhs type_def_mod td_rhs heaps error
	# fun_name = makeIdent ("toGenericFrom" +++ td_ident.id_name)
	| not error.ea_ok
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)	
			//---> ("buildConversionFrom failed", td_ident)
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)
			//---> ("buildConversionFrom", td_ident, let (_,_,fs,_) = funs_and_groups in hd fs)
where
	// build expression for type def rhs
	build_expr_for_type_rhs :: 
			!Index				// type def module
			!TypeRhs			// type rhs
			!*Heaps
			!*ErrorAdmin	
		-> 	( !Expression		// body expresssion
			, !FreeVar
			, !*Heaps
			, !*ErrorAdmin
			)		
	build_expr_for_type_rhs type_def_mod (AlgType def_symbols) heaps error
		#! (expr, var, heaps, error) = build_sum False type_def_mod def_symbols heaps error
		#! (expr, var, heaps) = SwitchGenericInfo 
			(build_case_object var expr heaps)
			(expr, var, heaps)
		= (expr, var, heaps, error)
	build_expr_for_type_rhs type_def_mod (RecordType {rt_constructor}) heaps error				
		# (expr, var, heaps, error) = build_sum True type_def_mod [rt_constructor] heaps	error
		#! (expr, var, heaps) = SwitchGenericInfo 
			(build_case_object var expr heaps)
			(expr, var, heaps)
		= (expr, var, heaps, error)
		
	build_expr_for_type_rhs type_def_mod (AbstractType _) heaps error
		#! error = reportError td_ident td_pos "cannot build isomorphisms for an abstract type" error
		# dummy_fv = {fv_def_level=(-1), fv_count=0, fv_ident=makeIdent "dummy", fv_info_ptr=nilPtr}
		= (EE, dummy_fv, heaps, error)
	build_expr_for_type_rhs type_def_mod (SynType _) heaps error
		#! error = reportError td_ident td_pos "cannot build isomorphisms for a synonym type" error
		# dummy_fv = {fv_def_level=(-1), fv_count=0, fv_ident=makeIdent "dummy", fv_info_ptr=nilPtr}
		= (EE, dummy_fv, heaps, error)
	
	// build expression for sums
	build_sum ::
			!Bool				// is record 
			!Index 
			![DefinedSymbol] 
			!*Heaps 
			!*ErrorAdmin
		-> 	( !Expression
			, !FreeVar			// top variable
			, !*Heaps
			, !*ErrorAdmin
			)
	build_sum is_record type_def_mod [] heaps error
		= abort "algebraic type with no constructors!\n"
	build_sum is_record type_def_mod [def_symbol] heaps error
		#! (cons_app_expr, cons_arg_vars, heaps) = build_cons_app type_def_mod def_symbol heaps
		#! (prod_expr, var, heaps) = build_prod is_record cons_app_expr cons_arg_vars heaps 
		#! (alt_expr, var, heaps) = SwitchGenericInfo 
			(build_case_cons var prod_expr heaps)
			(prod_expr, var, heaps)
		= (alt_expr, var, heaps, error)
	build_sum is_record type_def_mod def_symbols heaps error
		#! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols
	
		#! (left_expr, left_var, heaps, error) 
			= build_sum is_record type_def_mod left_def_syms heaps error

		#! (right_expr, right_var, heaps, error) 
			= build_sum is_record type_def_mod right_def_syms heaps error
	
		#! (case_expr, var, heaps) = 
			build_case_either left_var left_expr right_var right_expr heaps
		= (case_expr, var, heaps, error)
	
	// build expression for products
	build_prod :: 
			!Bool							// is record
			!Expression   					// result of the case on product
			![FreeVar] 						// list of variables of the constructor pattern
			!*Heaps
		-> 	( !Expression					// generated product
			, !FreeVar						// top variable
			, !*Heaps
			)
	build_prod is_record expr [] heaps
		= build_case_unit expr heaps	
	build_prod is_record expr [cons_arg_var] heaps
	
		#! (arg_expr, var, heaps) = SwitchGenericInfo 
			(case is_record of True -> build_case_field cons_arg_var expr heaps; False -> (expr, cons_arg_var, heaps))
			(expr, cons_arg_var, heaps)
		
		= (arg_expr, var, heaps)	
	build_prod is_record expr cons_arg_vars heaps
		#! (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars		 
		#! (expr, left_var, heaps) = build_prod is_record expr left_vars heaps
		#! (expr, right_var, heaps) = build_prod is_record expr right_vars heaps		
		#! (case_expr, var, heaps) = build_case_pair left_var right_var expr heaps		
		= (case_expr, var, heaps) 
	
	// build constructor application expression
	build_cons_app :: !Index !DefinedSymbol !*Heaps 
		-> (!Expression, ![FreeVar], !*Heaps)
	build_cons_app cons_mod def_symbol=:{ds_arity} heaps
		#! names = ["x"  +++ toString k \\ k <- [1..ds_arity]]
		#! (var_exprs, vars, heaps) = buildVarExprs names heaps 
		#! (expr, heaps) = buildConsApp cons_mod def_symbol var_exprs heaps
	 	= (expr, vars, heaps)

	// build case expressions for PAIR, EITHER and UNIT
	build_case_unit body_expr heaps
		# unit_pat = buildPredefConsPattern PD_ConsUNIT [] body_expr predefs
		# {pds_module, pds_def} = predefs.[PD_TypeUNIT]
		# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [unit_pat]
		= build_case_expr case_patterns heaps
		
	build_case_pair var1 var2 body_expr heaps
		# pair_pat = buildPredefConsPattern PD_ConsPAIR [var1, var2] body_expr predefs	
		# {pds_module, pds_def} = predefs.[PD_TypePAIR]
		# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pair_pat]	
		= build_case_expr case_patterns heaps
	
	build_case_either left_var left_expr right_var right_expr heaps
		# left_pat = buildPredefConsPattern PD_ConsLEFT [left_var] left_expr predefs
		# right_pat = buildPredefConsPattern PD_ConsRIGHT [right_var] right_expr predefs
		# {pds_module, pds_def} = predefs.[PD_TypeEITHER]
		# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [left_pat, right_pat]
		= build_case_expr case_patterns heaps

	// CONS case
	build_case_cons var body_expr heaps
		# pat = buildPredefConsPattern PD_ConsCONS [var] body_expr predefs	
		# {pds_module, pds_def} = predefs.[PD_TypeCONS]
		# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat]
		= build_case_expr case_patterns heaps 
	
	// FIELD case
	build_case_field var body_expr heaps
		# pat = buildPredefConsPattern PD_ConsFIELD [var] body_expr predefs	
		# {pds_module, pds_def} = predefs.[PD_TypeFIELD]
		# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat]
		= build_case_expr case_patterns heaps 
	
	// OBJECT case
	build_case_object var body_expr heaps
		# pat = buildPredefConsPattern PD_ConsOBJECT [var] body_expr predefs	
		# {pds_module, pds_def} = predefs.[PD_TypeOBJECT]
		# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat]
		= build_case_expr case_patterns heaps 
		
	// case with a variable as the selector expression
	build_case_expr case_patterns heaps
		# (var_expr, var, heaps) = buildVarExpr "c" heaps
		# (case_expr, heaps) = buildCaseExpr var_expr case_patterns heaps
		= (case_expr, var, heaps)
		

//****************************************************************************************
// build kind indexed classes 
//****************************************************************************************

buildClasses :: !*GenericState -> *GenericState
buildClasses gs=:{gs_modules, gs_main_module}
	#! (common_defs=:{com_class_defs, com_member_defs}, gs_modules) = gs_modules ! [gs_main_module]