implementation module CollectTypes;

import typetable;
import type_io_read;
import type_io_common;

import RWSDebugChoice;

:: *CollectTypesState
	= {
	// Input
		cts_type_tables							:: !*{#TypeTable}

	// Reserved		
	,	cts_collected_types						:: !*{#Bool}									// already collected types
	,	cts_module_base_indices					:: !{#Int}

	// Output
	,	cts_type_dependencies					:: ![(TIO_TypeReference,TIO_TypeReference)]

	// Reserved		
	,	cts_type_dependencies_to_be_collected	:: ![(TIO_TypeReference,TIO_TypeReference)]		// set of type dependencies to be examined

	,	cts_left_i								:: !Int
	,	cts_right_i								:: !Int

	,	cts_left_module_i						:: !Int
	,	cts_right_module_i						:: !Int
	};
	
// interne type equivalenties

default_collect_types_state :: *CollectTypesState;
default_collect_types_state
	= { 
	// Parameters
		cts_type_tables							= {}
		
	,	cts_collected_types						= {}
	,	cts_module_base_indices					= {}
	
	// Reserved
	,	cts_type_dependencies					= []
	
	,	cts_type_dependencies_to_be_collected	= []

	,	cts_left_i								= -1
	,	cts_right_i								= -1

	,	cts_left_module_i						= -1
	,	cts_right_module_i						= -1

	};
	

// precondition:
// - 1st and 2nd argument are type equivalent 
// - types are in nf
class collect_types a :: !a !a !*CollectTypesState -> *CollectTypesState;

// only called from other modules; does initializing
instance collect_types TypeTableTypeReference
where {
	collect_types t1=:(TypeTableTypeReference type_table_left type_reference_left) t2=:(TypeTableTypeReference type_table_right type_reference_right) cts
		| isTypeWithoutDefinition type_reference_left //<<- ("collect_types",t1,t2)
			= {cts & cts_type_dependencies = [(type_reference_left,type_reference_right)] }; // optimization

		// determine amount of representant types and create arrays which marks used type definition 
		# (n_types,cts)
			= cts!cts_type_tables.[type_table_left].tt_type_io_state.tis_max_types;
		# (module_base_indices,cts)
			= cts!cts_type_tables.[type_table_left].tt_type_io_state.tis_max_types_per_module;

		# cts
			= { cts &
				cts_collected_types						= createArray n_types False
			,	cts_module_base_indices					= module_base_indices

			,	cts_type_dependencies					= []			
			,	cts_type_dependencies_to_be_collected	= [(type_reference_left,type_reference_right)]

			,	cts_left_i								= type_table_left
			,	cts_right_i								= type_table_right
			};
		= collect_types_loop cts;
	where {
		collect_types_loop cts=:{cts_type_dependencies_to_be_collected=[(type_reference_left,type_reference_right):rest]}
			# cts
				= { cts &
					cts_type_dependencies_to_be_collected	= rest
				};
			# cts
				= collect_types type_reference_left type_reference_right cts;
			= collect_types_loop cts;
		collect_types_loop cts
			= cts;
	};
};

// only for types without definition e.g. List, Array
instance == TIO_TypeReference
where {
	(==) {tio_type_without_definition=Just type_name1} {tio_type_without_definition=Just type_name2}
		= type_name1 == type_name2;
	(==) _ _
		= False;
};

instance collect_types TIO_TypeReference
where {
	collect_types type_ref1=:{tio_tr_module_n=tio_tr_module_n1} type_ref2=:{tio_tr_module_n=tio_tr_module_n2} cts=:{cts_left_module_i,cts_right_module_i,cts_left_i,cts_right_i,cts_type_dependencies}
		| isTypeWithoutDefinition type_ref1 //<<- ("collect_types TIO_TypeReference",type_ref1,type_ref2)
			# type_pair = (type_ref1,type_ref2)
			| isMember type_pair cts_type_dependencies
				= cts;
				# cts
					= { cts &
						cts_type_dependencies	= [type_pair:cts_type_dependencies]
					};
				= cts;
			
		// check whether type reference has already been seen
		# (type_ref_index1,cts)
			= compute_type_ref_index type_ref1 cts;
		# (already_referenced_type,cts)
			= cts!cts_collected_types.[type_ref_index1];
		| already_referenced_type
			= cts;
		
		// mark it as seen and put in list
		# cts
			= { cts & 
				cts_collected_types.[type_ref_index1]	= True						
			,	cts_type_dependencies 					= [(type_ref1,type_ref2):cts.cts_type_dependencies]
			};
			
			
		// dereference type reference
		# (type1,cts)
			= deref_type_reference (TypeTableTypeReference cts_left_i type_ref1) cts
		# (type2,cts)
			= deref_type_reference (TypeTableTypeReference cts_right_i type_ref2) cts
			
		// set defining modules of new types
		# cts
			= { cts &
				cts_left_module_i				= tio_tr_module_n1
			,	cts_right_module_i				= tio_tr_module_n2
			}		
		# cts
			= collect_types type1 type2 cts;	
			
					// restore old defining modules
		# cts
			= { cts &
				cts_left_module_i				= cts_left_module_i
			,	cts_right_module_i				= cts_right_module_i
			}
		= cts;

		
};

//import RWSDebug;

// copied (and slightly modified) from type_io_equal_types ...
compute_type_ref_index {tio_tr_module_n,tio_tr_type_def_n,tio_type_without_definition=Nothing} cts
//	| True <<- ("compute_type_ref_index",tio_tr_module_n)
	# (module_base_index,cts)
		= cts!cts_module_base_indices.[tio_tr_module_n];
	# index
		= module_base_index + tio_tr_type_def_n;
	= (index,cts);
compute_type_ref_index {tio_tr_module_n,tio_tr_type_def_n,tio_type_without_definition=Just s} cts
	= abort ("compute_type_ref_index " +++ s);

deref_type_reference type=:(TypeTableTypeReference type_table_i {tio_tr_module_n,tio_tr_type_def_n,tio_type_without_definition=Nothing}) cts
	= cts!cts_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_type_defs.[tio_tr_type_def_n];
// ... copied

instance collect_types (TIO_TypeDef a) | collect_types a
where {
	collect_types {tio_td_rhs=tio_td_rhs1} {tio_td_rhs=tio_td_rhs2} cts
		= collect_types tio_td_rhs1 tio_td_rhs2 cts;
};
	
instance collect_types TIO_TypeRhs
where {
	collect_types (TIO_AlgType tio_defined_symbols1) (TIO_AlgType tio_defined_symbols2) cts
		= collect_types tio_defined_symbols1 tio_defined_symbols2 cts;
	collect_types (TIO_RecordType tio_record_type1) (TIO_RecordType tio_record_type2) cts
		= collect_types tio_record_type1 tio_record_type2 cts;
	collect_types (TIO_SynType tio_syn_type1) (TIO_SynType tio_syn_type2) cts
//		| True <<- ("instance collect_types TIO_TypeRhs; synonym types are not yet fully supported")
		= collect_types tio_syn_type1 tio_syn_type2 cts;

	collect_types TIO_UnknownType TIO_UnknownType cts
		= abort "UnknownType";
	collect_types _ _ cts
		= abort "unknown type";
};

instance collect_types TIO_RecordType
where {
	collect_types {tio_rt_fields=tio_rt_fields1} {tio_rt_fields=tio_rt_fields2} cts
		= collect_types tio_rt_fields1 tio_rt_fields2 cts;
};
		
instance collect_types TIO_DefinedSymbol
where {
	collect_types {tio_ds_index=tio_ds_index1} {tio_ds_index=tio_ds_index2} cts=:{cts_left_i,cts_right_i,cts_left_module_i,cts_right_module_i}
		#! (tio_td_name,cts)
			= cts!cts_type_tables.[cts_left_i].tt_tio_common_defs.[cts_left_module_i].tio_module;
		#! (string_table_i,cts)
			=cts!cts_type_tables.[cts_left_i].tt_type_io_state.tis_string_table;
		#! module_name_l
			= get_name_from_string_table tio_td_name string_table_i;

		#! (tio_td_name,cts)
			= cts!cts_type_tables.[cts_right_i].tt_tio_common_defs.[cts_right_module_i].tio_module;
		#! (string_table_i,cts)
			=cts!cts_type_tables.[cts_right_i].tt_type_io_state.tis_string_table;
		#! module_name_r
			= get_name_from_string_table tio_td_name string_table_i;
	
			

//		| True <<- ("%%%%%%%%", module_name_l,module_name_r, (cts_left_i, cts_left_module_i, tio_ds_index1), (cts_right_i, cts_right_module_i, tio_ds_index2))
//			= cts;
		# (tio_cons_symb1,cts)
			= cts!cts_type_tables.[cts_left_i].tt_tio_common_defs.[cts_left_module_i].tio_com_cons_defs.[tio_ds_index1];
		# (tio_cons_symb2,cts)
			= cts!cts_type_tables.[cts_right_i].tt_tio_common_defs.[cts_right_module_i].tio_com_cons_defs.[tio_ds_index2];
			
			
	
		= collect_types tio_cons_symb1 tio_cons_symb2 cts;
};

instance collect_types TIO_ConsDef
where {
	collect_types {tio_cons_type=tio_cons_type1}  {tio_cons_type=tio_cons_type2} cts
//		| True <<- "instance collect_types TIO_ConsDef"
		= collect_types tio_cons_type1 tio_cons_type2 cts;
};

instance collect_types TIO_SymbolType
where {
	collect_types {tio_st_args=tio_st_args1,tio_st_result=tio_st_result1} {tio_st_args=tio_st_args2,tio_st_result=tio_st_result2} cts
		# cts
			= collect_types tio_st_args1 tio_st_args2 cts;
		= collect_types tio_st_result1 tio_st_result2 cts;
};

/*
print type_table_i {tio_tr_module_n,tio_tr_type_def_n,tio_type_without_definition=Nothing} type_tables
	#! (string_table_i,type_tables)
		= type_tables![type_table_i].tt_type_io_state.tis_string_table;
	#! (tio_td_name,type_tables)
		= type_tables![type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_type_defs.[tio_tr_type_def_n].tio_td_name;
	#! type_name
		= get_name_from_string_table tio_td_name string_table_i;
	= (type_name,type_tables);
*/

instance collect_types TIO_AType
where {
	collect_types {tio_at_type=tio_at_type1} {tio_at_type=tio_at_type2} cts
		= collect_types tio_at_type1 tio_at_type2 cts;
};
			
instance collect_types TIO_Type
where {
	collect_types (TIO_TAS tio_type_symb_ident1 tio_atypes1 _) (TIO_TAS tio_type_symb_ident2 tio_atypes2 _) cts
		# cts
			= collect_types tio_type_symb_ident1 tio_type_symb_ident2 cts;
		= collect_types tio_atypes1 tio_atypes2 cts;
			
	collect_types (tio_atype1a ----> tio_atype1b) (tio_atype2a ----> tio_atype2b) cts
		# cts
			= collect_types tio_atype1a tio_atype2a cts;
		= collect_types tio_atype1b tio_atype2b cts;
			
	collect_types (_ :@@: tio_atypes1) (_ :@@: tio_atypes2) cts
		= collect_types tio_atypes1 tio_atypes2 cts;
	
	collect_types (TIO_TB tio_basic_type1) (TIO_TB tio_basic_type2) cts
		= collect_types tio_basic_type1 tio_basic_type2 cts;
	
/*
//	collect_types (TIO_GTV _) (TIO_GTV _) cts
//		= cts;

	collect_types (TIO_TV tio_type_var1) (TIO_TV tio_type_var2) cts
		= collect_types tio_type_var1 tio_type_var2 cts;
		
	collect_types (TIO_TQV tio_type_var1) (TIO_TQV tio_type_var2) cts
		= collect_types tio_type_var1 tio_type_var2 cts;

	collect_types TIO_TE TIO_TE cts
		= (True,type_tables,cts)
*/
	collect_types _ _ cts
		= cts;
};
		
instance collect_types TIO_BasicType
where {
	// type are equivalent, so one match suffices
	collect_types basic_type _ cts
		# basic_type
			= { default_elem &
				tio_type_without_definition	= Just (toString basic_type)
			};
		= collect_types basic_type basic_type cts;
		
		

	
	// TIO_TypeRef
/*
	collect_types TIO_BT_Int TIO_BT_Int cts
		= (True,type_tables,cts)
		
	collect_types TIO_BT_Char TIO_BT_Char cts
		= (True,type_tables,cts)

	collect_types TIO_BT_Real TIO_BT_Real cts
		= (True,type_tables,cts)
		
	collect_types TIO_BT_Bool TIO_BT_Bool cts
		= (True,type_tables,cts)
	
	collect_types TIO_BT_Dynamic TIO_BT_Dynamic cts
		= (True,type_tables,cts)

	collect_types TIO_BT_File TIO_BT_File cts
		= (True,type_tables,cts)

	collect_types TIO_BT_World TIO_BT_World cts
		= (True,type_tables,cts)

	collect_types (TIO_BT_String tio_type1) (TIO_BT_String tio_type2) cts
		= collect_types tio_type1 tio_type2 cts;
		
	collect_types _ _ cts
		= (False,type_tables,cts);
*/
};
	
/*	
instance collect_types TIO_ConsVariable
where
	collect_types _ _ _ _
		= abort "instance collect_types TIO_ConsVariable";
*/

instance collect_types TIO_TypeSymbIdent
where {
	collect_types {tio_type_name_ref=tio_type_name_ref1} {tio_type_name_ref=tio_type_name_ref2} cts
		= collect_types tio_type_name_ref1 tio_type_name_ref2 cts;
};

/*
instance collect_types TIO_ATypeVar
where
	collect_types {tio_atv_annotation=tio_atv_annotation1,tio_atv_variable=tio_atv_variable1} {tio_atv_annotation=tio_atv_annotation2,tio_atv_variable=tio_atv_variable2} cts
		# (are_annotations_equal,type_tables,cts)
			= collect_types tio_atv_annotation1 tio_atv_annotation2 cts;
		| are_annotations_equal
			= collect_types tio_atv_variable1 tio_atv_variable2 cts;
			= (False,type_tables,cts)


instance collect_types TIO_TypeVar
where
	collect_types {tio_tv_name=tio_tv_name1} {tio_tv_name=tio_tv_name2} cts=:{cts_within_type_table,cts_left_string_table,cts_right_string_table}
		# tio_tv_name
			= (tio_tv_name1 == tio_tv_name2) //if True /*cts_within_type_table*/ (tio_tv_name1 == tio_tv_name2) 
			//(get_name_from_string_table tio_tv_name1 cts_left_string_table == get_name_from_string_table tio_tv_name2 cts_right_string_table)
		= (tio_tv_name,type_tables,cts)
		
instance collect_types TIO_Annotation
where
	collect_types TIO_AN_Strict TIO_AN_Strict cts
		= (True,type_tables,cts)
	collect_types TIO_AN_None TIO_AN_None cts
		= (True,type_tables,cts)
	collect_types _ _ cts
		= (False,type_tables,cts);
*/
		
instance collect_types TIO_FieldSymbol
where {
	collect_types {tio_fs_index=tio_fs_index1} {tio_fs_index=tio_fs_index2} cts=:{cts_left_i,cts_right_i,cts_left_module_i,cts_right_module_i}
		# (tio_select_def1,cts)
			= cts!cts_type_tables.[cts_left_i].tt_tio_common_defs.[cts_left_module_i].tio_com_selector_defs.[tio_fs_index1];
		# (tio_select_def2,cts)
			= cts!cts_type_tables.[cts_right_i].tt_tio_common_defs.[cts_right_module_i].tio_com_selector_defs.[tio_fs_index2];
		= collect_types tio_select_def1 tio_select_def2 cts;
};

instance collect_types TIO_SelectorDef
where {
	collect_types {tio_sd_type=tio_sd_type1} {tio_sd_type=tio_sd_type2} cts
		= collect_types tio_sd_type1 tio_sd_type2 cts;
};

instance collect_types [a] | collect_types a
where {
/*
	collect_types l r cts
		| length l == length r
			= collect_types2 l r cts;
			| True <<- ("collect_types [a] | collect_types a",l,r)
			= abort "lijst lengtes ongelijk";
	where {
*/
	collect_types [] [] cts
		= cts;
	collect_types [type1:types1] [type2:types2] cts
		# cts
			= collect_types type1 type2 cts;
		= collect_types types1 types2 cts;
//	};
/*
	collect_types _ _ _
		= abort "1";
*/

};
			
//1.3		
instance collect_types {#a} | ArrayElem, collect_types a
//3.1
/*2.0
instance collect_types {#a} | Array {#} a & collect_types a
0.2*/
where {
	collect_types a1 a2 cts
		| s_a1 <> s_a2
			= cts;
			
		= collect_types_loop 0 s_a1 cts;
	where {
		collect_types_loop i limit cts
			| i == limit
				= cts;
			
			# cts
				= collect_types a1.[i] a2.[i] cts;
			= collect_types_loop (inc i) limit cts;
	
		s_a1
			= size a1;
		s_a2
			= size a2;
	};
};
	
// *****	

	
/*		


:: TypeTableTypeReference
	= TypeTableTypeReference !Int !TIO_TypeReference
	
::  TIO_TypeReference
	= {
		tio_type_without_definition  :: !Maybe !String
	,   tio_tr_module_n    			 :: !Int
	,   tio_tr_type_def_n  			 :: !Int
	}
*/
	
/*

:: *CollectTypesState
	= {
	// Parameters
		cts_type_tables							:: !*{#TypeTable}
		
	,	cts_collected_types						:: !*{#Bool}									// already collected types
	,	cts_module_base_indices					:: !{#Int}

	// Reserved	
	,	cts_type_dependencies					:: ![(TIO_TypeReference,TIO_TypeReference)]
	
	,	cts_type_dependencies_to_be_collected	:: ![(TIO_TypeReference,TIO_TypeReference)]		// set of type dependencies to be examined

	,	cts_left_i								:: !Int
	,	cts_right_i								:: !Int

	,	cts_left_module_i						:: !Int
	,	cts_right_module_i						:: !Int
	};
*/