implementation module typesupport import StdEnv, StdStrictLists, compare_types import syntax, expand_types, unitype, utilities, checktypes :: Store :== Int :: AttrCoercion = { ac_demanded :: !Int , ac_offered :: !Int } :: TempSymbolType = { tst_args :: ![AType] , tst_arity :: !Int , tst_lifted :: !Int , tst_result :: !AType , tst_context :: ![TypeContext] , tst_var_contexts :: !(VarContexts TypeContext) , tst_attr_env :: ![AttrCoercion] } :: FunctionType = CheckedType !SymbolType | SpecifiedType !SymbolType ![AType] !TempSymbolType | UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType :: AttributeEnv :== {! TypeAttribute } :: VarEnv :== {! Type } :: CleanUpState = { cus_var_env :: !.VarEnv , cus_attr_env :: !.AttributeEnv , cus_appears_in_lifted_part :: !.LargeBitvect , cus_heaps :: !.TypeHeaps , cus_var_store :: !Int , cus_attr_store :: !Int , cus_exis_vars :: ![(Int,TypeAttribute)] , cus_error :: !.ErrorAdmin } :: CleanUpInput = { cui_coercions :: !{! CoercionTree} , cui_attr_part :: !AttributePartition , cui_top_level :: !Bool , cui_is_lifted_part :: !Bool } class clean_up a :: !CleanUpInput !a !*CleanUpState -> (!a, !*CleanUpState) instance clean_up AType where clean_up cui atype=:{at_attribute, at_type = TempQV qv_number} cus | cui.cui_top_level = clean_up_top_level_q_variable cui at_attribute qv_number cus clean_up cui atype=:{at_attribute, at_type = TempQDV qv_number} cus | cui.cui_top_level = clean_up_top_level_q_variable cui at_attribute qv_number cus clean_up cui atype=:{at_attribute,at_type} cus # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus (at_type, cus) = clean_up cui at_type cus = ({atype & at_attribute = at_attribute, at_type = at_type}, cus) clean_up_top_level_q_variable cui at_attribute qv_number cus # (at_attribute, cus) = cleanUpTypeAttribute True cui at_attribute cus # (type, cus) = cus!cus_var_env.[qv_number] (var, cus) = cleanUpVariable True type qv_number cus cus = {cus & cus_exis_vars = add_new_exis_attr_var type qv_number at_attribute cus.cus_exis_vars} = ({at_attribute = at_attribute, at_type = var}, cus) where add_new_exis_attr_var TE ev_number ev_attr cus_exis_vars = [(ev_number, ev_attr) : cus_exis_vars] add_new_exis_attr_var type ev_number ev_attr cus_exis_vars = cus_exis_vars attrIsUndefined TA_None = True attrIsUndefined _ = False cleanUpTypeAttribute :: !Bool !CleanUpInput TypeAttribute !*CleanUpState -> (!TypeAttribute, !*CleanUpState) cleanUpTypeAttribute _ cui TA_Unique cus = (TA_Unique, cus) cleanUpTypeAttribute _ cui TA_Multi cus = (TA_Multi, cus) cleanUpTypeAttribute may_be_existential cui tv=:(TA_TempVar av_number) cus | cui.cui_top_level # av_group_nr = cui.cui_attr_part.[av_number] coercion_tree = cui.cui_coercions.[av_group_nr] | isNonUnique coercion_tree = (TA_Multi, cus) | isUnique coercion_tree = (TA_Unique, cus) # cus = check_appearance cui.cui_is_lifted_part av_group_nr cus # (attr, cus) = clean_up_attribute_variable av_group_nr (cus!cus_attr_env.[av_group_nr]) | isExistential coercion_tree | may_be_existential = (attr, { cus & cus_error = checkError "attribute variable could not be universally quantified" "" cus.cus_error}) = (attr, cus) = (attr, cus) = (TA_Multi, cus) where check_appearance is_lifted_part group_nr cus=:{cus_appears_in_lifted_part, cus_error} | is_lifted_part = { cus & cus_appears_in_lifted_part = bitvectSet group_nr cus_appears_in_lifted_part} | bitvectSelect group_nr cus_appears_in_lifted_part = { cus & cus_appears_in_lifted_part = bitvectReset group_nr cus_appears_in_lifted_part, cus_error = checkError "attribute variable of lifted argument appears in the specified type" "" cus_error} = cus clean_up_attribute_variable av_group_nr (TA_None, cus=:{cus_heaps,cus_attr_store,cus_attr_env}) # (av, th_attrs) = NewAttrVar cus_attr_store cus_heaps.th_attrs new_attr_var = TA_Var av = (new_attr_var, { cus & cus_attr_env = { cus_attr_env & [av_group_nr] = new_attr_var}, cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store}) clean_up_attribute_variable av_group_nr attr_and_cus = attr_and_cus cleanUpTypeAttribute _ cui av=:(TA_Var _) cus = (av, cus) cleanUpTypeAttribute _ cui type_attribute cus = abort ("cleanUpTypeAttribute "+++toString type_attribute) instance clean_up Type where clean_up cui (TempV tv_number) cus # (type, cus) = cus!cus_var_env.[tv_number] = cleanUpVariable cui.cui_top_level type tv_number cus clean_up cui (TA tc types) cus # (types, cus) = clean_up cui types cus = (TA tc types, cus) clean_up cui (TAS tc types strictness) cus # (types, cus) = clean_up cui types cus = (TAS tc types strictness, cus) clean_up cui (argtype --> restype) cus # (argtype, cus) = clean_up cui argtype cus (restype, cus) = clean_up cui restype cus = (argtype --> restype, cus) clean_up cui t=:(TB _) cus = (t, cus) clean_up cui (TArrow1 argtype) cus # (argtype, cus) = clean_up cui argtype cus = (TArrow1 argtype, cus) clean_up cui t=:TArrow cus = (t, cus) clean_up cui (TempCV tempvar :@: types) cus # (type, cus) = cus!cus_var_env.[tempvar] # (type, cus) = cleanUpVariable cui.cui_top_level type tempvar cus (types, cus) = clean_up cui types cus = (simplifyTypeApplication type types, cus) clean_up cui (TempQCV qv_number :@: types) cus=:{cus_exis_vars} # (type, cus) = cus!cus_var_env.[qv_number] | cui.cui_top_level # (TV tv, cus) = cleanUpVariable True type qv_number {cus & cus_exis_vars = add_new_variable type qv_number cus_exis_vars} (types, cus) = clean_up cui types cus = (CV tv :@: types, cus) # (TV tv, cus) = cleanUpVariable False type qv_number cus (types, cus) = clean_up cui types cus = (CV tv :@: types, cus) clean_up cui (TempQCDV qv_number :@: types) cus=:{cus_exis_vars} # (type, cus) = cus!cus_var_env.[qv_number] | cui.cui_top_level # (TV tv, cus) = cleanUpVariable True type qv_number {cus & cus_exis_vars = add_new_variable type qv_number cus_exis_vars} (types, cus) = clean_up cui types cus = (CV tv :@: types, cus) # (TV tv, cus) = cleanUpVariable False type qv_number cus (types, cus) = clean_up cui types cus = (CV tv :@: types, cus) clean_up cui (cv :@: types) cus # (types, cus) = clean_up cui types cus = (cv :@: types, cus) clean_up cui (TempQV qv_number) cus=:{cus_error,cus_exis_vars} # (type, cus) = cus!cus_var_env.[qv_number] | cui.cui_top_level = cleanUpVariable True type qv_number {cus & cus_exis_vars = add_new_variable type qv_number cus_exis_vars} = cleanUpVariable False type qv_number cus clean_up cui (TempQDV qv_number) cus=:{cus_error,cus_exis_vars} # (type, cus) = cus!cus_var_env.[qv_number] | cui.cui_top_level = cleanUpVariable True type qv_number {cus & cus_exis_vars = add_new_variable type qv_number cus_exis_vars} = cleanUpVariable False type qv_number cus clean_up cui tv=:(TV _) cus = (tv, cus) clean_up cui (TFA vars type) cus=:{cus_heaps} # (type, cus) = clean_up cui type cus = (TFA vars type, cus) clean_up cui type cus = abort ("clean_up Type (typesupport.icl): unknown type " ---> ("clean_up Type", type)) add_new_variable TE qv_number cus_exis_vars = [(qv_number, TA_None) : cus_exis_vars] add_new_variable type qv_number cus_exis_vars = cus_exis_vars instance clean_up [a] | clean_up a where clean_up cui l cus = mapSt (clean_up cui) l cus instance clean_up DictionaryAndClassType where clean_up cui {dc_var,dc_class_type} cus # (dc_class_type,cus) = clean_up cui dc_class_type cus = ({dc_var=dc_var,dc_class_type=dc_class_type},cus) cleanUpVariable _ TE tv_number cus=:{cus_heaps,cus_var_store,cus_var_env} # (tv_info_ptr, th_vars) = newPtr TVI_Empty cus_heaps.th_vars new_var = TV {tv_ident = NewVarId cus_var_store, tv_info_ptr = tv_info_ptr} = (new_var, {cus & cus_var_env = { cus_var_env & [tv_number] = new_var}, cus_heaps = { cus_heaps & th_vars = th_vars }, cus_var_store = inc cus_var_store}) cleanUpVariable top_level (TLifted var) tv_number cus=:{cus_error} | top_level = (TV var, { cus & cus_error = liftedError var cus_error}) = (TV var, cus) cleanUpVariable _ type tv_number cus = (type, cus) :: CleanUpResult :== BITVECT cClosed :== 0 cDefinedVar :== 1 cUndefinedVar :== 2 cLiftedVar :== 4 cQVar :== 8 cleanUpClosedVariable TE env = (cUndefinedVar, TE, env) cleanUpClosedVariable (TLifted tvar) env = (cLiftedVar, TV tvar, env) cleanUpClosedVariable tvar env = (cDefinedVar, tvar, env) combineCleanUpResults cur1 cur2 :== cur1 bitor cur2 checkCleanUpResult cur prop :== not (cur bitand prop == 0) class cleanUpClosed a :: !a !u:VarEnv -> (!CleanUpResult, !a, !u:VarEnv) instance cleanUpClosed AType where cleanUpClosed atype=:{at_type} env # (cur, at_type, env) = cleanUpClosed at_type env = (cur, { atype & at_attribute = TA_Multi, at_type = at_type}, env) instance cleanUpClosed Type where cleanUpClosed (TempV tv_number) env # (type, env) = env![tv_number] = cleanUpClosedVariable type env cleanUpClosed (TA tc types) env # (cur, types, env) = cleanUpClosed types env = (cur, TA tc types, env) cleanUpClosed (TAS tc types strictness) env # (cur, types, env) = cleanUpClosed types env = (cur, TAS tc types strictness, env) cleanUpClosed (argtype --> restype) env # (cur, (argtype,restype), env) = cleanUpClosed (argtype,restype) env = (cur, argtype --> restype, env) cleanUpClosed (TArrow1 argtype) env # (cur, argtype, env) = cleanUpClosed argtype env = (cur, TArrow1 argtype, env) cleanUpClosed (TempCV tv_number :@: types) env # (type, env) = env![tv_number] # (cur1, type, env) = cleanUpClosedVariable type env | checkCleanUpResult cur1 cUndefinedVar = (cur1, TempCV tv_number :@: types, env) # (cur2, types, env) = cleanUpClosed types env = (combineCleanUpResults cur1 cur2, simplifyTypeApplication type types, env) cleanUpClosed t=:(TempQV _) env = (cQVar, t, env) cleanUpClosed t=:(TempQDV _) env = (cQVar, t, env) cleanUpClosed t env = (cClosed, t, env) instance cleanUpClosed (a,b) | cleanUpClosed a & cleanUpClosed b where cleanUpClosed (x,y) env # (cur1, x, env) = cleanUpClosed x env | checkCleanUpResult cur1 cUndefinedVar = (cur1, (x,y), env) # (cur2, y, env) = cleanUpClosed y env = (combineCleanUpResults cur1 cur2, (x,y), env) instance cleanUpClosed [a] | cleanUpClosed a where cleanUpClosed [] env = (cClosed, [], env) cleanUpClosed [t:ts] env # (cur, (t,ts), env) = cleanUpClosed (t,ts) env = (cur, [t:ts], env) errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin errorHeading error_kind err=:{ea_file,ea_loc = []} = { err & ea_file = ea_file <<< error_kind <<< ':', ea_ok = False } errorHeading error_kind err=:{ea_file,ea_loc = [ loc : _ ]} = { err & ea_file = ea_file <<< error_kind <<< ' ' <<< loc <<< ':', ea_ok = False } contextError class_symb err # err = errorHeading "Overloading error" err = {err & ea_file = err.ea_file <<< " unresolved class \"" <<< class_symb <<< "\" not occurring in specified type\n"} liftedContextError class_symb err # err = errorHeading "Overloading error" err = {err & ea_file = err.ea_file <<< " type variable of type of lifted argument appears in class \"" <<< class_symb <<< "\"\n"} existentialError err # err = errorHeading "Type error" err = { err & ea_file = err.ea_file <<< "existential type variable appears in the derived type specification\n" } liftedError type_var err # err = errorHeading "Type error" err = { err & ea_file = err.ea_file <<< "type variable " <<< type_var <<< " of type of lifted argument appears in the specified type\n" } startRuleError mess err # err = errorHeading "Type error" err = { err & ea_file = err.ea_file <<< mess } extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) extendSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of_extra_args type_heaps | nr_of_extra_args > 0 # (st_args, (st_vars, st_attr_vars, type_heaps)) = newAttributedVariables nr_of_extra_args st_args (st_vars, st_attr_vars, type_heaps) = ({ st & st_args = st_args, st_vars = st_vars, st_attr_vars = st_attr_vars, st_arity = st_arity + nr_of_extra_args }, type_heaps) = (st, type_heaps) cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) cleanSymbolType arity type_heaps # (st_result, clean_state) = newAttributedVariable 0 ([], [], type_heaps) (st_args, (st_vars, st_attr_vars, type_heaps)) = newAttributedVariables arity [] clean_state = ({ st_arity = arity, st_vars = st_vars , st_args = st_args, st_args_strictness=NotStrict, st_result = st_result, st_context = [], st_attr_env = [], st_attr_vars = st_attr_vars }, type_heaps) newAttributedVariables var_number attributed_variables clean_state=:(_,_,_) /* Temporary hack */ | var_number == 0 = (attributed_variables, clean_state) # (attributed_variable, clean_state) = newAttributedVariable var_number clean_state = newAttributedVariables (dec var_number) [ attributed_variable : attributed_variables ] clean_state newAttributedVariable var_number (variables, attributes, type_heaps=:{th_vars,th_attrs}) # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars new_var = { tv_ident = NewVarId var_number, tv_info_ptr = tv_info_ptr } (new_attr_var, th_attrs) = NewAttrVar var_number th_attrs = ({ at_attribute = TA_Var new_attr_var, at_type = TV new_var}, ([ new_var : variables ], [ new_attr_var : attributes ], { type_heaps & th_vars = th_vars, th_attrs = th_attrs })) cSpecifiedType :== True cDerivedType :== False cleanUpSymbolType :: !Bool !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition !*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) cleanUpSymbolType is_start_rule spec_type {tst_arity,tst_args,tst_result,tst_context,tst_lifted} derived_context case_and_let_exprs coercions attr_part var_env attr_var_env heaps var_heap expr_heap error #! nr_of_temp_vars = size var_env #! max_attr_nr = size attr_var_env # cus = { cus_var_env = var_env, cus_attr_env = attr_var_env, cus_appears_in_lifted_part = bitvectCreate max_attr_nr, cus_heaps = heaps, cus_var_store = 0, cus_attr_store = 0, cus_error = error, cus_exis_vars = [] } cui = { cui_coercions = coercions, cui_attr_part = attr_part, cui_top_level = True, cui_is_lifted_part = True } (lifted_args, cus=:{cus_var_env}) = clean_up cui (take tst_lifted tst_args) cus cui = { cui & cui_is_lifted_part = False } (lifted_vars, cus_var_env) = determine_type_vars nr_of_temp_vars [] cus_var_env (st_args, (_, cus)) = mapSt (clean_up_arg_type cui) (drop tst_lifted tst_args) ([], { cus & cus_var_env = cus_var_env }) (st_result, cus) = clean_up_result_type cui tst_result cus (st_context, cus_var_env, var_heap, cus_error) = clean_up_type_contexts spec_type tst_context derived_context cus.cus_var_env var_heap cus.cus_error (st_vars, cus_var_env) = determine_type_vars nr_of_temp_vars lifted_vars cus_var_env (cus_attr_env, st_attr_vars, st_attr_env, cus_error) = build_attribute_environment cus.cus_appears_in_lifted_part 0 max_attr_nr coercions (bitvectCreate max_attr_nr) cus.cus_attr_env [] [] cus_error (expr_heap, {cus_var_env,cus_attr_env,cus_heaps,cus_error}) = clean_up_expression_types {cui & cui_top_level = False} case_and_let_exprs expr_heap {cus & cus_var_env = cus_var_env, cus_attr_env = cus_attr_env, cus_appears_in_lifted_part = {el\\el<-:cus.cus_appears_in_lifted_part}, cus_error = cus_error } st = {st_arity = tst_arity, st_vars = st_vars , st_args = lifted_args ++ st_args, st_args_strictness=NotStrict, st_result = st_result, st_context = st_context, st_attr_env = st_attr_env, st_attr_vars = st_attr_vars } cus_error = check_type_of_start_rule is_start_rule st cus_error = (st, { cus_var_env & [i] = TE \\ i <- [0..nr_of_temp_vars - 1]}, { cus_attr_env & [i] = TA_None \\ i <- [0..max_attr_nr - 1]}, cus_heaps, var_heap, expr_heap, cus_error) where determine_type_vars to_index all_vars var_env = iFoldSt determine_type_var 0 to_index (all_vars, var_env) where determine_type_var var_index (all_vars, var_env) # (type, var_env) = var_env![var_index] = case type of TV var -> ([var : all_vars], { var_env & [var_index] = TLifted var}) _ -> (all_vars, var_env) clean_up_arg_type cui at=:{at_type = TFA avars type, at_attribute} (all_exi_vars, cus) # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus (type, cus) = clean_up cui type cus | isEmpty cus.cus_exis_vars = ({ at & at_type = TFA avars type, at_attribute = at_attribute}, (all_exi_vars, cus)) = ({ at & at_type = TFA avars type, at_attribute = at_attribute}, (all_exi_vars, {cus & cus_error = existentialError cus.cus_error, cus_exis_vars = []})) clean_up_arg_type cui at=:{at_type = TFAC avars type contexts, at_attribute} (all_exi_vars, cus) # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus (type, cus) = clean_up cui type cus | isEmpty cus.cus_exis_vars = ({ at & at_type = TFAC avars type contexts, at_attribute = at_attribute}, (all_exi_vars, cus)) = ({ at & at_type = TFAC avars type contexts, at_attribute = at_attribute}, (all_exi_vars, {cus & cus_error = existentialError cus.cus_error, cus_exis_vars = []})) clean_up_arg_type cui=:{cui_top_level} at (all_exi_vars, cus) # (at, cus) = clean_up cui at cus (cus_exis_vars, cus) = cus!cus_exis_vars | isEmpty cus_exis_vars = (at, (all_exi_vars, cus)) # (new_exi_vars, all_exi_vars, cus) = foldSt check_existential_var cus_exis_vars ([], all_exi_vars, cus) = ({ at & at_type = TFA new_exi_vars at.at_type }, (all_exi_vars, {cus & cus_exis_vars = []})) where check_existential_var (var_number,var_attr) (exi_vars, all_vars, cus) # (type, cus) = cus!cus_var_env.[var_number] | isMember var_number all_vars = case type of TE -> (exi_vars, all_vars, cus) _ # (TV var, cus) = cus!cus_var_env.[var_number] -> ([{atv_attribute = var_attr, atv_variable = var } : exi_vars ], all_vars, {cus & cus_var_env = {cus.cus_var_env & [var_number] = TE }, cus_error = existentialError cus.cus_error }) # all_vars = [var_number : all_vars] = case type of TV var -> ([{atv_attribute=var_attr, atv_variable=var} : exi_vars], all_vars, {cus & cus_var_env.[var_number] = TE}) TLifted var | cui_top_level # cus = {cus & cus_error = liftedError var cus.cus_error, cus_var_env.[var_number] = TE} -> ([{atv_attribute=var_attr, atv_variable=var} : exi_vars], all_vars, cus) -> ([{atv_attribute=var_attr, atv_variable=var} : exi_vars], all_vars, {cus & cus_var_env.[var_number] = TE}) clean_up_result_type cui at cus # (at, cus=:{cus_exis_vars}) = clean_up cui at cus | isEmpty cus_exis_vars = (at, cus) = (at, { cus & cus_error = existentialError cus.cus_error }) clean_up_type_contexts spec_type spec_context derived_context env var_heap error | spec_type # var_heap = foldSt (mark_specified_context derived_context) spec_context var_heap (rev_contexts, env, error) = foldSt clean_up_lifted_type_context derived_context ([], env, error) (rev_contexts, env, var_heap, error) = foldSt clean_up_type_context spec_context (rev_contexts, env, var_heap, error) = (reverse rev_contexts, env, var_heap, error) # (rev_contexts, env, var_heap, error) = foldSt clean_up_type_context derived_context ([], env, var_heap, error) = (reverse rev_contexts, env, var_heap, error) mark_specified_context [] spec_tc var_heap = var_heap mark_specified_context [tc=:{tc_var} : tcs] spec_tc var_heap | spec_tc == tc | spec_tc.tc_var == tc_var = var_heap = var_heap <:= (spec_tc.tc_var, VI_ForwardClassVar tc_var) = mark_specified_context tcs spec_tc var_heap clean_up_type_context tc=:{tc_types,tc_class,tc_var} (collected_contexts, env, var_heap, error) | case sreadPtr tc_var var_heap of VI_EmptyConstructorClassVar-> True; _ -> False = (collected_contexts, env, var_heap, error) # (cur, tc_types, env) = cleanUpClosed tc_types env | checkCleanUpResult cur cUndefinedVar = (collected_contexts, env, var_heap, error) | checkCleanUpResult cur cLiftedVar = ([{ tc & tc_types = tc_types } : collected_contexts ], env, var_heap, liftedContextError (toString tc_class) error) | checkCleanUpResult cur cQVar = (collected_contexts, env, var_heap, error) = ([{ tc & tc_types = tc_types } : collected_contexts ], env, var_heap, error) clean_up_lifted_type_context tc=:{tc_types} (collected_contexts, env, error) # (cur, tc_types, env) = cleanUpClosed tc.tc_types env | checkCleanUpResult cur cLiftedVar | checkCleanUpResult cur cDefinedVar = (collected_contexts, env, liftedContextError (toString tc.tc_class) error) = ([{ tc & tc_types = tc_types } : collected_contexts], env, error) = (collected_contexts, env, error) build_attribute_environment :: !LargeBitvect !Index !Index !{! CoercionTree} !*LargeBitvect !*AttributeEnv ![AttributeVar] ![AttrInequality] !*ErrorAdmin -> (!*AttributeEnv,![AttributeVar],![AttrInequality],!*ErrorAdmin) build_attribute_environment appears_in_lifted_part attr_group_index max_attr_nr coercions already_build_inequalities attr_env attr_vars inequalities error | attr_group_index == max_attr_nr = (attr_env, attr_vars, inequalities, error) # (attr, attr_env) = attr_env![attr_group_index] = case attr of TA_Var attr_var # already_build_inequalities = bitvectResetAll already_build_inequalities # (ok, attr_env, inequalities,already_build_inequalities) = build_inequalities appears_in_lifted_part (bitvectSelect attr_group_index appears_in_lifted_part) attr_var coercions.[attr_group_index] coercions attr_env inequalities already_build_inequalities error = case ok of True -> error _ -> checkError "attribute variable of lifted argument appears in derived attribute inequality" "" error -> build_attribute_environment appears_in_lifted_part (inc attr_group_index) max_attr_nr coercions already_build_inequalities attr_env [attr_var : attr_vars] inequalities error TA_None -> build_attribute_environment appears_in_lifted_part (inc attr_group_index) max_attr_nr coercions already_build_inequalities attr_env attr_vars inequalities error build_inequalities :: {#Int} Bool AttributeVar !CoercionTree {!CoercionTree} !*{!TypeAttribute} [AttrInequality] !*LargeBitvect -> (!Bool,!*{!TypeAttribute},![AttrInequality],!*LargeBitvect) build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var (CT_Node dem_attr left right) coercions attr_env inequalities already_build_inequalities # (ok1, attr_env, inequalities,already_build_inequalities) = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var left coercions attr_env inequalities already_build_inequalities (ok2, attr_env, inequalities,already_build_inequalities) = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var right coercions attr_env inequalities already_build_inequalities # (attr, attr_env) = attr_env![dem_attr] = case attr of TA_Var attr_var | is_new_inequality attr_var off_var inequalities # ok3 = off_appears_in_lifted_part == bitvectSelect dem_attr appears_in_lifted_part -> (ok1 && ok2 && ok3, attr_env, [{ ai_demanded = attr_var, ai_offered = off_var } : inequalities],already_build_inequalities) -> (ok1 && ok2, attr_env, inequalities,already_build_inequalities) TA_None # (already_build_inequality,already_build_inequalities) = bitvectTestAndSet dem_attr already_build_inequalities | already_build_inequality -> (ok1 && ok2, attr_env, inequalities,already_build_inequalities) # (ok3, attr_env, inequalities,already_build_inequalities) = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var coercions.[dem_attr] coercions attr_env inequalities already_build_inequalities #! ok3=ok3 -> (ok1 && ok2 && ok3, attr_env, inequalities,already_build_inequalities) build_inequalities _ _ off_var tree coercions attr_env inequalities already_build_inequalities = (True, attr_env, inequalities,already_build_inequalities) is_new_inequality dem_var off_var [] = True is_new_inequality dem_var off_var [{ ai_demanded, ai_offered } : inequalities] = (dem_var <> ai_demanded || off_var <> ai_offered) && is_new_inequality dem_var off_var inequalities clean_up_expression_types :: !CleanUpInput ![ExprInfoPtr] !*ExpressionHeap !*CleanUpState -> (!*ExpressionHeap,!*CleanUpState); clean_up_expression_types cui expr_ptrs expr_heap cus = foldSt (clean_up_expression_type cui) expr_ptrs (expr_heap, cus) where clean_up_expression_type cui expr_ptr (expr_heap, cus) # (info, expr_heap) = readPtr expr_ptr expr_heap = case info of EI_CaseType case_type # (case_type, cus) = clean_up cui case_type cus -> (expr_heap <:= (expr_ptr, EI_CaseType case_type), cus) EI_LetType let_type # (let_type, cus) = clean_up cui let_type cus -> (expr_heap <:= (expr_ptr, EI_LetType let_type), cus) EI_DictionaryType dict_type # (dict_type, cus) = clean_up cui dict_type cus -> (expr_heap <:= (expr_ptr, EI_DictionaryType dict_type), cus) EI_ContextWithVarContexts class_expressions var_contexts # (var_contexts,cus) = clean_up_var_contexts var_contexts cus -> (writePtr expr_ptr (EI_ContextWithVarContexts class_expressions var_contexts) expr_heap,cus) where clean_up_var_contexts (VarContext arg_n type_contexts arg_atype var_contexts) cus # (type_contexts,cus) = clean_up cui type_contexts cus (arg_atype,cus) = clean_up cui arg_atype cus (var_contexts,cus) = clean_up_var_contexts var_contexts cus = (VarContext arg_n type_contexts arg_atype var_contexts,cus) clean_up_var_contexts NoVarContexts cus = (NoVarContexts,cus) EI_CaseTypeWithContexts case_type constructor_contexts # (case_type, cus) = clean_up cui case_type cus (constructor_contexts, cus) = clean_up_constructor_contexts cui constructor_contexts cus -> (expr_heap <:= (expr_ptr, EI_CaseTypeWithContexts case_type constructor_contexts), cus) where clean_up_constructor_contexts cui [(ds,type_contexts):constructor_contexts] cus # (type_contexts,cus) = clean_up_type_contexts cui type_contexts cus (constructor_contexts,cus) = clean_up_constructor_contexts cui constructor_contexts cus = ([(ds,type_contexts):constructor_contexts],cus) clean_up_constructor_contexts cui [] cus = ([],cus) clean_up_type_contexts cui [type_contexts=:{tc_types}:constructor_contexts] cus # (tc_types,cus) = clean_up cui tc_types cus (constructor_contexts,cus) = clean_up_type_contexts cui constructor_contexts cus = ([{type_contexts & tc_types=tc_types}:constructor_contexts],cus) clean_up_type_contexts cui [] cus = ([],cus) check_type_of_start_rule is_start_rule {st_context,st_arity,st_args} cus_error | is_start_rule | isEmpty st_context | st_arity > 0 | st_arity == 1 = case st_args of [{at_type = TB BT_World} : _] -> cus_error _ -> startRuleError "argument of Start rule should have type World.\n" cus_error = startRuleError "Start rule has too many arguments.\n" cus_error = cus_error = startRuleError "Start rule cannot be overloaded.\n" cus_error = cus_error instance clean_up CaseType where clean_up cui ctype=:{ct_pattern_type,ct_result_type, ct_cons_types} cus # (ct_pattern_type, cus) = clean_up cui ct_pattern_type cus (ct_result_type, cus) = clean_up cui ct_result_type cus (ct_cons_types, cus) = mapSt (mapSt (clean_up_arg_type cui)) ct_cons_types cus = ({ctype & ct_pattern_type = ct_pattern_type, ct_cons_types = ct_cons_types, ct_result_type = ct_result_type}, cus) where clean_up_arg_type cui at=:{at_type = TFA avars type, at_attribute} cus # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus (type, cus) = clean_up cui type cus = ({ at & at_type = TFA avars type, at_attribute = at_attribute}, cus) clean_up_arg_type cui at=:{at_type = TFAC avars type contexts, at_attribute} cus # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus (type, cus) = clean_up cui type cus = ({ at & at_type = TFAC avars type contexts, at_attribute = at_attribute}, cus) clean_up_arg_type cui at cus = clean_up cui at cus /* In 'bindInstances t1 t2' type variables of t1 are bound to the corresponding subtypes of t2, provided that t2 is a substitution instance of t1. Binding is done by setting the 'tv_info_ptr' of the variables of t1 to 'TVI_Type t' were t is the subtype to which the type variable is matched. Be careful with calling 'bindInstances': all the 'tv_info_ptr'-info's should be cleaned first, unless one is sure that t1 does not contain any 'tv_info_ptr' with value 'TVI_Type ...'. instance bindInstances AType, Type, [a] | bindInstances a */ updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap) updateExpressionTypes {st_args,st_vars,st_result,st_attr_vars} st_copy type_ptrs heaps=:{th_vars,th_attrs} expr_heap # th_vars = foldSt (\{tv_info_ptr} var_heap -> var_heap <:= (tv_info_ptr, TVI_Empty)) st_vars th_vars th_attrs = foldSt (\{av_info_ptr} attr_heap -> attr_heap <:= (av_info_ptr, AVI_Empty)) st_attr_vars th_attrs heaps = fold2St bind_instances_in_arg_type st_args st_copy.st_args {heaps & th_vars = th_vars, th_attrs = th_attrs} th_vars = bindInstances st_result st_copy.st_result heaps.th_vars = foldSt update_expression_type type_ptrs ({heaps & th_vars = th_vars}, expr_heap) where bind_instances_in_arg_type {at_type = TFA vars type1} {at_type = TFA _ type2} heaps # heaps = clear_atype_vars vars heaps = {heaps & th_vars = bindInstances type1 type2 heaps.th_vars} bind_instances_in_arg_type {at_type = TFAC vars type1 _} {at_type = TFAC _ type2 _} heaps # heaps = clear_atype_vars vars heaps = {heaps & th_vars = bindInstances type1 type2 heaps.th_vars} bind_instances_in_arg_type { at_type } atype2 heaps=:{th_vars} = { heaps & th_vars = bindInstances at_type atype2.at_type th_vars } clear_atype_vars vars heaps = foldSt clear_atype_var vars heaps where clear_atype_var {atv_variable={tv_info_ptr},atv_attribute} heaps=:{th_vars,th_attrs} = {heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attribute atv_attribute th_attrs} clear_attribute (TA_Var {av_info_ptr}) attr_heap = attr_heap <:= (av_info_ptr, AVI_Empty) clear_attribute _ attr_heap = attr_heap update_expression_type expr_ptr (type_heaps, expr_heap) # (info, expr_heap) = readPtr expr_ptr expr_heap = case info of EI_CaseType case_type # (changed, case_type_r, type_heaps) = substitute case_type type_heaps | changed -> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type_r)) -> (type_heaps, expr_heap) EI_LetType let_type # (changed, let_type_r, type_heaps) = substitute let_type type_heaps | changed -> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type_r)) -> (type_heaps, expr_heap) EI_DictionaryType dict_type # (_, dict_type, type_heaps) = substitute dict_type type_heaps -> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type)) EI_ContextWithVarContexts class_expressions var_contexts # (var_contexts,type_heaps) = substitute_var_contexts var_contexts type_heaps -> (type_heaps,writePtr expr_ptr (EI_ContextWithVarContexts class_expressions var_contexts) expr_heap) where substitute_var_contexts (VarContext arg_n type_contexts arg_atype var_contexts) type_heaps # (_, type_contexts,type_heaps) = substitute type_contexts type_heaps (_, arg_atype,type_heaps) = substitute arg_atype type_heaps (var_contexts,type_heaps) = substitute_var_contexts var_contexts type_heaps = (VarContext arg_n type_contexts arg_atype var_contexts,type_heaps) substitute_var_contexts NoVarContexts type_heaps = (NoVarContexts,type_heaps) EI_CaseTypeWithContexts case_type constructor_contexts # (_,case_type, type_heaps) = substitute case_type type_heaps (constructor_contexts, type_heaps) = substitute_constructor_contexts constructor_contexts type_heaps -> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseTypeWithContexts case_type constructor_contexts)) where substitute_constructor_contexts [(cons_symbol,context):constructor_contexts] type_heaps # (_, context, type_heaps) = substitute context type_heaps (constructor_contexts, type_heaps) = substitute_constructor_contexts constructor_contexts type_heaps = ([(cons_symbol,context):constructor_contexts],type_heaps) substitute_constructor_contexts [] type_heaps = ([],type_heaps) instance substitute DictionaryAndClassType where substitute {dc_var,dc_class_type} type_heaps # (changed,dc_class_type_r,type_heaps) = substitute dc_class_type type_heaps | changed = (True, {dc_var=dc_var,dc_class_type=dc_class_type_r},type_heaps) = (False, {dc_var=dc_var,dc_class_type=dc_class_type},type_heaps) class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap instance bindInstances Type where bindInstances (TV {tv_info_ptr}) type type_var_heap # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap = case tv_info of TVI_Type ind_type -> type_var_heap _ -> type_var_heap <:= (tv_info_ptr, TVI_Type type) bindInstances (TA _ arg_types1) (TA _ arg_types2) type_var_heap = bindInstances arg_types1 arg_types2 type_var_heap bindInstances (TA _ arg_types1) (TAS _ arg_types2 _) type_var_heap = bindInstances arg_types1 arg_types2 type_var_heap bindInstances (TAS _ arg_types1 _) (TA _ arg_types2) type_var_heap = bindInstances arg_types1 arg_types2 type_var_heap bindInstances (TAS _ arg_types1 _) (TAS _ arg_types2 _) type_var_heap = bindInstances arg_types1 arg_types2 type_var_heap bindInstances (l1 --> r1) (l2 --> r2) type_var_heap = bindInstances r1 r2 (bindInstances l1 l2 type_var_heap) bindInstances (TB _) (TB _) type_var_heap = type_var_heap bindInstances TArrow TArrow type_var_heap = type_var_heap bindInstances (TArrow1 x1) (TArrow1 x2) type_var_heap = bindInstances x1 x2 type_var_heap bindInstances (TFA _ type1) (TFA _ type2) type_var_heap = bindInstances type1 type2 type_var_heap bindInstances (CV l1 :@: r1) (CV l2 :@: r2) type_var_heap = bindInstances r1 r2 (bindInstances (TV l1) (TV l2) type_var_heap) instance bindInstances [a] | bindInstances a where bindInstances [] [] type_var_heap = type_var_heap bindInstances [x:xs] [y:ys] type_var_heap = bindInstances xs ys (bindInstances x y type_var_heap) instance bindInstances AType where bindInstances {at_type=t1} {at_type=t2} type_var_heap = bindInstances t1 t2 type_var_heap 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 # type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps (_, expanded_type, type_heaps) = substitute orig_type type_heaps = (expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps) bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps # th_attrs = bind_attribute form_root_attribute act_root_attribute type_heaps.th_attrs = fold2St bind_type_and_attr form_type_args act_type_args { type_heaps & th_attrs = th_attrs } where bind_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} {at_type,at_attribute} type_heaps=:{th_vars,th_attrs} = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = bind_attribute atv_attribute at_attribute th_attrs } bind_attribute (TA_Var {av_info_ptr}) attr th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attr) bind_attribute _ _ th_attrs = th_attrs clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps # th_attrs = clear_attribute form_root_attribute type_heaps.th_attrs = foldSt clear_type_and_attr form_type_args { type_heaps & th_attrs = th_attrs } where clear_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} type_heaps=:{th_vars,th_attrs} = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attribute atv_attribute th_attrs } clear_attribute (TA_Var {av_info_ptr}) th_attrs = th_attrs <:= (av_info_ptr, AVI_Empty) clear_attribute _ th_attrs = th_attrs /* expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs} # type_heaps = bindTypeVarsAndAttributes form_attr act_attr type_args arg_types type_heaps (_, exp_type, type_heaps) = substitute type_rhs type_heaps = (exp_type, clearBindingsOfTypeVarsAndAttributes form_attr type_args type_heaps) */ VarIdTable :: {# String} VarIdTable =: { "a", "b", "c", "d", "e", "f", "g", "h", "i", "j" } newIdent id_name :== { id_name = id_name, id_info = nilPtr } NewVarId var_store | var_store < size VarIdTable = newIdent VarIdTable.[var_store] = newIdent ("v" +++ toString var_store) AttrVarIdTable :: {!Ident} AttrVarIdTable =: {newIdent i \\ i<-: {# "u", "v", "w", "x", "y", "z" }} AttrVarIdTables :: [#{!Ident}] AttrVarIdTables =: [# let first_i=12*(1<
(!AttributeVar,!*AttrVarHeap) NewAttrVar attr_var_store th_attrs | attr_var_store < size AttrVarIdTable # (av_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs = ({av_ident=AttrVarIdTable.[attr_var_store],av_info_ptr=av_info_ptr},th_attrs) = getAttrVarId AttrVarIdTables (attr_var_store-6) 12 th_attrs where getAttrVarId [#attrVarIds_array:attrVarId_list] i p th_attrs | i
(!Bool, !*TypeHeaps)
instance equiv AType
where
equiv atype1 atype2 heaps=:{th_attrs}
# (ok, th_attrs) = equi_attrs atype1.at_attribute atype2.at_attribute th_attrs
| ok
= equiv atype1.at_type atype2.at_type { heaps & th_attrs = th_attrs }
= (False, { heaps & th_attrs = th_attrs })
where
equi_attrs attr=:(TA_Var {av_info_ptr}) (TA_TempVar av_number) attr_var_heap
# (av_info, attr_var_heap) = readPtr av_info_ptr attr_var_heap
= case av_info of
AVI_Forward forw_var_number
-> (forw_var_number == av_number, attr_var_heap)
_
-> (True, writePtr av_info_ptr (AVI_Forward av_number) attr_var_heap)
equi_attrs (TA_Var _) (TA_Var _) attr_var_heap
= (True, attr_var_heap)
equi_attrs attr1 attr2 attr_var_heap
= (attr1 == attr2, attr_var_heap)
equivTypeVars :: !TypeVar !TempVarId !*TypeVarHeap -> (!Bool, !*TypeVarHeap)
equivTypeVars {tv_info_ptr} var_number type_var_heap
# (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
= case tv_info of
TVI_Forward forw_var_number
-> (forw_var_number == var_number, type_var_heap)
_
-> (True, type_var_heap <:= (tv_info_ptr, TVI_Forward var_number))
instance equiv Type
where
equiv (TV tv) (TempV var_number) heaps=:{th_vars}
# (equiv, th_vars) = equivTypeVars tv var_number th_vars
= (equiv, { heaps & th_vars = th_vars })
equiv (TV tv1) (TV tv2) heaps
= (True, heaps)
equiv (arg_type1 --> restype1) (arg_type2 --> restype2) heaps
= equiv (arg_type1,restype1) (arg_type2,restype2) heaps
equiv (TArrow1 arg_type1) (TArrow1 arg_type2) heaps
= equiv arg_type1 arg_type2 heaps
equiv TArrow TArrow heaps
= (True, heaps)
equiv (TA tc1 types1) (TA tc2 types2) heaps
| tc1 == tc2
= equiv types1 types2 heaps
= (False, heaps)
equiv (TA tc1 types1) (TAS tc2 types2 _) heaps
| tc1 == tc2
= equiv types1 types2 heaps
= (False, heaps)
equiv (TAS tc1 types1 _) (TA tc2 types2) heaps
| tc1 == tc2
= equiv types1 types2 heaps
= (False, heaps)
equiv (TAS tc1 types1 _) (TAS tc2 types2 _) heaps
| tc1 == tc2
= equiv types1 types2 heaps
= (False, heaps)
equiv (TB basic1) (TB basic2) heaps
= (basic1 == basic2, heaps)
equiv (CV tv :@: types1) (TempCV var_number :@: types2) heaps=:{th_vars}
# (equi_vars, th_vars) = equivTypeVars tv var_number th_vars
| equi_vars
= equiv types1 types2 { heaps & th_vars = th_vars }
= (False, { heaps & th_vars = th_vars })
equiv (CV tv1 :@: types1) (CV tv2 :@: types2) heaps
// should occur only for A. type variables
= equiv types1 types2 heaps
equiv (TFA vars1 type1) (TFA vars2 type2) heaps
= equiv type1 type2 heaps
equiv (TFAC vars1 type1 _) (TFAC vars2 type2 _) heaps
= equiv type1 type2 heaps
equiv type1 type2 heaps
= (False, heaps)
instance equiv (a,b) | equiv a & equiv b
where
equiv (x1,y1) (x2,y2) heaps
# (equi_x, heaps) = equiv x1 x2 heaps
| equi_x
= equiv y1 y2 heaps
= (False, heaps)
instance equiv [a] | equiv a
where
equiv [x:xs] [y:ys] heaps
# (equi, heaps) = equiv x y heaps
| equi
= equiv xs ys heaps
= (False, heaps)
equiv [] [] heaps
= (True, heaps)
equiv _ _ heaps
= (False, heaps)
equivalent :: !SymbolType !TempSymbolType !Int !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps)
equivalent st=:{st_args,st_result,st_context,st_attr_env} tst=:{tst_args,tst_result,tst_context,tst_attr_env,tst_lifted} nr_of_contexts defs attr_env heaps
# nr_of_lifted_contexts = length st_context - nr_of_contexts
# (ok, heaps) = equiv (drop tst_lifted st_args,st_result) (drop tst_lifted tst_args,tst_result) heaps
| ok
# (ok, heaps) = equivalent_list_of_contexts (drop nr_of_lifted_contexts st_context) (drop nr_of_lifted_contexts tst_context) defs heaps
| ok
# (ok, attr_env, attr_var_heap) = equivalent_environments st_attr_env (fill_environment tst_attr_env attr_env) heaps.th_attrs
= (ok, clear_environment tst_attr_env attr_env, { heaps & th_attrs = attr_var_heap })
= (False, attr_env, heaps)
= (False, attr_env, heaps)
where
equivalent_list_of_contexts [] contexts defs heaps
= (True, heaps)
equivalent_list_of_contexts [tc : tcs] contexts defs heaps
# (ok, heaps) = contains_context tc contexts defs heaps
| ok
= equivalent_list_of_contexts tcs contexts defs heaps
= (False, heaps)
contains_context tc1 [tc2 : tcs] defs heaps
# (ok, heaps) = equivalent_contexts tc1 tc2 defs heaps
| ok
= (True, heaps)
= contains_context tc1 tcs defs heaps
contains_context tc1 [] defs heaps
= (False, heaps)
equivalent_contexts tc1=:{tc_class=TCGeneric {gtc_class=class1}} tc2=:{tc_class=TCGeneric {gtc_class=class2}} defs heaps
= equivalent_contexts {tc1 & tc_class = TCClass class1} {tc2 & tc_class = TCClass class2} defs heaps
equivalent_contexts tc1=:{tc_class=TCGeneric {gtc_class=class1}} tc2 defs heaps
= equivalent_contexts {tc1 & tc_class = TCClass class1} tc2 defs heaps
equivalent_contexts tc1 tc2=:{tc_class=TCGeneric {gtc_class=class2}} defs heaps
= equivalent_contexts tc1 {tc2 & tc_class = TCClass class2} defs heaps
equivalent_contexts tc1=:{tc_class=TCClass class1, tc_types=types1} {tc_class=TCClass class2, tc_types=types2} defs heaps
| class1 == class2
# (ok, heaps) = equiv types1 types2 heaps
= (ok, heaps)
# {glob_object={ds_index},glob_module} = class2
#! class_def = defs.[glob_module].com_class_defs.[ds_index]
# {class_context,class_args} = class_def
| isEmpty class_context
= (False, heaps)
# th_vars = bind_class_args class_args types2 heaps.th_vars
= equivalent_superclasses class_context tc1 defs { heaps & th_vars = th_vars }
where
bind_class_args [{tv_info_ptr} : vars] [type : types] type_var_heap
= bind_class_args vars types (writePtr tv_info_ptr (TVI_Type type) type_var_heap)
bind_class_args [] [] type_var_heap
= type_var_heap
equivalent_superclasses [] tc defs heaps
= (False, heaps)
equivalent_superclasses [super_tc=:{tc_types} : tcs] tc defs heaps=:{th_vars}
# (tc_types, th_vars) = retrieve_types tc_types th_vars
(ok, heaps) = equivalent_contexts { super_tc & tc_types = tc_types } tc defs { heaps & th_vars = th_vars }
| ok
= (True, heaps)
= equivalent_superclasses tcs tc defs heaps
where
retrieve_types [TV {tv_info_ptr} : types] type_var_heap
#! (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
# (TVI_Type type) = tv_info
#! (types, type_var_heap) = retrieve_types types type_var_heap
= ([type : types], type_var_heap)
retrieve_types [type : types] type_var_heap
#! (types, type_var_heap) = retrieve_types types type_var_heap
= ([type : types], type_var_heap)
retrieve_types [] type_var_heap
= ([], type_var_heap)
fill_environment :: ![AttrCoercion] !*{! TypeAttribute} -> *{! TypeAttribute}
fill_environment [] attr_env
= attr_env
fill_environment [{ac_demanded,ac_offered} : coercions ] attr_env
# (offered, attr_env) = attr_env![ac_demanded]
= fill_environment coercions { attr_env & [ac_demanded] = TA_List ac_offered offered }
clear_environment :: ![AttrCoercion] !*{! TypeAttribute} -> *{! TypeAttribute}
clear_environment [] attr_env
= attr_env
clear_environment [{ac_demanded,ac_offered} : coercions ] attr_env
= clear_environment coercions { attr_env & [ac_demanded] = TA_None }
equivalent_environments inequalities attr_env attr_heap
= foldSt equivalent_inequality inequalities (True, attr_env, attr_heap)
/*
equivalent_environments [] attr_env attr_heap
= (True, attr_env, attr_heap)
equivalent_environments [{ai_demanded,ai_offered} : coercions ] attr_env attr_heap
# (AVI_Forward demanded_var_number, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap
(AVI_Forward offered_var_number, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap
# (offered_of_demanded, attr_env) = attr_env![demanded_var_number]
attr_env = { attr_env & [demanded_var_number] = TA_Locked offered_of_demanded }
# (succ, locked_attributes, attr_env) = contains_coercion offered_var_number offered_of_demanded [demanded_var_number] attr_env
attr_env = foldSt unlock_attribute locked_attributes attr_env
| succ
= equivalent_environments coercions attr_env attr_heap
= (False, attr_env, attr_heap)
*/
equivalent_inequality {ai_demanded,ai_offered} (equiv, attr_env, attr_heap)
| equiv
# (dem_forward, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap
= case dem_forward of
AVI_Forward demanded_var_number
# (AVI_Forward offered_var_number, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap
(offered_of_demanded, attr_env) = attr_env![demanded_var_number]
attr_env = { attr_env & [demanded_var_number] = TA_Locked offered_of_demanded }
(succ, locked_attributes, attr_env) = contains_coercion offered_var_number offered_of_demanded [demanded_var_number] attr_env
attr_env = foldSt unlock_attribute locked_attributes attr_env
-> (succ, attr_env, attr_heap)
_
-> (True, attr_env, attr_heap)
= (False, attr_env, attr_heap)
// contains_coercion :: !Int !TypeAttribute ![Int] !u:{! TypeAttribute} -> (!Bool, ![Int], !u:{!TypeAttribute})
contains_coercion offered TA_None locked_attributes attr_env
= (False, locked_attributes, attr_env)
contains_coercion offered (TA_List this_offered next_offered) locked_attributes attr_env
| offered == this_offered
= (True, locked_attributes, attr_env)
# (succ, locked_attributes, attr_env) = contains_coercion offered next_offered locked_attributes attr_env
| succ
= (True, locked_attributes, attr_env)
# (offered_of_offered, attr_env) = attr_env![this_offered]
| is_locked offered_of_offered
= (False, locked_attributes, attr_env)
= contains_coercion offered offered_of_offered [this_offered : locked_attributes] { attr_env & [this_offered] = TA_Locked offered_of_offered }
contains_coercion offered (TA_Locked _) locked_attributes attr_env
= (False, locked_attributes, attr_env)
unlock_attribute attr_number attr_env
# (TA_Locked attr, attr_env) = attr_env![attr_number]
= { attr_env & [attr_number] = attr }
is_locked (TA_Locked _) = True
is_locked _ = False
:: Format =
{ form_properties :: !BITVECT
, form_attr_position :: Optional ([Int], Coercions)
}
cNoProperties :== 0
cAttributed :== 1
cAnnotated :== 2
cMarkAttribute :== 4
cBrackets :== 8
cCommaSeparator :== 16
cArrowSeparator :== 32
cAndSeparator :== 64
checkProperty form property :== not (form.form_properties bitand property == 0)
setProperty form property :== {form & form_properties = form.form_properties bitor property}
clearProperty form property :== {form & form_properties = form.form_properties bitand (bitnot property)}
(<::) infixl :: !*File !(!Format, !a, !Optional TypeVarBeautifulizer) -> *File | writeType a
(<::) file (format, a, opt_beautifulizer)
# (file, _) = writeType file opt_beautifulizer (format, a)
= file
class writeType a :: !*File !(Optional TypeVarBeautifulizer) !(!Format, !a) -> (!*File, !Optional TypeVarBeautifulizer)
instance writeType AttributeVar
where
writeType file No (_, av)
= (file <<< av, No)
writeType file (Yes beautifulizer) (_, av)
= writeBeautifulAttrVar file beautifulizer (TA_Var av)
:: SAType = {s_annotation::!Annotation,s_type::!AType}
add_strictness_annotations :: [AType] Int StrictnessList -> [SAType]
add_strictness_annotations [arg:args] strictness_index strictness
# annotation=arg_strictness_annotation strictness_index strictness
# args=add_strictness_annotations args (strictness_index+1) strictness
= [{s_annotation=annotation,s_type=arg}:args]
add_strictness_annotations [] strictness_index strictness
= []
instance writeType SymbolType
where
writeType file opt_beautifulizer (form, {st_args, st_args_strictness,st_arity, st_result, st_context, st_attr_env})
# file_opt_beautifulizer
= case st_arity of
0
-> writeType file opt_beautifulizer (bracket_arrow_type st_result.at_type form, st_result)
with
bracket_arrow_type (_ --> _) form
= setProperty form cBrackets
bracket_arrow_type _ form
= form
_
# (file, opt_beautifulizer)
// = writeType file opt_beautifulizer (form, st_args)
= write_arguments file opt_beautifulizer form st_args
with
write_arguments file opt_beautifulizer form st_args
| checkProperty form cAnnotated
= writeType file opt_beautifulizer (form, add_strictness_annotations st_args 0 st_args_strictness)
= writeType file opt_beautifulizer (form, st_args)
-> writeType (file <<< " -> ") opt_beautifulizer (form, st_result)
(file, opt_beautifulizer)
= show_context form st_context file_opt_beautifulizer
= case isEmpty st_attr_env || not (checkProperty form cAttributed) of
True
-> (file, opt_beautifulizer)
False
# (file, opt_beautifulizer)
= writeType (file <<< ", [") opt_beautifulizer
(setProperty form cCommaSeparator, grouped (hd st_attr_env).ai_demanded [] st_attr_env)
-> (file <<< ']', opt_beautifulizer)
where
// grouped takes care that inequalities like [a<=c, b<=c] are printed like [a b <= c]
grouped group_var accu []
= [{ ig_offered = accu, ig_demanded = group_var}]
grouped group_var accu [{ai_offered, ai_demanded}:ineqs]
| group_var==ai_demanded
= grouped group_var [ai_offered:accu] ineqs
=[{ ig_offered = accu, ig_demanded = group_var}: grouped ai_demanded [ai_offered] ineqs]
show_context form [] file_opt_beautifulizer
= file_opt_beautifulizer
show_context form contexts (file, opt_beautifulizer)
= writeType (file <<< " | ") opt_beautifulizer (setProperty form cAndSeparator, contexts)
:: InequalityGroup =
{ ig_offered :: ![AttributeVar]
, ig_demanded :: !AttributeVar
}
instance writeType InequalityGroup
where
writeType file opt_beautifulizer (form, {ig_offered,ig_demanded})
# (file, opt_beautifulizer)
= writeType file opt_beautifulizer (form, ig_offered)
= writeType (file <<< " <= ") opt_beautifulizer (form, ig_demanded)
instance writeType TypeContext
where
//writeType file opt_beautifulizer (form, {tc_class={glob_object={ds_ident}}, tc_types})
// = writeType (file <<< ds_ident <<< ' ') opt_beautifulizer (form, tc_types)
writeType file opt_beautifulizer (form, {tc_class, tc_types})
# file = write_tc_class tc_class file
= writeType (file <<< ' ') opt_beautifulizer (form, tc_types)
where
write_tc_class (TCClass {glob_object={ds_ident}}) file
= file <<< ds_ident
write_tc_class (TCGeneric {gtc_class={glob_object={ds_ident={id_name}}},gtc_kind}) file
= write_generic_class (size id_name-1) id_name gtc_kind
where
write_generic_class i class_name kind
| i>0
| class_name.[i]<>'_'
= write_generic_class (i-1) class_name kind
= file <<< (class_name % (0,i-1)) <<< "{|" <<< gtc_kind <<< "|}"
= file <<< class_name
instance writeType SAType
where
writeType file opt_beautifulizer (form, {s_annotation, s_type})
= writeType (file <<< s_annotation) opt_beautifulizer (form,s_type)
instance writeType AType
where
writeType file opt_beautifulizer (form, {at_attribute, at_type})
= show_attributed_type file opt_beautifulizer form at_attribute at_type
where
show_attributed_type file opt_beautifulizer form TA_Multi type
| checkProperty form cMarkAttribute
# (file, opt_beautifulizer)
= show_marked_attribute file opt_beautifulizer (form, TA_Multi)
= writeType file opt_beautifulizer (form, type)
= writeType file opt_beautifulizer (form, type)
show_attributed_type file opt_beautifulizer form TA_None type
| checkProperty form cMarkAttribute
# (file, opt_beautifulizer)
= show_marked_attribute file opt_beautifulizer (form, TA_None)
= writeType file opt_beautifulizer (form, type)
= writeType file opt_beautifulizer (form, type)
show_attributed_type file opt_beautifulizer form attr type
| checkProperty form cAttributed
# (file, opt_beautifulizer)
= writeType file opt_beautifulizer (form, attr)
= writeType file opt_beautifulizer (setProperty form cBrackets, type)
| checkProperty form cMarkAttribute
# (file, opt_beautifulizer)
= show_marked_attribute file opt_beautifulizer (form, attr)
= writeType file opt_beautifulizer (setProperty form cBrackets, type)
= writeType file opt_beautifulizer (form, type)
show_marked_attribute file opt_beautifulizer (form=:{form_attr_position = Yes (positions, coercions)}, attr)
| isEmpty positions
= show_attribute coercions (file <<< "^ ") opt_beautifulizer (form, attr)
= show_attribute coercions file opt_beautifulizer (form, attr)
show_attribute coercions file opt_beautifulizer (form, ta=:(TA_TempVar av_number))
| isUniqueAttribute av_number coercions
= writeType file opt_beautifulizer (form, TA_Unique)
| isNonUniqueAttribute av_number coercions
= writeType file opt_beautifulizer (form, TA_Multi)
= writeType file opt_beautifulizer (form, ta)
show_attribute coercions file opt_beautifulizer (form, ta)
= writeType file opt_beautifulizer (form, ta)
instance writeType TypeAttribute
where
writeType file (Yes beautifulizer) (form, ta=:TA_Var _)
= writeBeautifulAttrVarAndColon file beautifulizer ta
writeType file (Yes beautifulizer) (form, TA_RootVar av)
= writeBeautifulAttrVarAndColon file beautifulizer (TA_Var av)
writeType file (Yes beautifulizer) (form, ta=:TA_TempVar _)
= writeBeautifulAttrVarAndColon file beautifulizer ta
writeType file yes_beautifulizer=:(Yes _) (form, TA_Multi)
= (file, yes_beautifulizer)
writeType file opt_beautifulizer (_, ta)
= (file <<< ta, opt_beautifulizer)
writeBeautifulAttrVarAndColon file beautifulizer ta
# (file, yes_beautifulizer)
= writeBeautifulAttrVar file beautifulizer ta
= (file <<< ':', yes_beautifulizer)
instance writeType Type
where
writeType file No (form, TV varid)
= (file <<< varid, No)
writeType file No (form, TempV tv_number)
= (file <<< 'v' <<< tv_number, No)
writeType file opt_beautifulizer (form, TA type_symb types)
= writeTypeTA file opt_beautifulizer form type_symb types
writeType file opt_beautifulizer (form, TAS type_symb types strictness)
| checkProperty form cAnnotated
= writeTypeTA file opt_beautifulizer form type_symb (add_strictness_annotations types 0 strictness)
= writeTypeTA file opt_beautifulizer form type_symb types
writeType file opt_beautifulizer (form, arg_type --> res_type)
| checkProperty form cBrackets
= writeWithinBrackets "(" ")" file opt_beautifulizer
(setProperty form cArrowSeparator, [arg_type, res_type])
= writeType file opt_beautifulizer (setProperty form (cBrackets bitor cArrowSeparator), [arg_type, res_type])
writeType file opt_beautifulizer (form, type :@: types)
| checkProperty form cBrackets
# (file, opt_beautifulizer)
= writeType (file <<< '(') opt_beautifulizer (form, type)
(file, opt_beautifulizer)
= writeType (file <<< ' ') opt_beautifulizer (form, types)
= (file <<< ')', opt_beautifulizer)
# (file, opt_beautifulizer)
= writeType file opt_beautifulizer (form, type)
(file, opt_beautifulizer)
= writeType (file <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
= (file, opt_beautifulizer)
writeType file opt_beautifulizer (form, TB tb)
= (file <<< tb, opt_beautifulizer)
writeType file (Yes beautifulizer) (_, type_var=:TV _)
= writeBeautifulTypeVar file beautifulizer type_var
writeType file (Yes beautifulizer) (_, GTV tv)
= writeBeautifulTypeVar file beautifulizer (TV tv)
writeType file (Yes beautifulizer) (_, type_var=:TempV _)
= writeBeautifulTypeVar file beautifulizer type_var
writeType file opt_beautifulizer (form, TArrow)
= (file <<< "(->)", opt_beautifulizer)
writeType file opt_beautifulizer (form, TArrow1 t)
# file = file <<< "((->)"
# (file, opt_opt_beautifulizer) = writeType file opt_beautifulizer (form, t)
# file = file <<< ")"
= (file, opt_beautifulizer)
writeType file opt_beautifulizer (form, TFA vars type)
# (file, opt_beautifulizer) = writeType (file <<< "(A.") opt_beautifulizer (form, vars)
# (file, opt_beautifulizer) = writeType (file <<< ":") opt_beautifulizer (clearProperty form cBrackets, type)
= (file <<< ")", opt_beautifulizer)
writeType file opt_beautifulizer (form, TFAC vars type contexts)
# (file, opt_beautifulizer) = writeType (file <<< "(A.") opt_beautifulizer (form, vars)
(file, opt_beautifulizer) = writeType (file <<< ":") opt_beautifulizer (clearProperty form cBrackets, type)
(file, opt_beautifulizer) = show_context form contexts (file,opt_beautifulizer)
= (file <<< ")", opt_beautifulizer)
writeType file opt_beautifulizer (form, TempQV tv_number)
= (file <<< "E." <<< tv_number <<< ' ', opt_beautifulizer)
writeType file opt_beautifulizer (form, TempQDV tv_number)
= (file <<< "E." <<< tv_number <<< ' ', opt_beautifulizer)
writeType file opt_beautifulizer (form, TE)
= (file <<< "__", opt_beautifulizer)
writeType file _ (form, type)
= abort ("<:: (Type) (typesupport.icl)" ---> type)
writeTypeTA :: !*File !(Optional TypeVarBeautifulizer) !Format !TypeSymbIdent !a -> (!*File, !Optional TypeVarBeautifulizer) | writeType a
writeTypeTA file opt_beautifulizer form {type_ident,type_index,type_arity} types
| type_index.glob_module == cPredefinedModuleIndex
# predef_index = type_index.glob_object+FirstTypePredefinedSymbolIndex
| type_arity == 0
| predef_index==PD_StringType
= (file <<< "String", opt_beautifulizer)
| predef_index==PD_UnitType
= (file <<< "()", opt_beautifulizer)
= (file <<< type_ident, opt_beautifulizer)
| predef_index==PD_ListType
= writeWithinBrackets "[" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_StrictListType
= writeWithinBrackets "[!" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_UnboxedListType
= writeWithinBrackets "[#" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_TailStrictListType
= writeWithinBrackets "[" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_StrictTailStrictListType
= writeWithinBrackets "[!" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_UnboxedTailStrictListType
= writeWithinBrackets "[#" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_LazyArrayType
= writeWithinBrackets "{" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_StrictArrayType
= writeWithinBrackets "{!" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index==PD_UnboxedArrayType
= writeWithinBrackets "{#" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| predef_index>=PD_Arity2TupleType && predef_index<=PD_Arity32TupleType
= writeWithinBrackets "(" ")" file opt_beautifulizer (setProperty form cCommaSeparator, types)
| checkProperty form cBrackets
# (file, opt_beautifulizer)
= writeType (file <<< '(' <<< type_ident <<< ' ') opt_beautifulizer (form, types)
= (file <<< ')', opt_beautifulizer)
= writeType (file <<< type_ident <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
| type_arity == 0
= (file <<< type_ident, opt_beautifulizer)
| checkProperty form cBrackets
# (file, opt_beautifulizer)
= writeType (file <<< '(' <<< type_ident <<< ' ') opt_beautifulizer (form, types)
= (file <<< ')', opt_beautifulizer)
= writeType (file <<< type_ident <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
instance writeType ATypeVar
where
writeType file beautifulizer (form, {atv_attribute,atv_variable})
= writeType file beautifulizer (form, { at_attribute = atv_attribute, at_type = TV atv_variable })
writeWithinBrackets br_open br_close file opt_beautifulizer (form, types)
# (file, opt_beautifulizer)
= writeType (file <<< br_open) opt_beautifulizer (clearProperty form cBrackets, types)
= (file <<< br_close, opt_beautifulizer)
writeBeautifulTypeVar file beautifulizer=:{tvb_visited_type_vars, tvb_fresh_type_vars} type
| sanity_check_failed type
= abort "bug nr 12345 in module typesupport"
= case assoc_list_lookup (==) type tvb_visited_type_vars of
No
-> (file <<< hd tvb_fresh_type_vars,
Yes { beautifulizer &
tvb_visited_type_vars = [(type, hd tvb_fresh_type_vars):tvb_visited_type_vars],
tvb_fresh_type_vars = tl tvb_fresh_type_vars })
Yes (_, beautiful_var_name)
-> (file <<< beautiful_var_name, Yes beautifulizer)
where
sanity_check_failed (TV _) = False
sanity_check_failed (TempV _) = False
sanity_check_failed _ = True
writeBeautifulAttrVar file beautifulizer=:{tvb_visited_attr_vars, tvb_fresh_attr_vars} attribute
| sanity_check_failed attribute
= abort "bug nr 123456 in module typesupport"
= case assoc_list_lookup equal_attributes attribute tvb_visited_attr_vars of
No
-> (file <<< hd tvb_fresh_attr_vars,
Yes { beautifulizer &
tvb_visited_attr_vars = [(attribute, hd tvb_fresh_attr_vars):tvb_visited_attr_vars],
tvb_fresh_attr_vars = tl tvb_fresh_attr_vars })
Yes (_, beautiful_var_name)
-> (file <<< beautiful_var_name, Yes beautifulizer)
where
sanity_check_failed (TA_Var _) = False
sanity_check_failed (TA_TempVar _) = False
sanity_check_failed _ = True
equal_attributes (TA_Var {av_info_ptr=p1}) (TA_Var {av_info_ptr=p2})
= p1==p2
equal_attributes (TA_TempVar i1) (TA_TempVar i2)
= i1==i2
equal_attributes _ _
= False
instance writeType ConsVariable where
writeType file No (_, cons_variable)
= (file <<< cons_variable, No)
writeType file yes_beautifulizer (_, cv=:(TempQCV _))
= (file <<< cv, yes_beautifulizer)
writeType file yes_beautifulizer (_, cv=:(TempQCDV _))
= (file <<< cv, yes_beautifulizer)
writeType file (Yes beautifulizer) (_, CV tv)
= writeBeautifulTypeVar file beautifulizer (TV tv)
writeType file (Yes beautifulizer) (_, TempCV i)
= writeBeautifulTypeVar file beautifulizer (TempV i)
assoc_list_lookup _ _ [] = No
assoc_list_lookup equal t1 [hd=:(t2, _):tl]
| equal t1 t2
= Yes hd
= assoc_list_lookup equal t1 tl
cNoPosition :== -1
instance writeType [a] | writeType a
where
writeType file opt_beautifulizer (form, types)
= show_list 0 form types (file, opt_beautifulizer)
where
show_list elem_number form [type] file_opt_beautifulizer
| checkProperty form cCommaSeparator
= show_elem elem_number (clearProperty form cCommaSeparator) type file_opt_beautifulizer
| checkProperty form cArrowSeparator
= show_elem elem_number (clearProperty (clearProperty form cArrowSeparator) cBrackets) type file_opt_beautifulizer
| checkProperty form cAndSeparator
= show_elem elem_number (clearProperty form cAndSeparator) type file_opt_beautifulizer
= show_elem elem_number (setProperty form cBrackets) type file_opt_beautifulizer
show_list elem_number form [type : types] file_opt_beautifulizer
# (elem_format, seperator)
= if (checkProperty form cCommaSeparator) (clearProperty form cCommaSeparator, ",")
(if (checkProperty form cArrowSeparator) (setProperty (clearProperty form cArrowSeparator) cBrackets, " -> ")
(if (checkProperty form cAndSeparator) (clearProperty form cAndSeparator, " & ")
(setProperty form cBrackets, " ")))
(file, opt_beautifulizer)
= show_elem elem_number elem_format type file_opt_beautifulizer
= show_list (inc elem_number) form types (file <<< seperator, opt_beautifulizer)
show_list elem_number form [] file
= file
show_elem elem_nr form=:{form_attr_position = No} type (file, opt_beautifulizer)
= writeType file opt_beautifulizer (form, type)
show_elem elem_nr form=:{form_attr_position = Yes ([pos : positions], coercions)} type (file, opt_beautifulizer)
| elem_nr == pos
= writeType file opt_beautifulizer ({form & form_attr_position = Yes (positions, coercions)}, type)
| pos == cNoPosition
= writeType file opt_beautifulizer (form, type)
= writeType file opt_beautifulizer ({form & form_attr_position = Yes ([cNoPosition], coercions)}, type)
show_elem elem_nr form=:{form_attr_position = Yes ([], coercions)} type (file, opt_beautifulizer)
= writeType file opt_beautifulizer ({form & form_attr_position = Yes ([cNoPosition], coercions)}, type)
from compare_constructor import equal_constructor
instance == Format
where
(==) form1 form2 = equal_constructor form1 form2
instance <<< TypeContext
where
(<<<) file co = file <<< co.tc_class <<< " <" <<< ptrToInt co.tc_var <<< '>' <<< " " <<< co.tc_types
instance <<< AttrCoercion
where
(<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< " <= " <<< ac_offered
instance <<< TempSymbolType
where
(<<<) file {tst_args, tst_result, tst_context, tst_attr_env }
| isEmpty tst_args
= file <<< tst_result <<< " | " <<< tst_context <<< " [" <<< tst_attr_env <<< ']'
= file <<< tst_args <<< " -> " <<< tst_result <<< " | " <<< tst_context <<< " [" <<< tst_attr_env <<< ']'
// MW4..
:: TypeVarBeautifulizer =
{ tvb_visited_type_vars :: ![(Type, String)] // only TV and TempV
, tvb_fresh_type_vars :: ![String]
, tvb_visited_attr_vars :: ![(TypeAttribute, String)] // only TA_Var and TA_TempVar
, tvb_fresh_attr_vars :: ![String]
}
initialTypeVarBeautifulizer :: TypeVarBeautifulizer
initialTypeVarBeautifulizer
= { tvb_visited_type_vars = [], tvb_fresh_type_vars = fresh_vars 'a' 'i' 'a' (-1),
tvb_visited_attr_vars = [], tvb_fresh_attr_vars = fresh_vars 'u' (inc 'z') 'u' (-1) }
where
fresh_vars min max1 ch i
| ch==max1
= fresh_vars min max1 min (i+1)
= [if (i==(-1)) (toString ch) (toString ch+++toString i): fresh_vars min max1 (inc ch) i]
getImplicitAttrInequalities :: !SymbolType -> [AttrInequality]
// retrieve those inequalities that are implied by propagation
getImplicitAttrInequalities st=:{st_args, st_result}
# ineqs1 = get_ineqs_of_atype_list st_args
ineqs2 = get_ineqs_of_atype st_result
= uniqueBagToList (Pair ineqs1 ineqs2)
where
get_ineqs_of_atype :: !AType -> .Bag AttrInequality
get_ineqs_of_atype {at_attribute=TA_Var outer_av, at_type=at_type=:TA type_symb_ident type_args}
= get_ineqs_of_TA_with_TA_Var outer_av at_type type_symb_ident type_args
get_ineqs_of_atype {at_attribute=TA_Var outer_av, at_type=at_type=:TAS type_symb_ident type_args _}
= get_ineqs_of_TA_with_TA_Var outer_av at_type type_symb_ident type_args
get_ineqs_of_atype {at_type}
= get_ineqs_of_type at_type
get_ineqs_of_TA_with_TA_Var outer_av at_type type_symb_ident type_args
# ({tsp_propagation}) = type_symb_ident.type_prop
implicit_ineqs_1 = get_superflous_ineqs outer_av type_args tsp_propagation
| isEmptyBag implicit_ineqs_1
= get_ineqs_of_type at_type
# implicit_ineqs_2 = get_ineqs_of_type at_type
= Pair implicit_ineqs_1 implicit_ineqs_2
where
get_superflous_ineqs :: !AttributeVar ![AType] !PropClassification -> .Bag AttrInequality
get_superflous_ineqs outer_av [] tsp_propagation
= Empty
get_superflous_ineqs outer_av [{at_attribute}:type_args] tsp_propagation
# other_ineqs = get_superflous_ineqs outer_av type_args (tsp_propagation>>1)
| tsp_propagation bitand 1==0
// the type doesn't propagate in this argument
= other_ineqs
= case at_attribute of
TA_Var inner_av
-> Pair (Single {ai_demanded=inner_av, ai_offered=outer_av}) other_ineqs
_ -> other_ineqs
get_ineqs_of_type (TA ts args)
= get_ineqs_of_atype_list args
get_ineqs_of_type (TAS ts args _)
= get_ineqs_of_atype_list args
get_ineqs_of_type (l --> r)
= Pair (get_ineqs_of_atype l) (get_ineqs_of_atype r)
get_ineqs_of_type (TArrow1 type)
= get_ineqs_of_atype type
get_ineqs_of_type (cv :@: args)
= get_ineqs_of_atype_list args
get_ineqs_of_type (TFA vars type)
= get_ineqs_of_type type
get_ineqs_of_type (TFAC vars type type_contexts)
= get_ineqs_of_type type
get_ineqs_of_type _
= Empty
get_ineqs_of_atype_list []
= Empty
get_ineqs_of_atype_list [a_type:a_types]
= Pair (get_ineqs_of_atype a_type) (get_ineqs_of_atype_list a_types)
beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHeap)
beautifulizeAttributes symbol_type th_attrs
# (nr_of_attr_vars, rev_all_attr_vars, th_attrs)
= assignNumbersToAttrVars symbol_type th_attrs
(attr_env_coercions, th_attrs)
= addAttrEnvInequalities symbol_type.st_attr_env (emptyCoercions nr_of_attr_vars) th_attrs
(all_int_inequalities, th_attrs)
= mapSt pointers_to_int symbol_type.st_attr_env th_attrs
(_, attr_env_coercions)
= foldSt removeRedundancy all_int_inequalities
(createArray nr_of_attr_vars False, attr_env_coercions)
implicit_inequalities = getImplicitAttrInequalities symbol_type
(implicit_int_inequalities, th_attrs)
= mapSt pointers_to_int implicit_inequalities th_attrs
attr_env_coercions = foldSt remove_inequality implicit_int_inequalities attr_env_coercions
st_attr_env = coercionsToAttrEnv {el \\ el<-reverse rev_all_attr_vars } attr_env_coercions
= anonymizeAttrVars { symbol_type & st_attr_env = st_attr_env } implicit_inequalities th_attrs
where
pointers_to_int {ai_offered, ai_demanded} th_attrs
# (AVI_Attr (TA_TempVar offered), th_attrs) = readPtr ai_offered.av_info_ptr th_attrs
(AVI_Attr (TA_TempVar demanded), th_attrs) = readPtr ai_demanded.av_info_ptr th_attrs
= ({ ac_offered = offered, ac_demanded = demanded }, th_attrs)
remove_inequality {ac_offered, ac_demanded} attr_env_coercions
= removeInequality ac_offered ac_demanded attr_env_coercions
coercionsToAttrEnv :: !{AttributeVar} !Coercions -> [AttrInequality]
coercionsToAttrEnv attr_vars {coer_offered}
= flatten [ [ {ai_offered = attr_vars.[offered], ai_demanded = attr_vars.[demanded] }
\\ offered <- fst (flattenCoercionTree offered_tree) ]
\\ offered_tree<-:coer_offered & demanded<-[0..] ]
removeRedundancy :: !AttrCoercion !(!*{#Bool}, !*Coercions) -> (!.{#Bool}, !.Coercions)
removeRedundancy {ac_offered, ac_demanded} (visited, attr_env_coercions=:{coer_demanded})
// all i:not visited.[i]
# (descendants, coer_demanded)
= accCoercionTree flattenCoercionTree ac_offered coer_demanded
(path_exists, (visited, coer_demanded))
= searchPath (removeMember ac_demanded descendants) ac_demanded (visited, coer_demanded)
#! size
= size visited
# visited
= { visited & [i] = False \\ i<-[0..size-1] }
attr_env_coercions
= { attr_env_coercions & coer_demanded = coer_demanded }
| path_exists
// the inequality was redundant (like the first one in [a<=c, a<=b, b<=c]
= (visited, removeInequality ac_offered ac_demanded attr_env_coercions)
= (visited, attr_env_coercions)
where
searchPath :: ![Int] Int !(!*{#Bool}, !{!*CoercionTree}) -> (!Bool, (!.{#Bool}, !{!.CoercionTree}))
searchPath [] _ visited_coer_demanded
= (False, visited_coer_demanded)
searchPath [x:xs] goal (visited, coer_demanded)
// not visited.[x]
| x==goal
= (True, (visited, coer_demanded))
# visited
= { visited & [x] = True }
(descendants, coer_demanded)
= accCoercionTree flattenCoercionTree x coer_demanded
(xs, visited)
= foldSt add_unvisited_node descendants (xs, visited)
= searchPath xs goal (visited, coer_demanded)
add_unvisited_node :: !Int !(![Int], !u:{#Bool}) -> (![Int], !u:{#Bool})
add_unvisited_node candidate (accu, visited)
| visited.[candidate]
= (accu, visited)
= ([candidate:accu], visited)
instance performOnAttrVars AttrInequality
where
performOnAttrVars f {ai_demanded,ai_offered} st
= f ai_demanded (f ai_offered st)
assignNumbersToAttrVars :: !SymbolType !*AttrVarHeap -> (!Int, ![AttributeVar], !.AttrVarHeap)
assignNumbersToAttrVars {st_attr_vars, st_args, st_result, st_attr_env} th_attrs
# th_attrs = foldSt initializeToAVI_Empty st_attr_vars th_attrs
(nr_of_attr_vars, attr_vars, th_attrs)
= performOnAttrVars assign_number_to_unencountered_attr_var (st_args, st_result)
(0, [], th_attrs)
| fst (foldSt hasnt_got_a_number st_attr_env (False, th_attrs))
// to do: prevent free attributes in st_attr_env when expanding types
= performOnAttrVars assign_number_to_unencountered_attr_var st_attr_env (nr_of_attr_vars, attr_vars, th_attrs)
= (nr_of_attr_vars, attr_vars, th_attrs)
where
assign_number_to_unencountered_attr_var av=:{av_info_ptr} (next_number, attr_vars_accu, th_attrs)
# (avi, th_attrs) = readPtr av_info_ptr th_attrs
= case avi of
AVI_Empty
-> (next_number+1, [av:attr_vars_accu],
writePtr av_info_ptr (AVI_Attr (TA_TempVar next_number)) th_attrs)
_
-> (next_number, attr_vars_accu, th_attrs)
hasnt_got_a_number {ai_offered, ai_demanded} (or_of_all, th_attrs)
# hnn1 = has_no_number ai_offered th_attrs
hnn2 = has_no_number ai_demanded th_attrs
= (hnn1 || hnn2 || or_of_all, th_attrs)
has_no_number {av_info_ptr} th_attrs
= case sreadPtr av_info_ptr th_attrs of
AVI_Empty
-> True
_
-> False
//accCoercionTree :: !.(u:CoercionTree -> (.a,u:CoercionTree)) !Int !*{!u:CoercionTree} -> (!.a,!{!u:CoercionTree})
accCoercionTree f i coercion_trees
:== acc_coercion_tree i coercion_trees
where
acc_coercion_tree i coercion_trees
# (coercion_tree, coercion_trees) = coercion_trees![i]
(x, coercion_tree) = f coercion_tree
= (x, {coercion_trees & [i]=coercion_tree})
appCoercionTree f i coercion_trees
:== acc_coercion_tree i coercion_trees
where
acc_coercion_tree i coercion_trees
# (coercion_tree, coercion_trees) = coercion_trees![i]
= {coercion_trees & [i] = f coercion_tree}
flattenCoercionTree :: !u:CoercionTree -> (![Int], !u:CoercionTree)
flattenCoercionTree tree
= flatten_ct ([], tree)
where
flatten_ct (accu, CT_Node i left right)
# (accu, right) = flatten_ct (accu, right)
(accu, left) = flatten_ct ([i:accu], left)
= (accu, CT_Node i left right)
flatten_ct (accu, _)
= (accu, CT_Empty)
anonymizeAttrVars :: !SymbolType ![AttrInequality] !*AttrVarHeap -> (!SymbolType, !.AttrVarHeap)
anonymizeAttrVars st=:{st_attr_vars, st_args, st_result, st_attr_env} implicit_inequalities th_attrs
# th_attrs = countAttrVars st th_attrs
th_attrs = foldSt markUsedAttrVars st_attr_env th_attrs
th_attrs = foldSt mark_once_occurring_implicit_attr_var implicit_inequalities th_attrs
(st_args, th_attrs) = mapSt anonymize_atype st_args th_attrs
(st_result, th_attrs) = anonymize_atype st_result th_attrs
= ({ st & st_args = st_args, st_result = st_result }, th_attrs)
where
anonymize_atype atype=:{at_attribute=TA_Var {av_info_ptr}, at_type} th_attrs
# (at_type, th_attrs) = anonymize_type at_type th_attrs
(avi, th_attrs) = readPtr av_info_ptr th_attrs
= case avi of
AVI_CountMany
-> ({ atype & at_type = at_type }, th_attrs)
AVI_CountZero
-> ({ atype & at_type = at_type, at_attribute = TA_Anonymous }, th_attrs)
AVI_CountOne
-> ({ atype & at_type = at_type, at_attribute = TA_Anonymous }, th_attrs)
AVI_CountVar _
-> ({ atype & at_type = at_type, at_attribute = TA_Anonymous }, th_attrs)
AVI_Attr TA_None
-> ({ atype & at_type = at_type, at_attribute = TA_None }, th_attrs)
_
-> ({ atype & at_type = at_type }, th_attrs)
anonymize_atype atype=:{at_type} th_attrs
# (at_type, th_attrs) = anonymize_type at_type th_attrs
= ({ atype & at_type = at_type }, th_attrs)
anonymize_type (TA tsi args) th_attrs
# (args, th_attrs) = mapSt anonymize_atype args th_attrs
= (TA tsi args, th_attrs)
anonymize_type (TAS tsi args strictness) th_attrs
# (args, th_attrs) = mapSt anonymize_atype args th_attrs
= (TAS tsi args strictness, th_attrs)
anonymize_type (l --> r) th_attrs
# (l, th_attrs) = anonymize_atype l th_attrs
(r, th_attrs) = anonymize_atype r th_attrs
= (l --> r, th_attrs)
anonymize_type (TArrow1 type) th_attrs
# (type, th_attrs) = anonymize_atype type th_attrs
= (TArrow1 type, th_attrs)
anonymize_type (cv :@: args) th_attrs
# (args, th_attrs) = mapSt anonymize_atype args th_attrs
= (cv :@: args, th_attrs)
anonymize_type (TFA vars type) th_attrs
# (type, th_attrs) = anonymize_type type th_attrs
= (TFA vars type, th_attrs)
anonymize_type (TFAC vars type type_contexts) th_attrs
# (type, th_attrs) = anonymize_type type th_attrs
= (TFAC vars type type_contexts, th_attrs)
anonymize_type x th_attrs
= (x, th_attrs)
countAttrVars :: !SymbolType !*AttrVarHeap -> .AttrVarHeap
// for all attribute variables: set the attrVarInfo to (AVI_count c) where c is the number of
// occurences in of that attribute variable in the SymbolType (excluding inequalities)
countAttrVars {st_attr_vars, st_args, st_result} th_attrs
# th_attrs = foldSt (\av=:{av_info_ptr} th_attrs -> writePtr av_info_ptr AVI_CountZero th_attrs)
st_attr_vars th_attrs
= foldSt count_attr_vars_of_atype st_args (count_attr_vars_of_atype st_result th_attrs)
where
count_attr_vars_of_atype {at_attribute=TA_Var {av_info_ptr}, at_type} th_attrs
# (av_info,th_attrs) = readPtr av_info_ptr th_attrs
= case av_info of
AVI_CountZero
-> case at_type of
TV {tv_info_ptr}
-> count_attr_vars_of_type at_type (writePtr av_info_ptr (AVI_CountVar tv_info_ptr) th_attrs)
GTV {tv_info_ptr}
-> count_attr_vars_of_type at_type (writePtr av_info_ptr (AVI_CountVar tv_info_ptr) th_attrs)
_
-> count_attr_vars_of_type at_type (writePtr av_info_ptr AVI_CountOne th_attrs)
AVI_CountVar previous_tv_info_ptr
-> case at_type of
TV {tv_info_ptr}
| tv_info_ptr==previous_tv_info_ptr
-> count_attr_vars_of_type at_type (writePtr av_info_ptr (AVI_CountVar tv_info_ptr) th_attrs)
GTV {tv_info_ptr}
| tv_info_ptr==previous_tv_info_ptr
-> count_attr_vars_of_type at_type (writePtr av_info_ptr (AVI_CountVar tv_info_ptr) th_attrs)
_
-> count_attr_vars_of_type at_type (writePtr av_info_ptr AVI_CountMany th_attrs)
AVI_CountOne
-> count_attr_vars_of_type at_type (writePtr av_info_ptr AVI_CountMany th_attrs)
AVI_CountMany
-> count_attr_vars_of_type at_type th_attrs
count_attr_vars_of_atype {at_type} th_attrs
= count_attr_vars_of_type at_type th_attrs
count_attr_vars_of_type (TA _ args) th_attrs
= foldSt count_attr_vars_of_atype args th_attrs
count_attr_vars_of_type (TAS _ args _) th_attrs
= foldSt count_attr_vars_of_atype args th_attrs
count_attr_vars_of_type (l --> r) th_attrs
= count_attr_vars_of_atype l (count_attr_vars_of_atype r th_attrs)
count_attr_vars_of_type (TArrow1 t) th_attrs
= count_attr_vars_of_atype t th_attrs
count_attr_vars_of_type (_ :@: args) th_attrs
= foldSt count_attr_vars_of_atype args th_attrs
count_attr_vars_of_type (TFA _ type) th_attrs
= count_attr_vars_of_type type th_attrs
count_attr_vars_of_type (TFAC _ type _) th_attrs
= count_attr_vars_of_type type th_attrs
count_attr_vars_of_type _ th_attrs
= th_attrs
markUsedAttrVars {ai_offered, ai_demanded} th_attrs
= writePtr ai_offered.av_info_ptr (AVI_Forward 0)
(writePtr ai_demanded.av_info_ptr (AVI_Forward 0) th_attrs)
// misuse AVI_Forward to indicate that this attribute variable is referenced in
// the attribute inequalities
mark_once_occurring_implicit_attr_var {ai_offered={av_info_ptr}} th_attrs
# (avi, th_attrs) = readPtr av_info_ptr th_attrs
= case avi of
AVI_CountOne
-> writePtr av_info_ptr (AVI_Attr TA_None) th_attrs
_
-> th_attrs
removeInequality :: !Int !Int !*Coercions -> .Coercions
removeInequality offered demanded attr_env_coercions=:{coer_offered, coer_demanded}
# coer_offered = appCoercionTree (removeNode offered) demanded coer_offered
coer_demanded = appCoercionTree (removeNode demanded) offered coer_demanded
= { attr_env_coercions & coer_demanded = coer_demanded, coer_offered = coer_offered }
removeNode :: !Int !*CoercionTree -> .CoercionTree
removeNode i1 (CT_Node i2 left right)
| i1