implementation module StdDynamicTypeIO

import _SystemDynamic, StdDynamicTypes
import code from "DtoBaseAndArity.obj"

:: Type
	= Predefined PredefType
	| NonPredefined TypeDef`

// convert ConstructorID to a type
TypeConstructorIDToType :: !Int !TypeState -> Type
TypeConstructorIDToType index ts=:{ts_typedefs}
	| index < N_PREDEFINED_INDICES 
		= Predefined (snd (INDEX_TO_PREDEFINED_TYPE_STRING.[index])) 
		= NonPredefined ts_typedefs.[index - N_PREDEFINED_INDICES]
		
// convert TypeCodeConstructor to Type
TypeCodeConstructorToType :: !TypeCodeConstructor !TypeState -> Type
TypeCodeConstructorToType tcc ts=:{ts_addresses_ids,ts_typedefs}
	| typeCodeConstructorIsPredefined tcc
		| tcc == TypeCodeConstructorInt
			= Predefined PT_Int
		| tcc == TypeCodeConstructorChar
			= Predefined PT_Char
		| tcc == TypeCodeConstructorReal
			= Predefined PT_Real
		| tcc == TypeCodeConstructorBool
			= Predefined PT_Bool
		| tcc == TypeCodeConstructorDynamic
			= Predefined PT_Dynamic
		| tcc == TypeCodeConstructorFile
			= Predefined PT_File
		| tcc == TypeCodeConstructorInt
			= Predefined PT_Int
		| tcc == TypeCodeConstructorWorld
			= Predefined PT_World
		| tcc == TypeCodeConstructor_Arrow
			= Predefined PT__Arrow
		| tcc == TypeCodeConstructor_List
			= Predefined PT__List
		| tcc == TypeCodeConstructor_StrictList
			= Predefined PT__StrictList
		| tcc == TypeCodeConstructor_UnboxedList
			= Predefined PT__UnboxedList
		| tcc == TypeCodeConstructor_TailStrictList
			= Predefined PT__TailStrictList
		| tcc == TypeCodeConstructor_StrictTailStrictList
			= Predefined PT__StrictTailStrictList
		| tcc == TypeCodeConstructor_UnboxedTailStrictList
			= Predefined PT__UnboxedTailStrictList
		| tcc == TypeCodeConstructor_LazyArray
			= Predefined PT__LazyArray
		| tcc == TypeCodeConstructor_StrictArray
			= Predefined PT__StrictArray
		| tcc == TypeCodeConstructor_UnboxedArray
			= Predefined PT__UnboxedArray
			
			// must be tuple
			#! tcc_string = toString tcc
			# x = toInt (tcc_string % (6, dec (size tcc_string)))
			= Predefined (PT__Tuple x)
			
		// user defined type
		# tcc_address = get_descP tcc 
		# x = filter (\(address,_) -> tcc_address == address) ts_addresses_ids
		| length x <> 1
			= abort "TypeCodeConstructorToType; user defined type unknown"
			
		# tcc_id
			= snd (hd x)
		= NonPredefined ts_typedefs.[tcc_id - N_PREDEFINED_INDICES]
			
// should be abstract
:: TypeState
	= {
		ts_addresses_ids	:: [(!Int,!Int)]
	,	ts_typedefs			:: {#TypeDef`}
	};

