implementation module type_io_write

import type_io_read
import type_io_common
import RWSDebugChoice

// compiler
//1.3
from utilities import foldSt, mapSt, second_of_2_tuple
from general import Optional, Yes, No
from predef import PD_StringType, PD_ListType, PD_LazyArrayType, PD_StrictArrayType, PD_UnboxedArrayType

// extended
from ExtString import CharIndex, CharIndexBackwards, ends, starts
from pdExtFile import path_separator
from ExtFile import ExtractPathAndFile, ExtractPathFileAndExtension
//import SymbolTable;
from NamesTable import create_names_table, isEmptyNamesTableElement, insert_symbol_in_symbol_table,find_symbol_in_symbol_table;
from ReadObject import decode_line_from_library_file;
//3.1

/*2.0
from utilities import foldSt, mapSt, second_of_2_tuple
from general import ::Optional(..)
from predef import PD_StringType, PD_ListType, PD_LazyArrayType, PD_StrictArrayType, PD_UnboxedArrayType

// extended
from ExtString import CharIndex, CharIndexBackwards, ends, starts
from pdExtFile import path_separator
from ExtFile import ExtractPathAndFile, ExtractPathFileAndExtension
//import SymbolTable;
from NamesTable import create_names_table, isEmptyNamesTableElement, insert_symbol_in_symbol_table,find_symbol_in_symbol_table;
from ReadObject import decode_line_from_library_file;
0.2*/




//F a b :== b
import DebugUtilities
import type_io_static
import StdMaybe;

create_type_archive :: [String] [String] !String !*Files -> (!Bool,!*Files)
create_type_archive objects dlls typ_name files
/*
	// determine icl modules
	# (n_clean_modules,module_names)
		= filter_out_non_clean_modules objects 0 []

	// read type information per module
	# (ok1,tio_common_defs,type_io_state,files)
		= collect_type_info module_names n_clean_modules files
*/
	# (ok1,tio_common_defs,type_io_state,files)
		= collect_type_infoNEW objects files

	| not ok1
		= (False,files)	
		
	// write it back to disk
	# (ok,files)
		= write_type_information2 typ_name dlls tio_common_defs type_io_state files

/*
	# (ok,_,tio_common_defs2,_,files)
		= read_type_information typ_name files
	| True
		= abort ("hhahaha" +++ toString (size tio_common_defs2))
*/
	= (ok,files)
where
	filter_out_non_clean_modules :: [!String] !Int [!String] -> (!Int,[!String])
	filter_out_non_clean_modules [] n_clean_modules accu 
		= (n_clean_modules,accu)
	filter_out_non_clean_modules [file_name:file_names] n_clean_modules accu
		| (ends file_name "_options.o") || (ends file_name ".obj")
			= filter_out_non_clean_modules file_names n_clean_modules accu
		| ends ".o" (snd (ExtractPathAndFile file_name)) && fst (starts "_" (snd (ExtractPathAndFile file_name)))
// WAS		| fst (starts "_" (snd (ExtractPathAndFile file_name)))
			= filter_out_non_clean_modules file_names n_clean_modules accu
	
		# tcl_file_name
			= fst (ExtractPathFileAndExtension file_name)
		= filter_out_non_clean_modules file_names (inc n_clean_modules) [tcl_file_name:accu]

