Commit 9a5600b8 authored by John van Groningen's avatar John van Groningen
Browse files

use bimapId instead of bimap{|*|} for variables

parent dc8eb8e7
...@@ -201,7 +201,7 @@ where ...@@ -201,7 +201,7 @@ where
= td_infos = td_infos
#! (td_infos1, td_infos) = replace td_infos n {} #! (td_infos1, td_infos) = replace td_infos n {}
#! td_infos1 = clear_td_infos 0 td_infos1 #! td_infos1 = clear_td_infos 0 td_infos1
#! (_, td_infos) = replace td_infos n td_infos1 #! td_infos = {td_infos & [n]=td_infos1}
= clear_modules (inc n) td_infos = clear_modules (inc n) td_infos
clear_td_infos n td_infos clear_td_infos n td_infos
...@@ -406,13 +406,10 @@ where ...@@ -406,13 +406,10 @@ where
// because bimaps for types not containing generic variables are indentity bimaps // because bimaps for types not containing generic variables are indentity bimaps
simplifyStructOfGenType :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps) simplifyStructOfGenType :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplifyStructOfGenType gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} simplifyStructOfGenType gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
| True #! th_vars = foldSt mark_type_var gvars th_vars
#! th_vars = foldSt mark_type_var gvars th_vars #! (type, th_vars) = simplify type th_vars
#! (type, th_vars) = simplify type th_vars #! th_vars = foldSt clear_type_var gvars th_vars
#! th_vars = foldSt clear_type_var gvars th_vars = (type, { heaps & hp_type_heaps = { hp_type_heaps & th_vars = th_vars}})
= (type, { heaps & hp_type_heaps = { hp_type_heaps & th_vars = th_vars}})
| otherwise
= (type, heaps)
where where
simplify t=:(GTSAppCons KindConst []) st simplify t=:(GTSAppCons KindConst []) st
= (t, st) = (t, st)
...@@ -421,7 +418,7 @@ where ...@@ -421,7 +418,7 @@ where
# actual_arity = length args # actual_arity = length args
# (contains_gen_vars, st) = occurs_list args st # (contains_gen_vars, st) = occurs_list args st
| formal_arity == actual_arity && not contains_gen_vars | formal_arity == actual_arity && not contains_gen_vars
= (GTSAppCons KindConst [], st) = (GTSAppConsBimapKindConst, st)
| otherwise | otherwise
# (args, st) = mapSt simplify args st # (args, st) = mapSt simplify args st
=(GTSAppCons kind args, st) =(GTSAppCons kind args, st)
...@@ -1425,11 +1422,20 @@ where ...@@ -1425,11 +1422,20 @@ where
#! num_gen_vars = length gen_vars #! num_gen_vars = length gen_vars
#! tvs = st_vars -- gen_vars #! tvs = st_vars -- gen_vars
#! kinds = drop num_gen_vars gen_var_kinds #! kinds = drop num_gen_vars gen_var_kinds
#! (bimap_contexts, gs_varh) = zipWithSt build_context tvs kinds gs_varh #! (bimap_contexts, gs_varh) = build_contexts tvs kinds gs_varh
#! gs = {gs & gs_varh = gs_varh, gs_genh = gs_genh} #! gs = {gs & gs_varh = gs_varh, gs_genh = gs_genh}
= ({gen_type & st_context = st_context ++ bimap_contexts}, gs) = ({gen_type & st_context = st_context ++ bimap_contexts}, gs)
where where
build_contexts [] [] st
= ([], st)
build_contexts [x:xs] [KindConst:kinds] st
= build_contexts xs kinds st
build_contexts [x:xs] [kind:kinds] st
# (z, st) = build_context x kind st
# (zs, st) = build_contexts xs kinds st
= ([z:zs], st)
build_context tv kind gs_varh build_context tv kind gs_varh
#! (var_info_ptr, gs_varh) = newPtr VI_Empty gs_varh #! (var_info_ptr, gs_varh) = newPtr VI_Empty gs_varh
#! {pds_module, pds_def} = gs_predefs . [PD_GenericBimap] #! {pds_module, pds_def} = gs_predefs . [PD_GenericBimap]
...@@ -2126,6 +2132,9 @@ where ...@@ -2126,6 +2132,9 @@ where
= zipWithSt build_bimap_expr non_gen_vars kinds heaps = zipWithSt build_bimap_expr non_gen_vars kinds heaps
where where
// build application of generic bimap for a specific kind // build application of generic bimap for a specific kind
build_bimap_expr non_gen_var KindConst heaps
#! (expr, heaps) = buildPredefFunApp PD_bimapId [] predefs heaps
= ((non_gen_var, expr), heaps)
build_bimap_expr non_gen_var kind heaps build_bimap_expr non_gen_var kind heaps
# (generic_info_expr, heaps) = build_generic_info_expr heaps # (generic_info_expr, heaps) = build_generic_info_expr heaps
#! (expr, heaps) #! (expr, heaps)
...@@ -2424,6 +2433,10 @@ where ...@@ -2424,6 +2433,10 @@ where
= (expr, (td_infos, heaps, error)) = (expr, (td_infos, heaps, error))
specialize GTSAppConsBimapKindConst (td_infos, heaps, error)
# (expr, heaps) = buildPredefFunApp PD_bimapId [] predefs heaps
= (expr, (td_infos, heaps, error))
specialize type (td_infos, heaps, error) specialize type (td_infos, heaps, error)
#! error = reportError gen_ident gen_pos "cannot specialize " error #! error = reportError gen_ident gen_pos "cannot specialize " error
= (EE, (td_infos, heaps, error)) = (EE, (td_infos, heaps, error))
......
...@@ -43,8 +43,8 @@ instance == FunctionOrMacroIndex ...@@ -43,8 +43,8 @@ instance == FunctionOrMacroIndex
| STE_Field !Ident | STE_Field !Ident
| STE_Class | STE_Class
| STE_Member | STE_Member
| STE_Generic // AA | STE_Generic
| STE_GenericCase // AA | STE_GenericCase
| STE_Instance | STE_Instance
| STE_Variable !VarInfoPtr | STE_Variable !VarInfoPtr
| STE_TypeVariable !TypeVarInfoPtr | STE_TypeVariable !TypeVarInfoPtr
...@@ -342,7 +342,6 @@ cNameLocationDependent :== True ...@@ -342,7 +342,6 @@ cNameLocationDependent :== True
, ai_offered :: !AttributeVar , ai_offered :: !AttributeVar
} }
:: DefinedSymbol = :: DefinedSymbol =
{ ds_ident :: !Ident { ds_ident :: !Ident
, ds_arity :: !Int , ds_arity :: !Int
...@@ -373,8 +372,6 @@ cNameLocationDependent :== True ...@@ -373,8 +372,6 @@ cNameLocationDependent :== True
, me_priority :: !Priority , me_priority :: !Priority
} }
// AA ...
:: GenericDef = :: GenericDef =
{ gen_ident :: !Ident // the generics name in IC_Class { gen_ident :: !Ident // the generics name in IC_Class
, gen_member_ident :: !Ident // the generics name in IC_Member , gen_member_ident :: !Ident // the generics name in IC_Member
...@@ -429,13 +426,10 @@ cNameLocationDependent :== True ...@@ -429,13 +426,10 @@ cNameLocationDependent :== True
, gt_vars :: ![TypeVar] // generic arguments , gt_vars :: ![TypeVar] // generic arguments
, gt_arity :: !Int // number of generic arguments , gt_arity :: !Int // number of generic arguments
} }
//getGenericClassForKind :: !GenericDef !TypeKind -> (!Bool, DefinedSymbol) //getGenericClassForKind :: !GenericDef !TypeKind -> (!Bool, DefinedSymbol)
//addGenericKind :: !GenericDef !TypeKind -> !GenericDef //addGenericKind :: !GenericDef !TypeKind -> !GenericDef
// ... AA
:: InstanceType = :: InstanceType =
{ it_vars :: [TypeVar] { it_vars :: [TypeVar]
, it_types :: ![Type] , it_types :: ![Type]
...@@ -549,6 +543,7 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex} ...@@ -549,6 +543,7 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
| GTSAppVar TypeVar [GenTypeStruct] | GTSAppVar TypeVar [GenTypeStruct]
| GTSVar TypeVar | GTSVar TypeVar
| GTSArrow GenTypeStruct GenTypeStruct // needed for simplifying bimaps | GTSArrow GenTypeStruct GenTypeStruct // needed for simplifying bimaps
| GTSAppConsBimapKindConst // needed for simplifying bimaps
| GTSCons DefinedSymbol GenTypeStruct | GTSCons DefinedSymbol GenTypeStruct
| GTSField DefinedSymbol GenTypeStruct | GTSField DefinedSymbol GenTypeStruct
| GTSObject DefinedSymbol GenTypeStruct | GTSObject DefinedSymbol GenTypeStruct
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment