Commit 74a8c577 authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl

generate bimap functions as a case with for each constructor as result the...

generate bimap functions as a case with for each constructor as result the constructor with bimapped arguments, no generic representation of the algebraic, record or newtype is created, remove the bimap functions for the generic representation constructors, use a seperate type for the GenTypeStruct for bimap (BimapGenTypeStruct)
parent 65073581
......@@ -26,12 +26,18 @@ import genericsupport,transform,utilities
| GTSEither !GenTypeStruct !GenTypeStruct
| GTSUnit
| GTSArrow GenTypeStruct GenTypeStruct
// the following constructors are used for optimizing bimaps
| GTSAppConsBimapKindConst
| GTSAppBimap TypeKind [GenTypeStruct]
| GTSAppConsSimpleType !GlobalIndex !TypeKind ![GenTypeStruct]
| GTSCons1Bimap !GenTypeStruct
| GTSRecord1Bimap !GenTypeStruct
:: BimapGenTypeStruct
= BGTSAppCons TypeKind [BimapGenTypeStruct]
| BGTSAppVar TypeVar [BimapGenTypeStruct]
| BGTSVar TypeVar
| BGTSE
| BGTSUnit
| BGTSArrow BimapGenTypeStruct BimapGenTypeStruct
| BGTSAlgebraic ![[BimapGenTypeStruct]]
| BGTSRecord ![BimapGenTypeStruct]
| BGTSAppConsBimapKindConst
| BGTSAppConsSimpleType !GlobalIndex !TypeKind ![BimapGenTypeStruct]
:: GenericTypeRep =
{ gtr_type :: GenTypeStruct // generic structure type
......@@ -41,8 +47,8 @@ import genericsupport,transform,utilities
:: GenericTypeReps
| GenericTypeRep !GenericTypeRep
| GenericBimapTypeRep !GenericTypeRep
| GenericTypeRepAndBimapTypeRep !GenericTypeRep !GenericTypeRep
| GenericBimapTypeRep !BimapGenTypeStruct
| GenericTypeRepAndBimapTypeRep !GenericTypeRep !BimapGenTypeStruct
:: FunDefs :== {#FunDef}
:: Modules :== {#CommonDefs}
......@@ -63,13 +69,7 @@ import genericsupport,transform,utilities
bimap_fromto_function :: !FunctionIndexAndIdent,
bimap_tofrom_function :: !FunctionIndexAndIdent,
bimap_to_function :: !FunctionIndexAndIdent,
bimap_from_function :: !FunctionIndexAndIdent,
bimap_PAIR_function :: !FunctionIndexAndIdent,
bimap_EITHER_function :: !FunctionIndexAndIdent,
bimap_OBJECT_function :: !FunctionIndexAndIdent,
bimap_CONS_function :: !FunctionIndexAndIdent,
bimap_RECORD_function :: !FunctionIndexAndIdent,
bimap_FIELD_function :: !FunctionIndexAndIdent
bimap_from_function :: !FunctionIndexAndIdent
}
:: FunctionIndexAndIdent = {
......@@ -279,14 +279,8 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
bimap_fromto_function = undefined_function_and_ident,
bimap_tofrom_function = undefined_function_and_ident,
bimap_to_function = undefined_function_and_ident,
bimap_from_function = undefined_function_and_ident,
bimap_PAIR_function = undefined_function_and_ident,
bimap_EITHER_function = undefined_function_and_ident,
bimap_OBJECT_function = undefined_function_and_ident,
bimap_CONS_function = undefined_function_and_ident,
bimap_RECORD_function = undefined_function_and_ident,
bimap_FIELD_function = undefined_function_and_ident
}
bimap_from_function = undefined_function_and_ident
}
funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions=bimap_functions}
#! (funs_and_groups, gs)
= foldArraySt build_generic_representation com_gencase_defs (funs_and_groups, gs)
......@@ -344,7 +338,7 @@ where
GenericTypeRep gen_type_rep
| not build_bimap_type_rep
-> (funs_and_groups, gs)
# (gen_bimap_type_rep, funs_and_groups, gs) = buildBimapGenericTypeRep type_def_gi funs_and_groups gs
# (gen_bimap_type_rep, gs) = buildBimapGenericTypeRep type_def_gi gs
# gs & gs_td_infos.[glob_module,glob_object].tdi_gen_rep = GenericTypeRepAndBimapTypeRep gen_type_rep gen_bimap_type_rep
-> (funs_and_groups, gs)
GenericBimapTypeRep gen_bimap_type_rep
......@@ -357,13 +351,13 @@ where
| build_type_rep
# (gen_type_rep, funs_and_groups, gs) = buildGenericTypeRep type_def_gi funs_and_groups gs
| build_bimap_type_rep
# (gen_bimap_type_rep, funs_and_groups, gs) = buildBimapGenericTypeRep type_def_gi funs_and_groups gs
# (gen_bimap_type_rep, gs) = buildBimapGenericTypeRep type_def_gi gs
# gs & gs_td_infos.[glob_module,glob_object].tdi_gen_rep = GenericTypeRepAndBimapTypeRep gen_type_rep gen_bimap_type_rep
-> (funs_and_groups, gs)
# gs & gs_td_infos.[glob_module,glob_object].tdi_gen_rep = GenericTypeRep gen_type_rep
-> (funs_and_groups, gs)
| build_bimap_type_rep
# (gen_bimap_type_rep, funs_and_groups, gs) = buildBimapGenericTypeRep type_def_gi funs_and_groups gs
# (gen_bimap_type_rep, gs) = buildBimapGenericTypeRep type_def_gi gs
# gs & gs_td_infos.[glob_module,glob_object].tdi_gen_rep = GenericBimapTypeRep gen_bimap_type_rep
-> (funs_and_groups, gs)
......@@ -410,23 +404,19 @@ buildGenericTypeRep type_index funs_and_groups
}
= ({gtr_type=atype,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
buildBimapGenericTypeRep :: !GlobalIndex /*type def index*/ !FunsAndGroups !*GenericState -> (!GenericTypeRep,!FunsAndGroups,!*GenericState)
buildBimapGenericTypeRep type_index funs_and_groups
gs=:{gs_modules, gs_predefs, gs_main_module, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
buildBimapGenericTypeRep :: !GlobalIndex !*GenericState -> (!BimapGenTypeStruct,!*GenericState)
buildBimapGenericTypeRep type_index
gs=:{gs_modules, gs_predefs, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]
// remove TVI_TypeKind's, otherwise: abort "type var is not empty", buildTypeDefInfo seems to do this in buildGenericTypeRep
gs_tvarh = remove_type_argument_numbers type_def.td_args gs_tvarh
heaps = {hp_expression_heap=gs_exprh, hp_var_heap=gs_varh, hp_generic_heap=gs_genh, hp_type_heaps={th_vars=gs_tvarh, th_attrs=gs_avarh}}
(atype, (gs_modules, gs_td_infos, heaps, gs_error))
(atype, (gs_modules, gs_td_infos, heaps, gs_error))
= buildBimapStructType type_index gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
(from_fun_ds, funs_and_groups, heaps, gs_error)
= buildBimapConversionFrom type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error
(to_fun_ds, funs_and_groups, heaps, gs_error)
= buildBimapConversionTo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error
{hp_expression_heap, hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}} = heaps
gs & gs_modules = gs_modules, gs_td_infos = gs_td_infos, gs_error = gs_error, gs_avarh = th_attrs,
gs_tvarh = th_vars, gs_varh = hp_var_heap, gs_genh = hp_generic_heap, gs_exprh = hp_expression_heap
= ({gtr_type=atype,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
= (atype, gs)
// the structure type
......@@ -434,7 +424,7 @@ convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbolsData !AType (!
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToGenTypeStruct ident pos {psd_predefs_a} type st
= convert type st
where
where
convert {at_type=TA type_symb args, at_attribute} st
= convert_type_app type_symb at_attribute args st
convert {at_type=TAS type_symb args _, at_attribute} st
......@@ -449,7 +439,7 @@ where
convert {at_type=TV tv} st
= (GTSVar tv, st)
convert {at_type=TB _} st
= (GTSAppCons KindConst [], st)
= (GTSAppCons KindConst [], st)
convert {at_type=type} (modules, td_infos, heaps, error)
# error = reportError ident.id_name pos ("can not build generic representation for this type", type) error
= (GTSE, (modules, td_infos, heaps, error))
......@@ -472,9 +462,9 @@ where
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (GTSAppCons kind args, st)
convert_bimap_AType_to_GenTypeStruct :: !AType !Position !PredefinedSymbolsData (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convert_bimap_AType_to_GenTypeStruct type pos {psd_predefs_a} st
convertATypeToBimapGenTypeStruct :: !Ident !Position !PredefinedSymbolsData !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToBimapGenTypeStruct ident pos {psd_predefs_a} type st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
......@@ -483,18 +473,60 @@ where
= convert_type_app type_symb at_attribute args st
convert {at_type=(CV tv) :@: args} st
#! (args, st) = mapSt convert args st
= (GTSAppVar tv args, st)
= (BGTSAppVar tv args, st)
convert {at_type=x --> y} st
#! (x, st) = convert x st
#! (y, st) = convert y st
= (GTSArrow x y, st)
= (BGTSArrow x y, st)
convert {at_type=TV tv} st
= (GTSVar tv, st)
= (BGTSVar tv, st)
convert {at_type=TB _} st
= (BGTSAppCons KindConst [], st)
convert {at_type=type} (modules, td_infos, heaps, error)
# error = reportError ident.id_name pos ("can not build generic representation for this type", type) error
= (BGTSE, (modules, td_infos, heaps, error))
convert_type_app {type_index} attr args (modules, td_infos, heaps, error)
# (type_def, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
= case type_def.td_rhs of
SynType atype
# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps
-> convert {at_type = expanded_type, at_attribute = attr}
(modules, td_infos, {heaps & hp_type_heaps = th}, error)
_
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module
&& type_index.glob_object == pds_def
-> (BGTSAppCons KindConst [], (modules, td_infos, heaps, error))
| otherwise
#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (BGTSAppCons kind args, st)
convert_generic_function_type_to_BimapGenTypeStruct :: !AType !Position !PredefinedSymbolsData (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convert_generic_function_type_to_BimapGenTypeStruct type pos {psd_predefs_a} st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
= convert_type_app type_symb at_attribute args st
convert {at_type=TAS type_symb args _, at_attribute} st
= convert_type_app type_symb at_attribute args st
convert {at_type=(CV tv) :@: args} st
#! (args, st) = mapSt convert args st
= (BGTSAppVar tv args, st)
convert {at_type=x --> y} st
#! (x, st) = convert x st
#! (y, st) = convert y st
= (BGTSArrow x y, st)
convert {at_type=TV tv} st
= (BGTSVar tv, st)
convert {at_type=TB _} st
= (GTSAppCons KindConst [], st)
= (BGTSAppCons KindConst [], st)
convert {at_type=type} (modules, td_infos, heaps, error)
# error = reportError predefined_idents.[PD_GenericBimap].id_name pos ("can not build generic representation for this type", type) error
= (GTSE, (modules, td_infos, heaps, error))
= (BGTSE, (modules, td_infos, heaps, error))
convert_type_app {type_index=type_index=:{glob_module,glob_object}} attr args (modules, td_infos, heaps, error)
# (type_def, modules) = modules![glob_module].com_type_defs.[glob_object]
......@@ -507,7 +539,7 @@ where
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| glob_module == pds_module && glob_object == pds_def
&& (case args of [{at_type=TB _}] -> True; _ -> False)
-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
-> (BGTSAppCons KindConst [], (modules, td_infos, heaps, error))
AlgType alts
# n_args = length args
| n_args>0 && type_def.td_arity==n_args
......@@ -516,8 +548,8 @@ where
| can_generate_bimap_to_or_from
#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
#! (args, st) = convert_args args (modules, td_infos, heaps, error)
-> (GTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
-> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
-> (BGTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
-> convert_type_app_to_BGTSAppCons glob_module glob_object args modules td_infos heaps error
RecordType {rt_constructor}
# n_args = length args
| n_args>0 && type_def.td_arity==n_args
......@@ -526,17 +558,17 @@ where
| ok
#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
#! (args, st) = convert_args args (modules, td_infos, heaps, error)
-> (GTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
-> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
-> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
-> (BGTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
-> convert_type_app_to_BGTSAppCons glob_module glob_object args modules td_infos heaps error
-> convert_type_app_to_BGTSAppCons glob_module glob_object args modules td_infos heaps error
_
-> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
-> convert_type_app_to_BGTSAppCons glob_module glob_object args modules td_infos heaps error
where
convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
convert_type_app_to_BGTSAppCons glob_module glob_object args modules td_infos heaps error
#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
#! (args, st) = convert_args args (modules, td_infos, heaps, error)
= (GTSAppCons kind args, st)
= (BGTSAppCons kind args, st)
convert_args args st
= mapSt convert args st
......@@ -683,85 +715,57 @@ args_contain_no_type_var atypes = All contains_no_type_var atypes
// the structure type of a generic type can often be simplified
// because bimaps for types not containing generic variables are indentity bimaps
simplify_bimap_GenTypeStruct :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplify_bimap_GenTypeStruct :: ![TypeVar] !BimapGenTypeStruct !*Heaps -> (!BimapGenTypeStruct, !*Heaps)
simplify_bimap_GenTypeStruct gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
#! th_vars = foldSt mark_type_var gvars th_vars
#! (type, th_vars) = simplify type th_vars
#! th_vars = foldSt clear_type_var gvars th_vars
= (type, { heaps & hp_type_heaps = { hp_type_heaps & th_vars = th_vars}})
where
simplify t=:(GTSAppCons KindConst []) st
simplify t=:(BGTSAppCons KindConst []) st
= (t, st)
simplify (GTSAppCons kind=:(KindArrow kinds) args) st
simplify (BGTSAppCons kind=:(KindArrow kinds) args) st
# formal_arity = length kinds
# actual_arity = length args
# contains_gen_vars = occurs_list args st
| formal_arity == actual_arity && not contains_gen_vars
= (GTSAppConsBimapKindConst, st)
= (BGTSAppConsBimapKindConst, st)
# (args, st) = mapSt simplify args st
= (GTSAppCons kind args, st)
simplify (GTSAppConsSimpleType type_symbol_n kind args) st
= (BGTSAppCons kind args, st)
simplify (BGTSAppConsSimpleType type_symbol_n kind args) st
# contains_gen_vars = occurs_list args st
| not contains_gen_vars
= (GTSAppConsBimapKindConst, st)
= (BGTSAppConsBimapKindConst, st)
# (args, st) = mapSt simplify args st
= (GTSAppConsSimpleType type_symbol_n kind args, st)
simplify (GTSArrow x y) st
= (BGTSAppConsSimpleType type_symbol_n kind args, st)
simplify (BGTSArrow x y) st
# contains_gen_vars = occurs2 x y st
| not contains_gen_vars
= (GTSAppConsBimapKindConst, st)
= (BGTSAppConsBimapKindConst, st)
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSArrow x y, st)
simplify (GTSAppVar tv args) st
= (BGTSArrow x y, st)
simplify (BGTSAppVar tv args) st
# (args, st) = mapSt simplify args st
= (GTSAppVar tv args, st)
simplify t=:(GTSVar tv) st
= (BGTSAppVar tv args, st)
simplify t=:(BGTSVar tv) st
= (t, st)
simplify (GTSPair x y) st
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSPair x y, st)
simplify (GTSEither x y) st
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSEither x y, st)
simplify GTSUnit st
= (GTSUnit, st)
simplify (GTSCons1Bimap x) st
# (x, st) = simplify x st
= (GTSCons1Bimap x, st)
simplify (GTSRecord1Bimap x) st
# (x, st) = simplify x st
= (GTSRecord1Bimap x, st)
simplify (GTSCons cons_info_ds cons_index type_info gen_type_ds x) st
# (x, st) = simplify x st
= (GTSCons cons_info_ds cons_index type_info gen_type_ds x, st)
simplify (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds x) st
# (x, st) = simplify x st
= (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds x, st)
simplify (GTSField field_info_ds field_index record_info_ds x) st
# (x, st) = simplify x st
= (GTSField field_info_ds field_index record_info_ds x, st)
simplify (GTSObject type_info_ds type_index cons_desc_list_ds x) st
# (x, st) = simplify x st
= (GTSObject type_info_ds type_index cons_desc_list_ds x, st)
occurs (GTSAppCons _ args) st = occurs_list args st
occurs (GTSAppConsSimpleType _ _ args) st = occurs_list args st
occurs (GTSAppVar tv args) st = type_var_occurs tv st || occurs_list args st
occurs (GTSVar tv) st = type_var_occurs tv st
occurs (GTSArrow x y) st = occurs2 x y st
occurs (GTSPair x y) st = occurs2 x y st
occurs (GTSEither x y) st = occurs2 x y st
occurs GTSUnit st = False
occurs (GTSCons1Bimap arg) st = occurs arg st
occurs (GTSRecord1Bimap arg) st = occurs arg st
occurs (GTSCons _ _ _ _ arg) st = occurs arg st
occurs (GTSRecord _ _ _ _ arg) st = occurs arg st
occurs (GTSField _ _ _ arg) st = occurs arg st
occurs (GTSObject _ _ _ arg) st = occurs arg st
occurs GTSE st = False
simplify BGTSUnit st
= (BGTSUnit, st)
simplify (BGTSAlgebraic algebraic_gen_type) st
# (algebraic_gen_type, st) = mapSt (mapSt simplify) algebraic_gen_type st
= (BGTSAlgebraic algebraic_gen_type, st)
simplify (BGTSRecord record_gen_type) st
# (record_gen_type, st) = mapSt simplify record_gen_type st
= (BGTSRecord record_gen_type, st)
occurs (BGTSAppCons _ args) st = occurs_list args st
occurs (BGTSAppConsSimpleType _ _ args) st = occurs_list args st
occurs (BGTSAppVar tv args) st = type_var_occurs tv st || occurs_list args st
occurs (BGTSVar tv) st = type_var_occurs tv st
occurs (BGTSArrow x y) st = occurs2 x y st
occurs BGTSUnit st = False
occurs BGTSE st = False
occurs2 x y st
= occurs x st || occurs y st
......@@ -832,11 +836,19 @@ where
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module predefs (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# st_arg = case st_args of [st_arg] -> st_arg;
= convertATypeToGenTypeStruct td_ident td_pos predefs st_arg (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
buildBimapStructType ::
!GlobalIndex // type def global index
!PredefinedSymbolsData
(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> ( !GenTypeStruct // the structure type
-> ( !BimapGenTypeStruct // the structure type
, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
)
buildBimapStructType {gi_module,gi_index} predefs (modules, td_infos, heaps, error)
......@@ -845,47 +857,38 @@ buildBimapStructType {gi_module,gi_index} predefs (modules, td_infos, heaps, err
where
build_type {td_rhs=AlgType alts, td_ident, td_pos} st
# (cons_args, st) = mapSt (build_alt td_ident td_pos) alts st
= (build_sum_type cons_args, st)
= (BGTSAlgebraic cons_args, st)
build_type {td_rhs=RecordType {rt_constructor,rt_fields}, td_ident, td_pos} (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
= case args of
[arg]
// GTSRecord if 1 field
-> (GTSRecord1Bimap arg, st)
_
-> (build_prod_type args, st)
# (args, st) = mapSt (convertATypeToBimapGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
= (BGTSRecord args, st)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
= (BGTSE, (modules, td_infos, heaps, error))
build_type {td_rhs=NewType cons, td_ident, td_pos} st
= build_newtype_alt td_ident td_pos cons gi_module predefs st
build_type {td_rhs=SynType type,td_ident, td_pos} (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of a synonym type" error
= (GTSE, (modules, td_infos, heaps, error))
= (BGTSE, (modules, td_infos, heaps, error))
build_type td=:{td_rhs=AbstractType _,td_ident, td_arity, td_pos} (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an abstract type" error
= (GTSE, (modules, td_infos, heaps, error))
= (BGTSE, (modules, td_infos, heaps, error))
build_alt td_ident td_pos cons_def_sym=:{ds_index} (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
= case args of
[arg]
// GTSCons if 1 element
-> (GTSCons1Bimap arg, st)
-> (build_prod_type args, st)
| cons_exi_vars=:[]
# (args, st) = mapSt (convertATypeToBimapGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
= (args, st)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
= ([], (modules, td_infos, heaps, error))
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module predefs (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# st_arg = case st_args of [st_arg] -> st_arg;
= convertATypeToGenTypeStruct td_ident td_pos predefs st_arg (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module predefs (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# st_arg = case st_args of [st_arg] -> st_arg;
= convertATypeToBimapGenTypeStruct td_ident td_pos predefs st_arg (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (BGTSE, (modules, td_infos, heaps, error))
build_prod_type :: [GenTypeStruct] -> GenTypeStruct
build_prod_type types
......@@ -1300,108 +1303,6 @@ where
# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
= (case_expr, heaps, error)
// conversion from type to generic
buildBimapConversionTo ::
!Index // type def module
!CheckedTypeDef // the type def
!Index // main module
!PredefinedSymbolsData
!FunsAndGroups !*Heaps !*ErrorAdmin
-> (!DefinedSymbol,
FunsAndGroups,!*Heaps,!*ErrorAdmin)
buildBimapConversionTo
type_def_mod
type_def=:{td_rhs, td_ident, td_index, td_pos}
main_module_index predefs funs_and_groups heaps error
# (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps
# (body_expr, heaps, error) = build_expr_for_type_rhs type_def_mod td_index td_rhs arg_expr heaps error
# fun_name = makeIdent ("toGeneric-" +++ td_ident.id_name)
| not error.ea_ok
# (def_sym, funs_and_groups) = buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups
= (def_sym, funs_and_groups, heaps, error)
# (def_sym, funs_and_groups) = buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups
= (def_sym, funs_and_groups, heaps, error)
where
// build conversion for type rhs
build_expr_for_type_rhs ::
!Int // type def module
!Int // type def index
!TypeRhs // type def rhs
!Expression // expression of the function argument variable
!*Heaps
!*ErrorAdmin
-> ( !Expression // generated expression
, !*Heaps // state
, !*ErrorAdmin)
build_expr_for_type_rhs type_def_mod type_def_index (AlgType def_symbols) arg_expr heaps error
= build_expr_for_conses type_def_mod type_def_index def_symbols arg_expr heaps error
build_expr_for_type_rhs type_def_mod type_def_index (RecordType {rt_constructor}) arg_expr heaps error
= build_expr_for_record type_def_mod type_def_index rt_constructor arg_expr heaps error
build_expr_for_type_rhs type_def_mod type_def_index (NewType cons) arg_expr heaps error
= build_expr_for_newtype type_def_mod type_def_index cons arg_expr heaps error
build_expr_for_type_rhs type_def_mod type_def_index (AbstractType _) arg_expr heaps error
#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" error
= (EE, heaps, error)
build_expr_for_type_rhs type_def_mod type_def_index (SynType _) arg_expr heaps error
#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" error
= (EE, heaps, error)
// build conversion for constructors of a type def
build_expr_for_conses type_def_mod type_def_index cons_def_syms arg_expr heaps error
# (case_alts, heaps, error)
= build_exprs_for_conses 0 (length cons_def_syms) type_def_mod cons_def_syms heaps error
# case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} case_alts
# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
= (case_expr, heaps, error)
// build conversions for constructors
build_exprs_for_conses :: !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
-> ([AlgebraicPattern], !*Heaps, !*ErrorAdmin)
build_exprs_for_conses i n type_def_mod [] heaps error
= ([], heaps, error)
build_exprs_for_conses i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
#! (alt, heaps, error) = build_expr_for_cons i n type_def_mod cons_def_sym heaps error
#! (alts, heaps, error) = build_exprs_for_conses (i+1) n type_def_mod cons_def_syms heaps error
= ([alt:alts], heaps, error)
// build conversion for a constructor
build_expr_for_cons :: !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin
-> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
build_expr_for_cons i n type_def_mod cons_def_sym=:{ds_ident, ds_arity} heaps error
#! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]]
#! (var_exprs, vars, heaps) = buildVarExprs names heaps
#! (expr, heaps) = if (ds_arity==1)
(build_cons (hd var_exprs) predefs heaps)
(build_prod var_exprs predefs heaps)
#! (expr, heaps) = build_sum i n expr predefs heaps
#! alg_pattern = {ap_symbol={glob_module=type_def_mod,glob_object=cons_def_sym}, ap_vars=vars, ap_expr=expr, ap_position=NoPos}
= (alg_pattern, heaps, error)
build_expr_for_newtype type_def_mod type_def_index cons_def_sym arg_expr heaps error
# (alt, heaps, error) = build_expr_for_newtype_cons type_def_mod cons_def_sym heaps error
# case_patterns = NewTypePatterns {gi_module = type_def_mod, gi_index = type_def_index} [alt]
# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
= (case_expr, heaps, error)
build_expr_for_newtype_cons :: !Int !DefinedSymbol !*Heaps !*ErrorAdmin -> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
build_expr_for_newtype_cons type_def_mod cons_def_sym heaps error
# (var_expr, var, heaps) = buildVarExpr "x11" heaps
#! alg_pattern = {ap_symbol={glob_module=type_def_mod,glob_object=cons_def_sym}, ap_vars=[var], ap_expr=var_expr, ap_position=NoPos}
= (alg_pattern, heaps, error)
// build conversion for a record type def
build_expr_for_record type_def_mod type_def_index cons_def_sym=:{ds_ident, ds_arity} arg_expr heaps error
#! names = ["x1" +++ toString k \\ k <- [1..ds_arity]]
#! (var_exprs, vars, heaps) = buildVarExprs names heaps
#! (expr, heaps) = if (ds_arity==1)
(build_record (hd var_exprs) predefs heaps)
(build_prod var_exprs predefs heaps)
#! alg_pattern = { ap_symbol = {glob_module = type_def_mod, glob_object = cons_def_sym},
ap_vars = vars, ap_expr = expr, ap_position = NoPos }
# case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} [alg_pattern]