Commit ff187c6e authored by Martin Wierich's avatar Martin Wierich
Browse files

now "list inferred types" can print attributes also

parent eeda1147
......@@ -950,22 +950,6 @@ checkSpecialTypes mod_index SP_None type_defs modules heaps cs
= (SP_None, type_defs, modules, heaps, cs)
/* MW: already defined in module syntax
instance <<< SelectorDef
where
(<<<) file {sd_symb} = file <<< sd_symb
*/
instance <<< AttrInequality
where
(<<<) file {ai_demanded,ai_offered}
= file <<< ai_offered <<< " <= " <<< ai_demanded
/*
instance <<< VarBind
where
(<<<) file vb = file <<< (vb.vb_var,vb.vb_vars)
*/
cOuterMostLevel :== 0
addTypeVariablesToSymbolTable :: ![ATypeVar] ![AttributeVar] !*TypeHeaps !*CheckState
......
......@@ -25,5 +25,5 @@ import checksupport, transform, overloading
| FrontEndPhaseConvertModules
| FrontEndPhaseAll
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !Bool !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
// upToPhase name paths list_inferred_types predefs files error io out
\ No newline at end of file
......@@ -78,7 +78,7 @@ instance == FrontEndPhase where
(==) a b
= equal_constructor a b
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !Bool !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface upToPhase mod_ident search_paths list_inferred_types predef_symbols hash_table files error io out
# (ok, mod, hash_table, error, predef_symbols, files)
= wantModule cWantIclFile mod_ident NoPos (hash_table -*-> ("Parsing:", mod_ident)) error search_paths predef_symbols files
......
......@@ -147,7 +147,7 @@ compileModule mod_name ms
loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths}
# (predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out, optional_syntax_tree)
= frontEndInterface FrontEndPhaseAll mod_ident {sp_locations = [], sp_paths = ms_paths} False predef_symbols hash_table ms_files ms_error ms_io ms_out
= frontEndInterface FrontEndPhaseAll mod_ident {sp_locations = [], sp_paths = ms_paths} No predef_symbols hash_table ms_files ms_error ms_io ms_out
ms
= {ms & ms_files=ms_files, ms_error=ms_error,ms_io=ms_io,ms_out=ms_out}
= case optional_syntax_tree of
......
......@@ -808,6 +808,8 @@ cNonRecursiveAppl :== False
:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId
| AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
| AVI_Count !Int /* auxiliary used in module typesupport */
:: AttrVarInfoPtr :== Ptr AttrVarInfo
:: AttrVarHeap :== Heap AttrVarInfo
......@@ -1159,7 +1161,7 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T
Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo,
BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns,
(Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification,
TypeCodeExpression, CoercionPosition
TypeCodeExpression, CoercionPosition, AttrInequality
instance == TypeAttribute
instance == Annotation
......
......@@ -768,6 +768,8 @@ cNotVarNumber :== -1
:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId
| AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
| AVI_Count !Int /* auxiliary used in module typesupport */
:: AttrVarInfoPtr :== Ptr AttrVarInfo
:: AttrVarHeap :== Heap AttrVarInfo
......@@ -1179,15 +1181,15 @@ where
instance toString TypeAttribute
where
toString (TA_Unique)
= "* "
= "*"
toString (TA_TempVar tav_number)
= "u" + toString tav_number + ": "
= "u" + toString tav_number + ":"
toString (TA_Var avar)
= toString avar + ": "
= toString avar + ":"
toString (TA_RootVar avar)
= toString avar + ": "
= toString avar + ":"
toString (TA_Anonymous)
= ". "
= "."
toString TA_None
= ""
toString TA_Multi
......@@ -1808,8 +1810,8 @@ readable :: !Ident -> String // somewhat hacky
readable {id_name}
| id_name=="_cons" || id_name=="_nil"
= "list constructor"
| id_name % (0,5) == "_tuple"
= "tuple"
| size id_name>0 && id_name.[0]=='_'
= id_name%(1, size id_name-1)
= id_name
instance <<< ImportedIdent
......
......@@ -7,5 +7,5 @@ import syntax, check
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
*/
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !Bool !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File, !*File)
......@@ -1561,17 +1561,26 @@ where
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
// MW4..
ts_out = ts.ts_out
ts_out = case list_inferred_types of
False
-> ts_out
_
# form = { form_properties = cNoProperties, form_attr_position = No }
-> ts_out <<< fun_symb <<< " :: "
<:: (form, clean_fun_type, Yes initialTypeVarBeautifulizer) <<< '\n'
th_attrs = ts_type_heaps.th_attrs
(ts_out, th_attrs)
= case list_inferred_types of
No
-> (ts_out, th_attrs)
Yes show_attributes
# form = { form_properties = if show_attributes cAttributed cNoProperties, form_attr_position = No }
// ts_out = ts_out <<< show_attributes <<< "\n"
(printable_type, th_attrs)
= case show_attributes of
True
-> beautifulizeAttributes clean_fun_type th_attrs
_
-> (clean_fun_type, th_attrs)
-> (ts_out <<< fun_symb <<< " :: "
<:: (form, printable_type, Yes initialTypeVarBeautifulizer) <<< '\n', th_attrs)
// ..MW4
ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }
// MW4 was: -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error, ts_out = ts_out })
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = { ts_type_heaps & th_attrs = th_attrs }, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error, ts_out = ts_out })
check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars, st_context} type_ptrs
defs fun_env attr_var_env type_heaps expr_heap error
......@@ -1602,7 +1611,7 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con
}
// MW4 was:typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !Bool !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File
// MW4 was: -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File, !*File)
// MW4 was:typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file
......
......@@ -2,7 +2,7 @@ definition module typesupport
import checksupport, StdCompare
from unitype import Coercions, CoercionTree, AttributePartition
from unitype import Coercions, CoercionTree, AttributePartition, CT_Empty
// MW: this switch is used to en(dis)able the fusion algorithm
SwitchFusion fuse dont_fuse :== dont_fuse
......@@ -47,6 +47,8 @@ expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribut
equivalent :: !SymbolType !TempSymbolType !Int !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps)
beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHeap)
:: AttrCoercion =
{ ac_demanded :: !Int
, ac_offered :: !Int
......@@ -72,3 +74,34 @@ class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a
instance <<< TempSymbolType
removeInequality :: !Int !Int !*Coercions -> .Coercions
anonymizeAttrVars :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHeap)
flattenCoercionTree :: !u:CoercionTree -> (![Int], !u:CoercionTree)
assignNumbersToAttrVars :: !SymbolType !*AttrVarHeap -> (!Int, ![AttributeVar], !.AttrVarHeap)
getImplicitAttrInequalities :: !SymbolType -> [AttrInequality]
// retrieve those inequalities that are implied by propagation
emptyCoercions :: !Int -> .Coercions
// Int: nr of attribute variables
addAttrEnvInequalities :: ![AttrInequality] !*Coercions !u:AttrVarHeap
-> (!.Coercions, !u:AttrVarHeap)
// assertion: the attribute variables point to (AVI_Attr (TA_TempVar nr)) where
// nr corresponds to the attribute variable
//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) = replace coercion_trees i CT_Empty
(x, coercion_tree) = f coercion_tree
= (x, snd (replace coercion_trees i coercion_tree))
//accCoercionTree :: !.(u:CoercionTree -> u:CoercionTree) !Int !*{!u:CoercionTree} -> {!u:CoercionTree}
appCoercionTree f i coercion_trees
:== acc_coercion_tree i coercion_trees
where
acc_coercion_tree i coercion_trees
# (coercion_tree, coercion_trees) = replace coercion_trees i CT_Empty
= snd (replace coercion_trees i (f coercion_tree))
This diff is collapsed.
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