Commit 75a78bb6 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

removed boolean result from substituteType and substitute: they

could only fail in case of a kind error which is already detected
elsewhere
parent a2ea07e1
...@@ -117,11 +117,8 @@ where ...@@ -117,11 +117,8 @@ where
# (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object] # (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object]
= case td_rhs of = case td_rhs of
SynType {at_type} SynType {at_type}
# (ok, subst_rhs, type_heaps) = substituteType used_td.td_attribute attribute used_td.td_args types at_type type_heaps # ( subst_rhs, type_heaps) = substituteType used_td.td_attribute attribute used_td.td_args types at_type type_heaps
| ok -> (Yes {type & at_type = subst_rhs }, type_defs, type_heaps, error)
-> (Yes {type & at_type = subst_rhs }, type_defs, type_heaps, error)
# error = popErrorAdmin (typeSynonymError used_td.td_ident "kind conflict in argument of type synonym" (pushErrorAdmin pos error))
-> (No, type_defs, type_heaps, error)
_ _
-> (No, type_defs, type_heaps, error) -> (No, type_defs, type_heaps, error)
......
...@@ -614,22 +614,16 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en ...@@ -614,22 +614,16 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en
(new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs) (new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs)
type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs } type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(ok1, new_ss_context, type_heaps) = substitute ss_context type_heaps (new_ss_context, type_heaps) = substitute ss_context type_heaps
(inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars) (inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars)
(inst_attr_vars, th_attrs) = foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs) (inst_attr_vars, th_attrs) = foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)
(inst_types, (ok2, type_heaps)) = mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs }) (inst_types, (ok2, type_heaps)) = mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs })
// (ok2, inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs } // (ok2, inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(ok3, inst_contexts, type_heaps) = substitute type_contexts type_heaps (inst_contexts, type_heaps) = substitute type_contexts type_heaps
(ok4, inst_attr_env, type_heaps) = substitute attr_env type_heaps (inst_attr_env, type_heaps) = substitute attr_env type_heaps
(special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars (special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars
error = case ok1 && ok2 && ok3 && ok4 of
True
-> error
False
-> checkError "instance type incompatible with class type" "" error
= (inst_vars, inst_attr_vars, inst_types, new_ss_context ++ inst_contexts, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error) = (inst_vars, inst_attr_vars, inst_types, new_ss_context ++ inst_contexts, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error)
where where
clear_vars type_vars type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) type_vars type_var_heap clear_vars type_vars type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) type_vars type_var_heap
...@@ -643,7 +637,7 @@ where ...@@ -643,7 +637,7 @@ where
-> (free_vars, type_var_heap) -> (free_vars, type_var_heap)
build_type_subst {bind_src,bind_dst} type_heaps build_type_subst {bind_src,bind_dst} type_heaps
# (_, bind_src, type_heaps) = substitute bind_src type_heaps # (bind_src, type_heaps) = substitute bind_src type_heaps
// RWS ... // RWS ...
/* /*
FIXME: this is a patch for the following incorrect function type (in a dcl module) FIXME: this is a patch for the following incorrect function type (in a dcl module)
...@@ -664,11 +658,11 @@ where ...@@ -664,11 +658,11 @@ where
substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps) substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps)
# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps) # (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
(ok, new_at, type_heaps) = substitute {at & at_type = type} type_heaps (new_at, type_heaps) = substitute {at & at_type = type} type_heaps
= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok && ok, type_heaps)) = ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
substitue_arg_type type (was_ok, type_heaps) substitue_arg_type type (was_ok, type_heaps)
# (ok, type, type_heaps) = substitute type type_heaps # (type, type_heaps) = substitute type type_heaps
= (type, (was_ok && ok, type_heaps)) = (type, (was_ok, type_heaps))
build_var_subst var (free_vars, type_var_heap) build_var_subst var (free_vars, type_var_heap)
# (new_info_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap # (new_info_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap
......
...@@ -388,7 +388,7 @@ where ...@@ -388,7 +388,7 @@ where
where where
fresh_context :: !TypeContext !*(.a,*TypeHeaps) -> (TypeContext,(.a,*TypeHeaps)) fresh_context :: !TypeContext !*(.a,*TypeHeaps) -> (TypeContext,(.a,*TypeHeaps))
fresh_context tc=:{tc_types} (var_heap, type_heaps) fresh_context tc=:{tc_types} (var_heap, type_heaps)
# (_, tc_types, type_heaps) = substitute tc_types type_heaps # (tc_types, type_heaps) = substitute tc_types type_heaps
// (tc_var, var_heap) = newPtr VI_Empty var_heap // (tc_var, var_heap) = newPtr VI_Empty var_heap
// = ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps)) // = ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps))
= ({ tc & tc_types = tc_types }, (var_heap, type_heaps)) = ({ tc & tc_types = tc_types }, (var_heap, type_heaps))
...@@ -496,7 +496,7 @@ where ...@@ -496,7 +496,7 @@ where
is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols
-> (unboxable, No, (predef_symbols, type_heaps)) -> (unboxable, No, (predef_symbols, type_heaps))
SynType {at_type} SynType {at_type}
# (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps # (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
-> try_to_unbox expanded_type defs (predef_symbols, type_heaps) -> try_to_unbox expanded_type defs (predef_symbols, type_heaps)
_ _
-> (False, No, (predef_symbols, type_heaps)) -> (False, No, (predef_symbols, type_heaps))
...@@ -593,7 +593,7 @@ tryToExpandTypeSyn defs type cons_id=:{type_ident,type_index={glob_object,glob_m ...@@ -593,7 +593,7 @@ tryToExpandTypeSyn defs type cons_id=:{type_ident,type_index={glob_object,glob_m
# {td_ident,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object] # {td_ident,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
= case td_rhs of = case td_rhs of
SynType {at_type} SynType {at_type}
# (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps # (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
-> (True, expanded_type, type_heaps) -> (True, expanded_type, type_heaps)
_ _
-> (False, type, type_heaps) -> (False, type, type_heaps)
...@@ -835,7 +835,7 @@ where ...@@ -835,7 +835,7 @@ where
= type_var_heap <:= (tv_info_ptr, TVI_Type type) = type_var_heap <:= (tv_info_ptr, TVI_Type type)
subst_context_and_generate_super_classes class_context (super_classes, type_heaps) subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
# (_, super_class, type_heaps) = substitute class_context type_heaps # (super_class, type_heaps) = substitute class_context type_heaps
| containsContext super_class super_classes | containsContext super_class super_classes
= (super_classes, type_heaps) = (super_classes, type_heaps)
= generate_super_classes super_class ([super_class : super_classes], type_heaps) = generate_super_classes super_class ([super_class : super_classes], type_heaps)
...@@ -1057,7 +1057,7 @@ where ...@@ -1057,7 +1057,7 @@ where
# {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2 # {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2
{class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types
(_, super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } (super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars }
= find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps = find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
where where
find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps
......
...@@ -978,8 +978,8 @@ where ...@@ -978,8 +978,8 @@ where
(type_variables, th_vars) = getTypeVars [ct_result_type:arg_types] th_vars (type_variables, th_vars) = getTypeVars [ct_result_type:arg_types] th_vars
(fresh_type_vars, th_vars) = mapSt bind_to_fresh_type_variable type_variables th_vars (fresh_type_vars, th_vars) = mapSt bind_to_fresh_type_variable type_variables th_vars
ti_type_heaps = { ti_type_heaps & th_vars = th_vars } ti_type_heaps = { ti_type_heaps & th_vars = th_vars }
(_, fresh_arg_types, ti_type_heaps) = substitute arg_types ti_type_heaps (fresh_arg_types, ti_type_heaps) = substitute arg_types ti_type_heaps
(_, fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps (fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
fun_type = fun_type =
{ st_vars = fresh_type_vars { st_vars = fresh_type_vars
, st_args = fresh_arg_types , st_args = fresh_arg_types
...@@ -1349,7 +1349,7 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i ...@@ -1349,7 +1349,7 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i
ti_type_heaps ti_type_heaps
= { ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars } = { ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars }
// | False-!->("before substitute", st_args, "->", st_result) = undef // | False-!->("before substitute", st_args, "->", st_result) = undef
# (_, (st_args,st_result), ti_type_heaps) # ((st_args,st_result), ti_type_heaps)
= substitute (st_args,st_result) ti_type_heaps = substitute (st_args,st_result) ti_type_heaps
// | False-!->("after substitute", st_args, "->", st_result) = undef // | False-!->("after substitute", st_args, "->", st_result) = undef
// determine args... // determine args...
...@@ -1686,9 +1686,9 @@ where ...@@ -1686,9 +1686,9 @@ where
= mapSt bind_to_fresh_type_variable st_vars th_vars = mapSt bind_to_fresh_type_variable st_vars th_vars
(fresh_st_attr_vars, th_attrs) (fresh_st_attr_vars, th_attrs)
= mapSt bind_to_fresh_attr_variable st_attr_vars th_attrs = mapSt bind_to_fresh_attr_variable st_attr_vars th_attrs
(_, [fresh_st_result:fresh_st_args], ti_type_heaps) ([fresh_st_result:fresh_st_args], ti_type_heaps)
= substitute [st_result:st_args] { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs } = substitute [st_result:st_args] { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(_, fresh_st_attr_env, ti_type_heaps) (fresh_st_attr_env, ti_type_heaps)
= substitute st_attr_env ti_type_heaps = substitute st_attr_env ti_type_heaps
= (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args, = (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args,
st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps) st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps)
...@@ -1907,7 +1907,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr ...@@ -1907,7 +1907,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
= das_arg_types![prod_index] = das_arg_types![prod_index]
# {ats_types=[arg_type:_]} # {ats_types=[arg_type:_]}
= ws_arg_type = ws_arg_type
(_, int_class_type, das_type_heaps) (int_class_type, das_type_heaps)
= substitute class_type das_type_heaps = substitute class_type das_type_heaps
class_atype class_atype
= { empty_atype & at_type = int_class_type } = { empty_atype & at_type = int_class_type }
...@@ -1941,7 +1941,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr ...@@ -1941,7 +1941,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
# (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps # (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps
with with
subFVT (fv,ty) th subFVT (fv,ty) th
# (_,ty`,th`) = substitute ty th # (ty`,th`) = substitute ty th
= ((fv,ty`),th`) = ((fv,ty`),th`)
# ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types] # ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types]
...@@ -1977,7 +1977,7 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var ...@@ -1977,7 +1977,7 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var
(das_next_attr_nr, th_attrs) (das_next_attr_nr, th_attrs)
= foldSt bind_to_temp_attr_var st_attr_vars (das_next_attr_nr, th_attrs) = foldSt bind_to_temp_attr_var st_attr_vars (das_next_attr_nr, th_attrs)
// prepare for substitute calls // prepare for substitute calls
(_, (st_args, st_result), das_type_heaps) ((st_args, st_result), das_type_heaps)
= substitute (st_args, st_result) { das_type_heaps & th_vars = th_vars, th_attrs = th_attrs } = substitute (st_args, st_result) { das_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
nr_of_applied_args nr_of_applied_args
= symbol_arity = symbol_arity
...@@ -3924,7 +3924,7 @@ where ...@@ -3924,7 +3924,7 @@ where
bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps
# ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps # ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps
ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps) ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps)
(_, type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps (type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps
= (type, ets_type_heaps) = (type, ets_type_heaps)
where where
bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs} bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs}
......
...@@ -353,7 +353,7 @@ unfoldVariable var=:{var_ident,var_info_ptr} ui us ...@@ -353,7 +353,7 @@ unfoldVariable var=:{var_ident,var_info_ptr} ui us
substitute_class_types class_types No substitute_class_types class_types No
= (class_types, No) = (class_types, No)
substitute_class_types class_types (Yes type_heaps) substitute_class_types class_types (Yes type_heaps)
# (_,new_class_types, type_heaps) = substitute class_types type_heaps # (new_class_types, type_heaps) = substitute class_types type_heaps
= (new_class_types, Yes type_heaps) = (new_class_types, Yes type_heaps)
readVarInfo var_info_ptr us readVarInfo var_info_ptr us
...@@ -549,7 +549,7 @@ where ...@@ -549,7 +549,7 @@ where
-> unfold_function_app app ui us -> unfold_function_app app ui us
substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps) substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps)
# (_,new_class_type, type_heaps) = substitute class_type type_heaps # (new_class_type, type_heaps) = substitute class_type type_heaps
= (EI_DictionaryType new_class_type, Yes type_heaps) = (EI_DictionaryType new_class_type, Yes type_heaps)
substitute_EI_DictionaryType x opt_type_heaps substitute_EI_DictionaryType x opt_type_heaps
= (x, opt_type_heaps) = (x, opt_type_heaps)
...@@ -662,10 +662,10 @@ substitute_let_or_case_type (EI_Extended extensions expr_info) yes_type_heaps ...@@ -662,10 +662,10 @@ substitute_let_or_case_type (EI_Extended extensions expr_info) yes_type_heaps
# (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps # (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps
= (EI_Extended extensions new_expr_info, yes_type_heaps) = (EI_Extended extensions new_expr_info, yes_type_heaps)
substitute_let_or_case_type (EI_CaseType case_type) (Yes type_heaps) substitute_let_or_case_type (EI_CaseType case_type) (Yes type_heaps)
# (_,new_case_type, type_heaps) = substitute case_type type_heaps # (new_case_type, type_heaps) = substitute case_type type_heaps
= (EI_CaseType new_case_type, Yes type_heaps) = (EI_CaseType new_case_type, Yes type_heaps)
substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps) substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps)
# (_,new_let_type, type_heaps) = substitute let_type type_heaps # (new_let_type, type_heaps) = substitute let_type type_heaps
= (EI_LetType new_let_type, Yes type_heaps) = (EI_LetType new_let_type, Yes type_heaps)
instance unfold CasePatterns instance unfold CasePatterns
......
...@@ -371,7 +371,7 @@ tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_att ...@@ -371,7 +371,7 @@ tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_att
#! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object] #! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object]
= case type_def.td_rhs of = case type_def.td_rhs of
SynType {at_type} SynType {at_type}
# (_, expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps # (expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps
-> (True, expanded_type, type_heaps) -> (True, expanded_type, type_heaps)
_ _
-> (False, type, type_heaps) -> (False, type, type_heaps)
...@@ -379,7 +379,7 @@ tryToExpand type=:(TAS {type_index={glob_object,glob_module}} type_args _) type_ ...@@ -379,7 +379,7 @@ tryToExpand type=:(TAS {type_index={glob_object,glob_module}} type_args _) type_
#! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object] #! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object]
= case type_def.td_rhs of = case type_def.td_rhs of
SynType {at_type} SynType {at_type}
# (_, expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps # (expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps
-> (True, expanded_type, type_heaps) -> (True, expanded_type, type_heaps)
_ _
-> (False, type, type_heaps) -> (False, type, type_heaps)
......
...@@ -71,12 +71,12 @@ beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHe ...@@ -71,12 +71,12 @@ beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHe
updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap) updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps) class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a, instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a,
(a,b) | substitute a & substitute b (a,b) | substitute a & substitute b
substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps)
bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps;
clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps;
......
...@@ -24,29 +24,33 @@ import genericsupport ...@@ -24,29 +24,33 @@ import genericsupport
| UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType | UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType
simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type) simplifyTypeApplication :: !Type ![AType] -> Type
simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args simplifyTypeApplication type type_args
# (ok, type)
= simplifyAndCheckTypeApplication type type_args
| not ok
= abort "typesupport.simplifyTypeApplication: unexpected error"
= type
simplifyAndCheckTypeApplication :: !Type ![AType] -> (!Bool, !Type)
simplifyAndCheckTypeApplication (TA type_cons=:{type_arity} cons_args) type_args
= (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)) = (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args))
simplifyTypeApplication (TAS type_cons=:{type_arity} cons_args strictness) type_args simplifyAndCheckTypeApplication (TAS type_cons=:{type_arity} cons_args strictness) type_args
= (True, TAS { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) strictness) = (True, TAS { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) strictness)
simplifyTypeApplication (CV tv :@: type_args1) type_args2 simplifyAndCheckTypeApplication (CV tv :@: type_args1) type_args2
= (True, CV tv :@: (type_args1 ++ type_args2)) = (True, CV tv :@: (type_args1 ++ type_args2))
simplifyTypeApplication TArrow [type1, type2] simplifyAndCheckTypeApplication TArrow [type1, type2]
= (True, type1 --> type2) = (True, type1 --> type2)
simplifyTypeApplication TArrow [type] simplifyAndCheckTypeApplication TArrow [type]
= (True, TArrow1 type) = (True, TArrow1 type)
simplifyTypeApplication (TArrow1 type1) [type2] simplifyAndCheckTypeApplication (TArrow1 type1) [type2]
= (True, type1 --> type2) = (True, type1 --> type2)
simplifyTypeApplication (TV tv) type_args simplifyAndCheckTypeApplication (TV tv) type_args
= (True, CV tv :@: type_args) = (True, CV tv :@: type_args)
simplifyTypeApplication (TB _) _ simplifyAndCheckTypeApplication (TempV i) type_args
= (False, TE) = (True, TempCV i :@: type_args)
simplifyTypeApplication (TArrow1 _) _ simplifyAndCheckTypeApplication type type_args
= (False, TE) = (False, type)
simplifyTypeApplication (_ --> _ ) _
= (False, TE)
:: AttributeEnv :== {! TypeAttribute } :: AttributeEnv :== {! TypeAttribute }
:: VarEnv :== {! Type } :: VarEnv :== {! Type }
...@@ -163,7 +167,7 @@ where ...@@ -163,7 +167,7 @@ where
# (type, cus) = cus!cus_var_env.[tempvar] # (type, cus) = cus!cus_var_env.[tempvar]
# (type, cus) = cleanUpVariable cui.cui_top_level type tempvar cus # (type, cus) = cleanUpVariable cui.cui_top_level type tempvar cus
(types, cus) = clean_up cui types cus (types, cus) = clean_up cui types cus
= (snd (simplifyTypeApplication type types), cus) = (simplifyTypeApplication type types, cus)
clean_up cui (TempQCV tempvar :@: types) cus clean_up cui (TempQCV tempvar :@: types) cus
# (type, cus) = cus!cus_var_env.[tempvar] # (type, cus) = cus!cus_var_env.[tempvar]
# (TV tv, cus) = cleanUpVariable cui.cui_top_level type tempvar cus # (TV tv, cus) = cleanUpVariable cui.cui_top_level type tempvar cus
...@@ -257,7 +261,7 @@ where ...@@ -257,7 +261,7 @@ where
| checkCleanUpResult cur1 cUndefinedVar | checkCleanUpResult cur1 cUndefinedVar
= (cur1, TempCV tv_number :@: types, env) = (cur1, TempCV tv_number :@: types, env)
# (cur2, types, env) = cleanUpClosed types env # (cur2, types, env) = cleanUpClosed types env
= (combineCleanUpResults cur1 cur2, snd (simplifyTypeApplication type types), env) = (combineCleanUpResults cur1 cur2, simplifyTypeApplication type types, env)
cleanUpClosed t env cleanUpClosed t env
= (cClosed, t, env) = (cClosed, t, env)
...@@ -583,13 +587,13 @@ where ...@@ -583,13 +587,13 @@ where
# (info, expr_heap) = readPtr expr_ptr expr_heap # (info, expr_heap) = readPtr expr_ptr expr_heap
= case info of = case info of
EI_CaseType case_type EI_CaseType case_type
# (_, case_type, type_heaps) = substitute case_type type_heaps # (case_type, type_heaps) = substitute case_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type)) -> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type))
EI_LetType let_type EI_LetType let_type
# (_, let_type, type_heaps) = substitute let_type type_heaps # (let_type, type_heaps) = substitute let_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type)) -> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type))
EI_DictionaryType dict_type EI_DictionaryType dict_type
# (_, dict_type, type_heaps) = substitute dict_type type_heaps # (dict_type, type_heaps) = substitute dict_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type)) -> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type))
...@@ -637,12 +641,11 @@ instance bindInstances AType ...@@ -637,12 +641,11 @@ instance bindInstances AType
bindInstances {at_type=t1} {at_type=t2} type_var_heap bindInstances {at_type=t1} {at_type=t2} type_var_heap
= bindInstances t1 t2 type_var_heap = bindInstances t1 t2 type_var_heap
substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps)
substituteType form_root_attribute act_root_attribute form_type_args act_type_args orig_type type_heaps substituteType form_root_attribute act_root_attribute form_type_args act_type_args orig_type type_heaps
# type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps # type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps
(ok, expanded_type, type_heaps) = substitute orig_type type_heaps (expanded_type, type_heaps) = substitute orig_type type_heaps
= (ok, expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps) = (expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps)
bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps
bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps
...@@ -671,13 +674,13 @@ where ...@@ -671,13 +674,13 @@ where
clear_attribute _ th_attrs clear_attribute _ th_attrs
= th_attrs = th_attrs
class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps) class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
instance substitute AType instance substitute AType
where where
substitute atype=:{at_attribute,at_type} heaps substitute atype=:{at_attribute,at_type} heaps
# (ok, (at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps # ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps
= (ok, { atype & at_attribute = at_attribute, at_type = at_type }, heaps) = ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps)
instance substitute TypeAttribute instance substitute TypeAttribute
where where
...@@ -685,35 +688,35 @@ where ...@@ -685,35 +688,35 @@ where
#! av_info = sreadPtr av_info_ptr th_attrs #! av_info = sreadPtr av_info_ptr th_attrs
= case av_info of = case av_info of
AVI_Attr attr AVI_Attr attr
-> (True, attr, heaps) -> (attr, heaps)
_ _
-> (True, TA_Multi, heaps) -> (TA_Multi, heaps)
substitute TA_None heaps substitute TA_None heaps
= (True, TA_Multi, heaps) = (TA_Multi, heaps)
substitute attr heaps substitute attr heaps
= (True, attr, heaps) = (attr, heaps)
instance substitute (a,b) | substitute a & substitute b instance substitute (a,b) | substitute a & substitute b
where where
substitute (x,y) heaps substitute (x,y) heaps
# (ok_x, x, heaps) = substitute x heaps # (x, heaps) = substitute x heaps
(ok_y, y, heaps) = substitute y heaps (y, heaps) = substitute y heaps
= (ok_x && ok_y, (x,y), heaps) = ((x,y), heaps)