write_type_information2 :: !String [String] !*{#TIO_CommonDefs} !*TypeIOState !*Files -> (!Bool,!*Files)
write_type_information2 typ_file_name dlls tio_common_defs type_io_state files
	# (ok,typ_file,files)
		= fopen typ_file_name FWriteData files
	| not ok
		= (False,snd (fclose typ_file files))
		
		
	// write contents of libraries
	# typ_file
		= fwritei (length dlls) typ_file
	# (ok,typ_file,_,files)
		= foldSt copy_library_files dlls (True,typ_file,create_names_table,files)
	| not ok
		= (False,snd (fclose typ_file files))
		
	// write type information
	# (typ_file,_)
		= write_type_info tio_common_defs typ_file WriteTypeInfoState
	# typ_file
		= write_type_io_state type_io_state typ_file
		
	# (_,files)
		= fclose typ_file files

	= (True,files)
where	// 
	copy_library_files :: !String (!Bool,!*File,!*NamesTable,!*Files) -> (!Bool,!*File,!*NamesTable,!*Files)
	copy_library_files library_file_name (True,typ_file,names_table,files)
		# (ok,library_file,files)
			= fopen library_file_name FReadText files
		| not ok
			= abort ("copy_library_files 1" +++ library_file_name) //(False,typ_file,snd (fclose library_file files))
			
		# (library_file,contents,n_contents_lines,names_table)
			= copy_library_file library_file [] 0 names_table
		# typ_file
			= fwritei n_contents_lines typ_file
		# typ_file
			= foldSt /*fwrites*/ write_line contents typ_file
			
		# (_,files)
			= fclose library_file files
		= (True,typ_file,names_table,files)
	where
		copy_library_file :: !*File [{#Char}] !Int !*NamesTable -> (!*File,[{#Char}],!Int,!*NamesTable)
		copy_library_file library_file accu n_contents_lines names_table
			# (end_of_line,library_file)
				= fend library_file
			| end_of_line
				= (library_file,reverse accu,n_contents_lines,names_table)
			
			# (s,library_file)
				= freadline library_file

			# result
				= if (isEmpty accu) Nothing (decode_line_from_library_file s);
			# (skip_line,names_table)
				= case result of
					Nothing	
						-> (False,names_table);
					(Just symbol_name)
						# (names_table_element,names_table)
							= find_symbol_in_symbol_table symbol_name names_table;
						| isEmptyNamesTableElement names_table_element
							# names_table
								= insert_symbol_in_symbol_table symbol_name 0 0 names_table;
							-> (False,names_table);
							
							// remove duplicate library symbols
							-> (True,names_table);
			| skip_line
				= copy_library_file library_file accu n_contents_lines names_table

				= copy_library_file library_file [s:accu] (inc n_contents_lines) names_table
				
		copy_library_files _ (False,typ_file,files)
			= (False,typ_file,files)
			
		write_line line typ_file
			# typ_file
				= fwritec (toChar (size line)) typ_file
			# typ_file
				= fwrites line typ_file
			= typ_file
			
:: WriteTypeInfoState	= WriteTypeInfoState;

report_position s tcl_file :== tcl_file
/*
	# (kk,tcl_file)
			= fposition tcl_file
	| F (s +++ " fp: " +++ toString kk) True
		= tcl_file
*/	 

class WriteTypeInfo a 
where
	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
		
instance WriteTypeInfo TIO_CommonDefs
where 
	write_type_info {tio_com_type_defs,tio_com_cons_defs,tio_com_selector_defs,tio_imported_modules,tio_n_exported_com_type_defs,tio_n_exported_com_cons_defs,tio_module} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_com_type_defs tcl_file wtis
		# tcl_file
			= report_position "na tio_com_type_defs (w)" tcl_file
					
		# (tcl_file,wtis)
 			= write_type_info tio_com_cons_defs tcl_file wtis
		# tcl_file
			= report_position "na tio_com_cons_defs (w)" tcl_file

 		# (tcl_file,wtis)
 			= write_type_info tio_com_selector_defs tcl_file wtis
		# tcl_file
			= report_position "na tio_com_selector_defs (w)" tcl_file
 			
 		// additional
 		# (tcl_file,wtis)
 			= write_type_info tio_imported_modules tcl_file wtis
	 	# tcl_file
			= report_position "na tio_imported_modules (w)" tcl_file
		 	
 		# (tcl_file,wtis)
 			= write_type_info tio_n_exported_com_type_defs tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info tio_n_exported_com_cons_defs tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info tio_module tcl_file wtis
 		
		= (tcl_file,wtis)
		
instance WriteTypeInfo TIO_SelectorDef
where
	write_type_info {tio_sd_type} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_sd_type tcl_file wtis
		= (tcl_file,wtis)
	
instance WriteTypeInfo TIO_ConsDef
where 
	write_type_info {tio_cons_symb,tio_cons_type,tio_cons_arg_vars,tio_cons_index,tio_cons_type_index,tio_cons_exi_vars} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_cons_symb tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_cons_type tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_cons_arg_vars tcl_file wtis
//		# (tcl_file,wtis)
//			= write_type_info tio_cons_priority tcl_file wtis

		# (tcl_file,wtis)
			= write_type_info tio_cons_index tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_cons_type_index tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_cons_exi_vars tcl_file wtis
	
		= (tcl_file,wtis)
	
	/*	
instance WriteTypeInfo TIO_Priority
where 
	write_type_info (Prio assoc i) tcl_file wtis
		# tcl_file
			= fwritec PrioCode tcl_file
		# (tcl_file,wtis)
			= write_type_info assoc tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info i tcl_file wtis
		= (tcl_file,wtis)
	write_type_info NoPrio tcl_file wtis
		# tcl_file
			= fwritec NoPrioCode tcl_file 
		= (tcl_file,wtis)
		
instance WriteTypeInfo TIO_Assoc
where 
	write_type_info LeftAssoc tcl_file wtis
		# tcl_file
			= fwritec LeftAssocCode tcl_file 
		= (tcl_file,wtis)

	write_type_info RightAssoc tcl_file wtis
		# tcl_file
			= fwritec RightAssocCode tcl_file
		= (tcl_file,wtis)	

	write_type_info NoAssoc tcl_file wtis
		# tcl_file
			= fwritec NoAssocCode tcl_file 
		= (tcl_file,wtis)	
		*/
		
//1.3
instance WriteTypeInfo TIO_TypeDef TIO_TypeRhs
//3.1
/*2.0
instance WriteTypeInfo (TIO_TypeDef TIO_TypeRhs)
0.2*/
where 
	write_type_info {tio_td_name,tio_td_arity,tio_td_args,tio_td_rhs} tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info tio_td_name tcl_file wtis
		# (tcl_file,wtis)
 			= write_type_info tio_td_arity tcl_file wtis 				
 		# (tcl_file,wtis)
 			= write_type_info tio_td_args tcl_file wtis
		# (tcl_file,wtis)
 			= write_type_info tio_td_rhs tcl_file wtis
 			
 		= (tcl_file,wtis)
 	
instance WriteTypeInfo TIO_ATypeVar
where 
	write_type_info {tio_atv_annotation,tio_atv_variable} tcl_file wtis
 		# (tcl_file,wtis) 
 			= write_type_info tio_atv_annotation tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info tio_atv_variable tcl_file wtis
 		= (tcl_file,wtis)
 		
instance WriteTypeInfo TIO_Annotation
where 
	write_type_info TIO_AN_Strict tcl_file wtis	
		= (fwritec '!' tcl_file,wtis)
	write_type_info TIO_AN_None tcl_file wtis
		= (fwritec ' ' tcl_file,wtis)
		
instance WriteTypeInfo TIO_TypeVar
where
	write_type_info {tio_tv_name} tcl_file wtis
		# tcl_file
			= fwritei tio_tv_name tcl_file
 		= (tcl_file,wtis)	

instance WriteTypeInfo TIO_TypeRhs
where 
	write_type_info (TIO_AlgType defined_symbols) tcl_file wtis
 		# tcl_file
 			= fwritec AlgTypeCode tcl_file
		
//		# defined_symbols
//			= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
		# (tcl_file,wtis)
			= write_type_info defined_symbols tcl_file wtis

		= (tcl_file,wtis)
		
	write_type_info (TIO_SynType _) tcl_file wtis
		# tcl_file
 			= fwritec SynTypeCode tcl_file;
 			
 		// unimplemented
 		= (tcl_file,wtis) 
		
	write_type_info (TIO_RecordType {tio_rt_fields}) tcl_file wtis
 		#! tcl_file
 			= fwritec RecordTypeCode tcl_file;
		= write_type_info tio_rt_fields tcl_file wtis

	write_type_info (TIO_AbstractType _) tcl_file wtis
 		#! tcl_file
 			= fwritec AbstractTypeCode tcl_file;
 			
 		// unimplemented
		= (tcl_file,wtis)
				
instance WriteTypeInfo TIO_DefinedSymbol 
where
	write_type_info {tio_ds_ident,tio_ds_arity,tio_ds_index} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_ds_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_ds_arity tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_ds_index tcl_file wtis
		= (tcl_file,wtis)

/*
instance WriteTypeInfo TIO_Ident 
where
	write_type_info {id_name} tcl_file wtis
		# tcl_file
			= fwritei (size id_name) tcl_file
		= (fwrites id_name tcl_file,wtis)
*/
		
instance WriteTypeInfo TIO_FieldSymbol
where
	write_type_info {tio_fs_name,tio_fs_var,tio_fs_index} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_fs_name tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_fs_var tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_fs_index tcl_file wtis
		= (tcl_file,wtis)
		
// NEW ->
instance WriteTypeInfo TIO_SymbolType
where
	write_type_info {tio_st_vars,tio_st_args,tio_st_arity,tio_st_result} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_st_vars tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_st_args tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_st_arity tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_st_result tcl_file wtis
		= (tcl_file,wtis)
		
instance WriteTypeInfo TIO_AType
where
	write_type_info {tio_at_annotation,tio_at_type} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_at_annotation tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_at_type tcl_file wtis
		= (tcl_file,wtis)
		
instance WriteTypeInfo TIO_Type
where
	write_type_info (TIO_TA type_symb_ident atypes) tcl_file wtis
		# tcl_file
			= fwritec TypeTACode tcl_file
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
		= (tcl_file,wtis)

	write_type_info (atype1 ----> atype2) tcl_file wtis
		# tcl_file
			= fwritec TypeArrowCode tcl_file
		# (tcl_file,wtis)
			= write_type_info atype1 tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atype2 tcl_file wtis
		= (tcl_file,wtis)
		
	write_type_info (cons_variable :@@: atypes) tcl_file wtis
		# tcl_file
			= fwritec TypeConsApplyCode tcl_file
		# (tcl_file,wtis)
			= write_type_info cons_variable tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
		= (tcl_file,wtis)
		
	write_type_info tb=:(TIO_TB basic_type) tcl_file wtis
		# (tcl_file,wtis)
			= case basic_type of
				TIO_BT_Int		-> (fwritec BT_IntCode tcl_file,wtis)
				TIO_BT_Char		-> (fwritec BT_CharCode tcl_file,wtis)
				TIO_BT_Real		-> (fwritec BT_RealCode tcl_file,wtis)
				TIO_BT_Bool		-> (fwritec BT_BoolCode tcl_file,wtis)
				TIO_BT_Dynamic	-> (fwritec BT_DynamicCode tcl_file,wtis)
				TIO_BT_File		-> (fwritec BT_FileCode tcl_file,wtis)
				TIO_BT_World	-> (fwritec BT_WorldCode tcl_file,wtis)
				TIO_BT_String type
					# tcl_file
						= fwritec BT_StringCode tcl_file
					# (tcl_file,wtis)
						= write_type_info type tcl_file wtis
					-> (tcl_file,wtis)
		= (tcl_file,wtis)
	
	write_type_info (TIO_GTV type_var) tcl_file wtis
		# tcl_file
			= fwritec TypeGTVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)

	write_type_info (TIO_TV type_var) tcl_file wtis
		# tcl_file
			= fwritec TypeTVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
		
	write_type_info (TIO_TQV type_var) tcl_file wtis
		# tcl_file
			= fwritec TypeTQVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	

	write_type_info TIO_TE tcl_file wtis
		# tcl_file
			= fwritec TypeTECode tcl_file
		= (tcl_file,wtis)	

instance WriteTypeInfo TIO_ConsVariable
where
	write_type_info (TIO_CV type_var) tcl_file wtis
		# tcl_file
			= fwritec ConsVariableCVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	

	write_type_info (TIO_TempCV temp_var_id) tcl_file wtis
		# tcl_file
			= fwritec ConsVariableTempCVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
		
	write_type_info (TIO_TempQCV temp_var_id) tcl_file wtis
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	

instance WriteTypeInfo TIO_TypeSymbIdent
where
	write_type_info {tio_type_name_ref,tio_type_arity} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_type_name_ref tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_type_arity tcl_file wtis
		= (tcl_file,wtis)
		
instance WriteTypeInfo TIO_TypeReference
where
	write_type_info {tio_type_without_definition,tio_tr_module_n,tio_tr_type_def_n} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info tio_type_without_definition tcl_file wtis
		# tcl_file
			= fwritei tio_tr_module_n tcl_file
		# tcl_file
			= fwritei tio_tr_type_def_n tcl_file
		= (tcl_file,wtis)
		
/*2.0
/*
instance WriteTypeInfo TIO_String
where
	write_type_info s tcl_file wtis
		# tcl_file
			= fwritei (size s) tcl_file
		= fwrites s tcl_file
	// warning:
	// Should be identical to the code in Ident
*/
0.2*/

// basic and structural write_type_info's
instance WriteTypeInfo Int 
where
	write_type_info i tcl_file wtis
		= (fwritei i tcl_file,wtis)

//1.3
instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
//3.1
/*2.0
instance WriteTypeInfo {#b} | WriteTypeInfo b & Array {#} b
0.2*/
where
	write_type_info unboxed_array tcl_file wtis
		# s_unboxed_array
			= size unboxed_array
		# tcl_file
			= fwritei s_unboxed_array tcl_file
			
		= write_type_info_loop 0 s_unboxed_array tcl_file wtis
	where 

		write_type_info_loop i limit tcl_file wtis
			| i == limit
				= (tcl_file,wtis)
			# (tcl_file,wtis)
				= write_type_info unboxed_array.[i] tcl_file wtis
			= write_type_info_loop (inc i) limit tcl_file wtis
			
instance WriteTypeInfo [a] | WriteTypeInfo a
where
	write_type_info l tcl_file wtis
		# tcl_file
			= fwritei (length l) tcl_file
		= write_type_info_loop l tcl_file wtis
	where
		write_type_info_loop []	tcl_file wtis
			= (tcl_file,wtis)
		write_type_info_loop [x:xs] tcl_file wtis
			# (tcl_file,wtis)
				= write_type_info x tcl_file wtis
			= write_type_info_loop xs tcl_file wtis
			
instance WriteTypeInfo (Maybe a) | WriteTypeInfo a
where
	write_type_info Nothing tcl_file wtis
 		# tcl_file
 			= fwritec MaybeNothingCode tcl_file
 		= (tcl_file,wtis)
 	write_type_info (Just a) tcl_file wtis
 		# tcl_file
 			= fwritec MaybeJustCode tcl_file
		# (tcl_file,wtis)
			= write_type_info a tcl_file wtis
		= (tcl_file,wtis)
		 	
instance WriteTypeInfo Char
where
	write_type_info c tcl_file wtis
		# tcl_file
			= fwritec c tcl_file;
		= (tcl_file,wtis);
		
// type_io_state
write_type_io_state :: !*TypeIOState !*File -> !*File
write_type_io_state type_io_state=:{tis_string_table,tis_equivalent_type_definitions} typ_file
	// string table
	# typ_file
		= fwritei (size tis_string_table) typ_file
	# typ_file
		= fwrites tis_string_table typ_file
		
/*		
	| True
		# n_equivalent_trees
			= tis_equivalent_type_definitions.[0].partitions.[0]
		= abort ((get_name_from_string_table tis_equivalent_type_definitions.[0].type_name tis_string_table) +++ " " +++ toString (size n_equivalent_trees))
*/
	// equivalent type definitions
	# (typ_file,_)
		= write_type_info tis_equivalent_type_definitions typ_file WriteTypeInfoState ->> ("hallo"		)
	= typ_file
		
instance WriteTypeInfo EquivalentTypeDef
where
	write_type_info {type_name,partitions} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info type_name tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info partitions tcl_file wtis
		= (tcl_file,wtis)