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;

init_collect_types :: !Int !Int ![(!TIO_TypeReference,!TIO_TypeReference)] !*CollectTypesState -> !*CollectTypesState;
init_collect_types type_table_left type_table_right types cts
	// 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	= types

		,	cts_left_i								= type_table_left
		,	cts_right_i								= type_table_right
		};
	= cts;
	
collect_types_loop :: !*CollectTypesState -> *CollectTypesState;
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 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
			
		# cts
			= init_collect_types type_table_left type_table_right [(type_reference_left,type_reference_right)] cts
		= collect_types_loop 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
			# 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;
};

// 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
	# (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
		= 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;
	
		# (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
		= 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;
};

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 _ _ 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;
};
	
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_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 [] [] cts
		= cts;
	collect_types [type1:types1] [type2:types2] cts
		# cts
			= collect_types type1 type2 cts;
		= collect_types types1 types2 cts;
};
			
instance collect_types {#a} | Array {#} a & collect_types a
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;
	};
};