GetAllTypedefs :: !.TypeState -> .[TypeDef`]	
GetAllTypedefs {ts_typedefs}
	= [typedef \\ typedef <-: ts_typedefs]
	
:: TypeRef
	= {
		tr_ith_type_def		:: !Int
	,	tr_ith_constructor	:: !Int
	}
	
GetTypeDef :: !TypeRef !TypeState -> TypeDef`
GetTypeDef {tr_ith_type_def} {ts_typedefs}
	= ts_typedefs.[tr_ith_type_def]
	
// using the descriptor address of a constructor, find its type definition	
FindTypeDef :: !Int !TypeState -> Maybe TypeRef
FindTypeDef descP {ts_typedefs}
	| descP bitand 2 == 0
		= abort "FindTypeDef; internal error; should always be a non-closure";
		
	= find_type_def descP 0 (size ts_typedefs) ts_typedefs

find_type_def descP i limit ts_typedefs
	| i == limit
		= Nothing;
		
		#! descP = descP bitand 0xfffffffd
		
		# maybe_ith_constructor
			= find_in_rhs descP ts_typedefs.[i]
		| isJust maybe_ith_constructor
			# type_ref
				= { 
					tr_ith_type_def		= i
				,	tr_ith_constructor	= fromJust maybe_ith_constructor
				}	
			= Just type_ref
		
			= find_type_def descP (inc i) limit ts_typedefs

find_in_rhs descP {rhs=AlgType` constructors}		
	= find_constructor 0 constructors
where
	find_constructor _ []
		= Nothing

	find_constructor i [Constructor` name arg_types strictness_list addresses:cs]
		#! (descP_base,actual_arity)
			= DtoBaseAndArity2 (descP bitor 2)
		| isMember descP_base addresses // <<- (descP_base,addresses)
			= Just i;			
			= find_constructor (inc i) cs
		where
			DtoBaseAndArity2 :: !Int -> !(!Int,!Int)
			DtoBaseAndArity2 _
				= code {
					jmp	DtoBaseAndArity
				}
				
find_in_rhs descP {rhs=RecordType` _ _ addresses}
	#! descP = descP bitand 0xfffffffd
	| isMember descP addresses
		= Just 0
		= Nothing	
		
CreateTypeState :: !Dynamic -> TypeState
CreateTypeState dyn 
	#! (ts_addresses_ids,typedefs)
		= get_type_definitions_of_dynamic dyn
	#! ts_typedefs
		= createArray (length typedefs) default_elem 
	#! ts_typedefs
		= { ts_typedefs & [td.td_id - N_PREDEFINED_INDICES] = td \\ td <- typedefs } 
	#! ts
		= { 
			ts_addresses_ids	= ts_addresses_ids
		,	ts_typedefs			= ts_typedefs 
		}
	= ts
where
	get_type_definitions_of_dynamic dyn
		# type = typeCodeOfDynamic dyn
		# descPs = collect_TypeConses type []
		= GetTypeInfo { descP \\ descP <- descPs }
	where
		collect_TypeConses :: !TypeCode ![Int] -> [Int]
		collect_TypeConses (TypeScheme _ tc) accu		
			= collect_TypeConses tc accu
		collect_TypeConses (TypeCons type_code_constructor) accu
			| typeCodeConstructorIsPredefined type_code_constructor //<<- ("jndfxc", toString type_code_constructor)
				= accu
//			| False <<- ("TypeConses (" +++ toString type_code_constructor +++ ")" +++ hex_int2 (get_descP type_code_constructor))
//				= undef;
			= [get_descP type_code_constructor:accu]
		collect_TypeConses (TypeApp tc1 tc2) accu
			= collect_TypeConses tc2 (collect_TypeConses tc1 accu)
		collect_TypeConses _ accu
			= accu	

		GetTypeInfo :: !{#Int} -> ([(!Int,!Int)],[TypeDef`])
		GetTypeInfo descPs
			| size descPs == 0
				= ([],[]);
				
			# x = doreqS ("GetTypeInfo" +++ encode descPs)
			
			#! (x=:(id_adresses_of_root_types,l))
				= (decode x); // (id_adresses_of_root_types,l)
			= x
		where
			// from DynamicLinkerInterface ...
			doreqS :: !String -> .{#Char}
			doreqS _ =
				code { 
					ccall DoReqS "S-S"
				}	
			// ... from DynamicLinkerInterface
		
get_descP :: !TypeCodeConstructor -> Int
get_descP _
	= code {
		pushD_a 0
		pop_a	1
	}		

UniversalTypeID_to_TypeCodeConstructor_address :: [UniversalTypeID] -> [(!TypeCodeConstructor,!UniversalTypeID)]
UniversalTypeID_to_TypeCodeConstructor_address []
	= []
UniversalTypeID_to_TypeCodeConstructor_address utids
	# x = doreqS ("UniversalTypeID_to_TypeCodeConstructor_address" +++ encode utids)
	= zip2 [fst (createTypeCodeConstructor address) \\ address <- (decode x)] utids 
where
	// from DynamicLinkerInterface ...
	doreqS :: !String -> .{#Char}
	doreqS _ =
		code { 
			ccall DoReqS "S-S"
		}	
	// ... from DynamicLinkerInterface

	createTypeCodeConstructor :: !Int -> (!TypeCodeConstructor,!Int)
	createTypeCodeConstructor _
		= code {
			pushI 8
			push_b 1
			subI
			push_b_a 0
			pop_b 1
		};