Skip to content
GitLab
Commit adbb49f0 authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl
Browse files

change generic bimap to: generic bimap a b | bimap b a :: .a ->.b

parent d74e4c8a
Hide whitespace changes
Inline Side-by-side
frontend/generics1.icl
View file @ adbb49f0
......@@ -32,10 +32,6 @@ import genericsupport
bimap_tofrom_function :: !FunctionIndexAndIdent,
bimap_to_function :: !FunctionIndexAndIdent,
bimap_from_function :: !FunctionIndexAndIdent,
bimap_arrow_function :: !FunctionIndexAndIdent,
bimap_arrow_arg_id_function :: !FunctionIndexAndIdent,
bimap_arrow_res_id_function :: !FunctionIndexAndIdent,
bimap_from_Bimap_function :: !FunctionIndexAndIdent,
bimap_PAIR_function :: !FunctionIndexAndIdent,
bimap_EITHER_function :: !FunctionIndexAndIdent,
bimap_OBJECT_function :: !FunctionIndexAndIdent,
......@@ -57,7 +53,10 @@ FIELD_NewType_Mask:==8;
:: PredefinedSymbolsData = !{psd_predefs_a :: !{#PredefinedSymbol}, psd_generic_newtypes::!Int}
:: TypeVarInfo
| TVI_Iso !DefinedSymbol !DefinedSymbol
| TVI_BimapExpr !Bool !Expression !Expression // Expression corresponding to the type var during generic specialization
| TVI_Exprs ![((GlobalIndex,[Int]), Expression)] // List of expressions corresponding to the type var during generic specialization
| TVI_SimpleBimapArgExpr !Expression
:: *GenericState =
{ gs_modules :: !*Modules
......@@ -249,10 +248,6 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
bimap_tofrom_function = undefined_function_and_ident,
bimap_to_function = undefined_function_and_ident,
bimap_from_function = undefined_function_and_ident,
bimap_arrow_function = undefined_function_and_ident,
bimap_arrow_arg_id_function = undefined_function_and_ident,
bimap_arrow_res_id_function = undefined_function_and_ident,
bimap_from_Bimap_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,
......@@ -371,9 +366,6 @@ buildGenericTypeRep type_index funs_and_groups
# (to_fun_ds, funs_and_groups, heaps, gs_error)
= buildConversionTo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error
# (iso_fun_ds, funs_and_groups, heaps, gs_error)
= buildConversionIso type_def from_fun_ds to_fun_ds "iso" 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 & gs_modules = gs_modules
, gs_td_infos = gs_td_infos
......@@ -384,7 +376,7 @@ buildGenericTypeRep type_index funs_and_groups
, gs_genh = hp_generic_heap
, gs_exprh = hp_expression_heap
}
= ({gtr_type=atype,gtr_iso=iso_fun_ds,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
= ({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
......@@ -399,12 +391,10 @@ buildBimapGenericTypeRep type_index funs_and_groups
= 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
(iso_fun_ds, funs_and_groups, heaps, gs_error)
= buildConversionIso type_def from_fun_ds to_fun_ds "iso-" 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_iso=iso_fun_ds,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
= ({gtr_type=atype,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
// the structure type
......@@ -487,19 +477,11 @@ where
| glob_module == pds_module && glob_object == pds_def
&& (case args of [{at_type=TB _}] -> True; _ -> False)
-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
RecordType _
# {pds_module, pds_def} = psd_predefs_a.[PD_TypeBimap]
| glob_module == pds_module && glob_object == pds_def
&& case args of [_,_] -> True; _ -> False
#! (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)
-> (GTSAppBimap kind args, st)
AlgType alts
# n_args = length args
| n_args>0 && type_arity==n_args
# (can_generate_bimap_to_or_from,modules,heaps)
= can_generate_bimap_to_or_from_for_this_type type_def glob_module alts modules heaps
= can_generate_bimap_to_or_from_for_this_type type_def.td_args glob_module alts modules heaps
| 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)
......@@ -514,41 +496,41 @@ where
#! (args, st) = convert_args args (modules, td_infos, heaps, error)
= (GTSAppCons kind args, st)
can_generate_bimap_to_or_from_for_this_type :: !CheckedTypeDef !Index ![DefinedSymbol] !*Modules !*Heaps -> (!Bool,!*Modules,!*Heaps)
can_generate_bimap_to_or_from_for_this_type type_def=:{td_args} type_def_module_n alts modules heaps=:{hp_type_heaps}
# th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars
#! ok = check_constructors alts type_def_module_n modules th_vars
# th_vars = remove_type_argument_numbers td_args th_vars
# heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}}
= (ok,modules,heaps)
where
check_constructors :: ![DefinedSymbol] !Index !Modules !TypeVarHeap -> Bool
check_constructors [{ds_index}:constructors] type_def_module_n modules th_vars
# {cons_type,cons_exi_vars} = modules.[type_def_module_n].com_cons_defs.[ds_index]
= isEmpty cons_exi_vars &&
isEmpty cons_type.st_context &&
check_constructor cons_type.st_args 0 th_vars &&
check_constructors constructors type_def_module_n modules th_vars
check_constructors [] type_def_module_n modules th_vars
= True
check_constructor :: ![AType] !Int !TypeVarHeap -> Bool
check_constructor [{at_type=TV {tv_info_ptr}}:atypes] used_type_vars th_vars
= case sreadPtr tv_info_ptr th_vars of
TVI_GenTypeVarNumber arg_n
# arg_mask = 1<<arg_n
| used_type_vars bitand arg_mask<>0
-> False
# used_type_vars = used_type_vars bitor arg_mask
-> check_constructor atypes used_type_vars th_vars
check_constructor [_:_] used_type_vars th_vars
= False
check_constructor [] used_type_vars th_vars
= True
convert_args args st
= mapSt convert args st
can_generate_bimap_to_or_from_for_this_type :: ![ATypeVar] !Index ![DefinedSymbol] !*Modules !*Heaps -> (!Bool,!*Modules,!*Heaps)
can_generate_bimap_to_or_from_for_this_type td_args type_def_module_n alts modules heaps=:{hp_type_heaps}
# th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars
#! ok = check_constructors alts type_def_module_n modules th_vars
# th_vars = remove_type_argument_numbers td_args th_vars
# heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}}
= (ok,modules,heaps)
where
check_constructors :: ![DefinedSymbol] !Index !Modules !TypeVarHeap -> Bool
check_constructors [{ds_index}:constructors] type_def_module_n modules th_vars
# {cons_type,cons_exi_vars} = modules.[type_def_module_n].com_cons_defs.[ds_index]
= isEmpty cons_exi_vars &&
isEmpty cons_type.st_context &&
check_constructor cons_type.st_args 0 th_vars &&
check_constructors constructors type_def_module_n modules th_vars
check_constructors [] type_def_module_n modules th_vars
= True
check_constructor :: ![AType] !Int !TypeVarHeap -> Bool
check_constructor [{at_type=TV {tv_info_ptr}}:atypes] used_type_vars th_vars
= case sreadPtr tv_info_ptr th_vars of
TVI_GenTypeVarNumber arg_n
# arg_mask = 1<<arg_n
| used_type_vars bitand arg_mask<>0
-> False
# used_type_vars = used_type_vars bitor arg_mask
-> check_constructor atypes used_type_vars th_vars
check_constructor [_:_] used_type_vars th_vars
= False
check_constructor [] used_type_vars th_vars
= True
// 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)
......@@ -574,16 +556,6 @@ where
= (GTSAppConsBimapKindConst, st)
# (args, st) = mapSt simplify args st
= (GTSAppConsSimpleType type_symbol_n kind args, st)
simplify t=:(GTSAppBimap KindConst []) st
= (t, st)
simplify (GTSAppBimap 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)
# (args, st) = mapSt simplify args st
= (GTSAppBimap kind args, st)
simplify (GTSArrow x y) st
# contains_gen_vars = occurs2 x y st
| not contains_gen_vars
......@@ -627,7 +599,6 @@ where
occurs (GTSAppCons _ args) st = occurs_list args st
occurs (GTSAppConsSimpleType _ _ args) st = occurs_list args st
occurs (GTSAppBimap _ 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
......@@ -1055,30 +1026,6 @@ where
// conversions functions
// buildConversionIso
buildConversionIso ::
!CheckedTypeDef // the type definition
!DefinedSymbol // from fun
!DefinedSymbol // to fun
!{#Char} // iso ident prefix
!Index // main module
!PredefinedSymbolsData
FunsAndGroups !*Heaps !*ErrorAdmin
-> (!DefinedSymbol,
FunsAndGroups,!*Heaps,!*ErrorAdmin)
buildConversionIso type_def=:{td_ident, td_pos} from_fun to_fun iso_ident_prefix
main_dcl_module_n predefs funs_and_groups heaps error
#! (from_expr, heaps) = buildFunApp main_dcl_module_n from_fun [] heaps
#! (to_expr, heaps) = buildFunApp main_dcl_module_n to_fun [] heaps
#! (iso_expr, heaps) = build_bimap_record to_expr from_expr predefs heaps
#! ident = makeIdent (iso_ident_prefix +++ td_ident.id_name)
#! (def_sym, funs_and_groups) = buildFunAndGroup ident [] iso_expr No main_dcl_module_n td_pos funs_and_groups
= (def_sym, funs_and_groups, heaps, error)
build_bimap_record to_expr from_expr predefs heaps
= buildPredefConsApp PD_ConsBimap [to_expr, from_expr] predefs heaps
// conversion from type to generic
buildConversionTo ::
!Index // type def module
......@@ -2765,7 +2712,7 @@ buildGenericCaseBody main_module_index gc_pos (TypeConsSymb {type_ident,type_ind
-> bimap_gen_type_rep
_ -> abort "sanity check: no generic representation\n"
#! (type_def=:{td_args, td_arity}, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
#! (type_def=:{td_args,td_arity,td_rhs}, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
#! (generated_arg_exprss, original_arg_exprs, arg_vars, heaps)
= build_arg_vars gen_def gcf_generic td_args heaps
......@@ -2777,6 +2724,13 @@ buildGenericCaseBody main_module_index gc_pos (TypeConsSymb {type_ident,type_ind
in (arg_vars,heaps_))
(arg_vars,heaps)
# (is_simple_bimap,modules,heaps)
= test_if_simple_bimap gcf_generic td_args td_rhs type_index.glob_module psd_predefs_a modules heaps
| is_simple_bimap
# (body_expr,modules,heaps) = build_simple_bimap td_args td_rhs type_index generated_arg_exprss original_arg_exprs modules heaps
# st & ss_modules=modules,ss_td_infos=td_infos,ss_heaps=heaps
= (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, st)
# st & ss_modules=modules,ss_td_infos=td_infos,ss_heaps=heaps
#! (specialized_expr, st)
= build_specialized_expr gc_pos gc_ident gcf_generic gen_def.gen_deps gen_def.gen_vars gtr_type td_args generated_arg_exprss gen_def.gen_info_ptr st
......@@ -2818,7 +2772,7 @@ where
# generic_bimap = psd_predefs_a.[PD_GenericBimap]
| gcf_generic.gi_module==generic_bimap.pds_module && gcf_generic.gi_index==generic_bimap.pds_def
#! bimap_spec_env = [(atv_variable, TVI_Expr False (hd exprs)) \\ {atv_variable} <- td_args & exprs <- generated_arg_exprss]
#! bimap_spec_env = [(atv_variable, TVI_BimapExpr False bimap_a_b_expr bimap_b_a_expr) \\ {atv_variable} <- td_args & [bimap_a_b_expr,bimap_b_a_expr] <- generated_arg_exprss]
// JvG: can probably make special version of simplify_bimap_GenTypeStruct that doesn't simplify if any var occurs, because all vars are passed
# (gtr_type, heaps) = simplify_bimap_GenTypeStruct [atv_variable \\ {atv_variable} <- td_args] gtr_type st.ss_heaps
......@@ -2842,14 +2796,14 @@ where
adapt_specialized_expr :: Position GenericDef GenericTypeRep [Expression] Expression
!FunsAndGroups !*Modules !*TypeDefInfos !*Heaps !*ErrorAdmin
-> (!Expression,!FunsAndGroups,!*Modules,!*TypeDefInfos,!*Heaps,!*ErrorAdmin)
adapt_specialized_expr gc_pos {gen_type, gen_vars, gen_info_ptr} {gtr_iso,gtr_to,gtr_from} original_arg_exprs specialized_expr
adapt_specialized_expr gc_pos {gen_type, gen_vars, gen_info_ptr} {gtr_to,gtr_from} original_arg_exprs specialized_expr
funs_and_groups modules td_infos heaps error
#! (var_kinds, heaps) = get_var_kinds gen_info_ptr heaps
#! non_gen_var_kinds = drop (length gen_vars) var_kinds
#! non_gen_vars = gen_type.st_vars -- gen_vars
#! (gen_env, heaps)
= build_gen_env gtr_iso gtr_to gtr_from gen_vars heaps
= build_gen_env gtr_to gtr_from gen_vars heaps
#! (non_gen_env, funs_and_groups, heaps)
= build_non_gen_env non_gen_vars non_gen_var_kinds funs_and_groups heaps
#! spec_env = gen_env ++ non_gen_env
......@@ -2877,12 +2831,12 @@ where
curry_symbol_type {st_args, st_result}
= foldr (\x y -> makeAType (x --> y) TA_Multi) st_result st_args
build_gen_env :: !DefinedSymbol !DefinedSymbol !DefinedSymbol ![TypeVar] !*Heaps -> (![(!TypeVar, !TypeVarInfo)], !*Heaps)
build_gen_env gtr_iso gtr_to gtr_from gen_vars heaps
build_gen_env :: !DefinedSymbol !DefinedSymbol ![TypeVar] !*Heaps -> (![(!TypeVar, !TypeVarInfo)], !*Heaps)
build_gen_env gtr_to gtr_from gen_vars heaps
= mapSt build_iso_expr gen_vars heaps
where
build_iso_expr gen_var heaps
= ((gen_var, TVI_Iso gtr_iso gtr_to gtr_from), heaps)
= ((gen_var, TVI_Iso gtr_to gtr_from), heaps)
build_non_gen_env :: ![TypeVar] ![TypeKind] FunsAndGroups !*Heaps -> (![(!TypeVar, !TypeVarInfo)], !FunsAndGroups, !*Heaps)
build_non_gen_env non_gen_vars kinds funs_and_groups heaps
......@@ -2892,15 +2846,68 @@ where
build_bimap_expr non_gen_var KindConst funs_and_groups heaps
# (expr, funs_and_groups, heaps)
= bimap_id_expression main_module_index predefs funs_and_groups heaps
= ((non_gen_var, TVI_Expr True expr), funs_and_groups, heaps)
= ((non_gen_var, TVI_BimapExpr True expr expr), funs_and_groups, heaps)
build_bimap_expr non_gen_var kind funs_and_groups heaps
#! (expr, heaps)
= buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps
= ((non_gen_var, TVI_Expr False expr), funs_and_groups, heaps)
= ((non_gen_var, TVI_BimapExpr False expr expr), funs_and_groups, heaps)
buildGenericCaseBody main_module_index gc_pos gc_type_cons gc_ident generic_info_index gcf_generic predefs st
# error = reportError gc_ident.id_name gc_pos "cannot specialize to this type" st.ss_error
= (TransformedBody {tb_args=[], tb_rhs=EE}, {st & ss_error=error})
test_if_simple_bimap :: GlobalIndex [ATypeVar] TypeRhs Int PredefinedSymbols !*Modules !*Heaps -> (!Bool,!*Modules,!*Heaps)
test_if_simple_bimap gcf_generic td_args (AlgType alts) type_module psd_predefs_a modules heaps
# generic_bimap = psd_predefs_a.[PD_GenericBimap]
| gcf_generic.gi_module==generic_bimap.pds_module && gcf_generic.gi_index==generic_bimap.pds_def
= can_generate_bimap_to_or_from_for_this_type td_args type_module alts modules heaps
= (False,modules,heaps)
test_if_simple_bimap gcf_generic td_args td_rhs type_module psd_predefs_a modules heaps
= (False,modules,heaps)
build_simple_bimap :: [ATypeVar] !TypeRhs (Global Index) [[Expression]] [Expression] *Modules *Heaps -> (!Expression,!*Modules,!*Heaps)
build_simple_bimap td_args (AlgType alts) type_index generated_arg_exprss [original_arg_expr] modules heaps
# {hp_type_heaps} = heaps
th_vars = set_arg_exprs td_args generated_arg_exprss hp_type_heaps.th_vars
heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}
(alg_patterns,modules,heaps) = build_bimap_alg_patterns alts type_index.glob_module modules heaps
(case_expr,heaps) = build_bimap_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr alg_patterns heaps
{hp_type_heaps} = heaps
th_vars = remove_type_argument_numbers td_args hp_type_heaps.th_vars
heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}
= (case_expr,modules,heaps)
where
set_arg_exprs :: ![ATypeVar] ![[Expression]] !*TypeVarHeap -> *TypeVarHeap
set_arg_exprs [{atv_variable={tv_info_ptr}}:atype_vars] [[arg_expr:_]:arg_exprs] th_vars
# th_vars = writePtr tv_info_ptr (TVI_SimpleBimapArgExpr arg_expr) th_vars
= set_arg_exprs atype_vars arg_exprs th_vars
set_arg_exprs [] [] th_vars
= th_vars
build_bimap_alg_patterns :: [DefinedSymbol] Int !*Modules *Heaps -> (![AlgebraicPattern],!*Modules,!*Heaps)
build_bimap_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] type_module_n modules heaps
# (cons_args,modules) = modules![type_module_n].com_cons_defs.[ds_index].cons_type.st_args
arg_names = ["x" +++ toString k \\ k <- [1..ds_arity]]
(var_exprs, vars, heaps) = buildVarExprs arg_names heaps
{hp_type_heaps} = heaps
(args,th_vars) = bimaps_with_arg cons_args var_exprs hp_type_heaps.th_vars
heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}
(alg_pattern,heaps) = build_alg_pattern cons_ds vars args type_module_n heaps
(alg_patterns,modules,heaps) = build_bimap_alg_patterns alts type_module_n modules heaps
= ([alg_pattern:alg_patterns],modules,heaps)
build_bimap_alg_patterns [] type_module_n modules heaps
= ([],modules,heaps)
bimaps_with_arg :: [AType] [Expression] !*TypeVarHeap -> (![Expression],!*TypeVarHeap)
bimaps_with_arg [{at_type=TV {tv_info_ptr}}:type_args] [var_expr:var_exprs] th_vars
# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
= case tv_info of
TVI_SimpleBimapArgExpr bimap_expr
# (args,th_vars) = bimaps_with_arg type_args var_exprs th_vars
= ([bimap_expr @ [var_expr]:args],th_vars)
bimaps_with_arg [] [] th_vars
= ([],th_vars)
// convert generic type contexts into normal type contexts
convertGenericTypeContexts :: !*GenericState -> *GenericState
......@@ -3267,9 +3274,6 @@ where
TVI_Exprs exprs
# (argExpr, error) = lookupArgExpr gen_index g_nums exprs st.ss_error
-> (argExpr, {st & ss_heaps=heaps,ss_error=error})
TVI_Iso iso_ds to_ds from_ds
# (expr,heaps) = buildFunApp main_module_index iso_ds [] heaps
-> (expr, {st & ss_heaps=heaps})
where
lookupArgExpr x g_nums [((k,gen_var_nums),v):kvs] error
| k==x && g_nums==gen_var_nums
......@@ -3581,106 +3585,214 @@ specialize_generic_bimap ::
specialize_generic_bimap gen_index type spec_env gen_ident gen_pos main_module_index predefs funs_and_groups heaps error
#! heaps = set_tvs spec_env heaps
#! (expr, (funs_and_groups, heaps, error))
= specialize type (funs_and_groups, heaps, error)
= specialize_f type (funs_and_groups, heaps, error)
#! heaps = clear_tvs spec_env heaps
= (expr, funs_and_groups, heaps, error)
where
specialize (GTSAppCons KindConst []) (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps)
= bimap_id_expression main_module_index predefs funs_and_groups heaps
specialize_f (GTSAppCons KindConst []) (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSAppCons kind arg_types) st
#! (arg_exprs, st) = specialize_f_args arg_types st
= build_generic_app kind arg_exprs gen_index gen_ident st
specialize_f (GTSAppVar tv arg_types) st
#! (arg_exprs, st) = specialize_f_args arg_types st
#! (expr, st) = specialize_f_type_var tv st
= (expr @ arg_exprs, st)
specialize_f (GTSVar tv) st
= specialize_f_type_var tv st
specialize_f (GTSArrow x y) st=:(_,heaps,_)
| is_bimap_id x heaps
#! (y, st) = specialize_f y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_from_expression [y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
| is_bimap_id y heaps
#! (x, st) = specialize_b x st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_to_expression [x] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
#! (x, st) = specialize_b x st
#! (y, st) = specialize_f y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_tofrom_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSPair x y) st
#! (x, st) = specialize_f x st
#! (y, st) = specialize_f y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_PAIR_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSEither x y) st
#! (x, st) = specialize_f x st
#! (y, st) = specialize_f y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_EITHER_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f GTSAppConsBimapKindConst (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr ,(funs_and_groups, heaps, error))
specialize_f GTSUnit (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSCons1Bimap arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_f arg_type st
(expr, funs_and_groups, heaps)
= bimap_CONS_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSRecord1Bimap arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_f arg_type st
(expr, funs_and_groups, heaps)
= bimap_RECORD_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSCons _ _ _ _ arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_f arg_type st
(expr, funs_and_groups, heaps)
= bimap_CONS_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSRecord _ _ _ _ arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_f arg_type st
(expr, funs_and_groups, heaps)
= bimap_RECORD_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSField _ _ _ arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_f arg_type st
(expr, funs_and_groups, heaps)
= bimap_FIELD_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (GTSObject _ _ _ arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_f arg_type st
(expr, funs_and_groups, heaps)
= bimap_OBJECT_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f type (funs_and_groups, heaps, error)
#! error = reportError gen_ident.id_name gen_pos "cannot specialize " error
= (EE, (funs_and_groups, heaps, error))
specialize_f_args [arg_type:arg_types] st
# (f_arg_expr,st) = specialize_f arg_type st
(b_arg_expr,st) = specialize_b arg_type st
(arg_exprs,st) = specialize_f_args arg_types st
= ([f_arg_expr,b_arg_expr:arg_exprs],st)
specialize_f_args [] st
= ([],st)
specialize_b (GTSAppCons KindConst []) (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize (GTSAppCons kind arg_types) st
#! (arg_exprs, st) = mapSt specialize arg_types st
specialize_b (GTSAppCons kind arg_types) st
#! (arg_exprs, st) = specialize_b_args arg_types st
= build_generic_app kind arg_exprs gen_index gen_ident st
specialize (GTSAppVar tv arg_types) st
#! (arg_exprs, st) = mapSt specialize arg_types st
#! (expr, st) = specialize_type_var tv st
specialize_b (GTSAppVar tv arg_types) st
#! (arg_exprs, st) = specialize_b_args arg_types st
#! (expr, st) = specialize_b_type_var tv st
= (expr @ arg_exprs, st)
specialize (GTSVar tv) st
= specialize_type_var tv st
specialize (GTSArrow x y) st=:(_,heaps,_)
specialize_b (GTSVar tv) st
= specialize_b_type_var tv st
specialize_b (GTSArrow x y) st=:(_,heaps,_)
| is_bimap_id x heaps
#! (y, st) = specialize y st
#! (y, st) = specialize_b y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_arrow_arg_id_expression [y] main_module_index predefs funs_and_groups heaps
= bimap_from_expression [y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
| is_bimap_id y heaps
#! (x, st) = specialize x st
#! (x, st) = specialize_f x st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_arrow_res_id_expression [x] main_module_index predefs funs_and_groups heaps
= bimap_to_expression [x] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
#! (x, st) = specialize x st
#! (y, st) = specialize y st
#! (x, st) = specialize_f x st
#! (y, st) = specialize_b y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_arrow_expression [x,y] main_module_index predefs funs_and_groups heaps
= bimap_tofrom_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize (GTSPair x y) st
#! (x, st) = specialize x st
#! (y, st) = specialize y st
specialize_b (GTSPair x y) st
#! (x, st) = specialize_b x st
#! (y, st) = specialize_b y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_PAIR_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize (GTSEither x y) st
#! (x, st) = specialize x st
#! (y, st) = specialize y st
specialize_b (GTSEither x y) st
#! (x, st) = specialize_b x st
#! (y, st) = specialize_b y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_EITHER_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize GTSAppConsBimapKindConst (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps)
= bimap_id_expression main_module_index predefs funs_and_groups heaps
specialize_b GTSAppConsBimapKindConst (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr ,(funs_and_groups, heaps, error))
specialize GTSUnit (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps)
= bimap_id_expression main_module_index predefs funs_and_groups heaps
specialize_b GTSUnit (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize (GTSCons1Bimap arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st
specialize_b (GTSCons1Bimap arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize_b arg_type st
(expr, funs_and_groups, heaps)