diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/overloading.icl | 34 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/type.icl | 16 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 15 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 150 |
5 files changed, 183 insertions, 34 deletions
diff --git a/frontend/overloading.icl b/frontend/overloading.icl index ec2973a..109dfdc 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -95,21 +95,25 @@ where = Equal -instanceError symbol types err=:{ea_file,ea_loc} - # ea_file = ea_file <<< "Overloading error " <<< hd ea_loc <<< ": \"" <<< symbol <<< "\" no instance available of type " <<< types <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} - -contextError err=:{ea_file,ea_loc} - # ea_file = ea_file <<< "Overloading Error " <<< hd ea_loc <<< ": specified context is too general\n" - = { err & ea_file = ea_file, ea_ok = False} - -uniqueError symbol types err=:{ea_file, ea_loc} - # ea_file = ea_file <<< "Overloading/Uniqueness Error " <<< hd ea_loc <<< ": \"" <<< symbol <<< "\" uniqueness specification of instance conflicts with current application " <<< types <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} - -unboxError type err=:{ea_file,ea_loc} - # ea_file = ea_file <<< "Overloading error " <<< hd ea_loc <<< ": instance cannot be unboxed" <<< type <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} +instanceError symbol types err + # err = errorHeading "Overloading error" err + format = { form_properties = cNoProperties, form_position = [] } + = { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type " <:: (format, types) <<< '\n' } + +contextError err + # err = errorHeading "Overloading error" err + = { err & ea_file = err.ea_file <<< " specified context is too general\n"} + +uniqueError symbol types err + # err = errorHeading "Overloading/Uniqueness error" err + format = { form_properties = cAnnotated, form_position = [] } + = { err & ea_file = err.ea_file <<< " \"" <<< symbol + <<< "\" uniqueness specification of instance conflicts with current application " <:: (format, types) <<< '\n'} + +unboxError type err + # err = errorHeading "Overloading error of Array class" err + format = { form_properties = cNoProperties, form_position = [] } + = { err & ea_file = err.ea_file <<< ' ' <:: (format, type) <<< " instance cannot be unboxed\n"} get :: !a !(Env a b) -> b | == a get elem_id [] diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 6b0e72a..ee920a5 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1122,7 +1122,7 @@ instance == ModuleKind, Ident instance <<< Module a | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, Global object | <<< object, 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 + Optional a | <<< a, ConsVariable, BasicType, Annotation instance == TypeAttribute instance == Annotation diff --git a/frontend/type.icl b/frontend/type.icl index 332c20d..50b52b4 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -161,9 +161,11 @@ where contains_var var_id _ = False -cannotUnify t1 t2 position err=:{ea_file,ea_loc} - # ea_file = ea_file <<< hd ea_loc <<< ": cannot unify " <<< t1 <<< " with " <<< t2 <<< " near " <<< position <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} +cannotUnify t1 t2 position err + # err = errorHeading "Type error" err + format = { form_properties = cNoProperties, form_position = [] } + = { err & ea_file = err.ea_file <<< " cannot unify " <:: (format, t1) <<< " with " <:: (format, t2) <<< " near " <<< position <<< '\n' } + /* simplifyType ta=:(type :@: type_args) @@ -572,9 +574,9 @@ freshAttribute ts=:{ts_attr_store} , prop_error :: !.ErrorAdmin } - attribute_error type_attr err - = TypeError "* attribute expected insted of" type_attr "" err + # err = errorHeading "Type error" err + = { err & ea_file = err.ea_file <<< "* attribute expected instead of " <<< type_attr <<< '\n' } addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index={glob_object,glob_module}} cons_args, at_attribute} ps # (cons_args, props, ps=:{prop_td_infos,prop_type_heaps,prop_attr_vars,prop_attr_env,prop_error}) @@ -1287,7 +1289,9 @@ where specification_error type err - = TypeError "specified type conflicts with derived type" type "" err + # err = errorHeading "Type error" err + format = { form_properties = cAttributed, form_position = []} + = { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' } cleanUpAndCheckFunctionTypes [] defs type_contexts coercion_env attr_partition type_var_env attr_var_env fun_defs ts = (fun_defs, ts) diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index 703fb41..d1385f7 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -4,7 +4,20 @@ import checksupport, StdCompare from unitype import Coercions, CoercionTree, AttributePartition -TypeError :: !String !mess !String !*ErrorAdmin -> *ErrorAdmin | <<< mess +errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin + +class (<::) infixl a :: !*File (!Format, !a) -> *File + +:: Format = + { form_properties :: !BITVECT + , form_position :: ![Int] + } + +cNoProperties :== 0 +cAttributed :== 4 +cAnnotated :== 8 + +instance <:: SymbolType, Type, AType, [a] | <:: a :: AttributeEnv :== {! TypeAttribute } :: VarEnv :== {! Type } diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 6c9379f..2d75653 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -179,23 +179,23 @@ where # (ok, (t,ts), env) = cleanUpClosed (t,ts) env = (ok, [t:ts], env) -TypeError :: !String !mess !String !*ErrorAdmin -> *ErrorAdmin | <<< mess -TypeError err_pref err_msg err_post err=:{ea_file,ea_loc} - | isEmpty ea_loc - # ea_file = ea_file <<< "Type error: " <<< err_pref <<< ' ' <<< err_msg <<< ' ' <<< err_post <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} - # ea_file = ea_file <<< "Type error " <<< hd ea_loc <<< ": " <<< err_pref <<< ' ' <<< err_msg <<< ' ' <<< err_post <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} - +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 } overloadingError class_symb err - = TypeError "internal overloading of class" class_symb "is unsolvable" err + # err = errorHeading "Type error" err + = { err & ea_file = err.ea_file <<< "internal overloading of class " <<< class_symb <<< " is unsolvable\n" } existentialError err - = TypeError "existential" "type variable" "appears in the derived type specification" err + # err = errorHeading "Type error" err + = { err & ea_file = err.ea_file <<< "existential type variable appears in the derived type specification\n" } liftedError var err - = TypeError "type variable of type of lifted argument" var "appears in the specified type" err + # err = errorHeading "Type error" err + = { err & ea_file = err.ea_file <<< "type variable of type of lifted argument " <<< var <<< " appears in the specified type\n" } clean_up_type_contexts [] env error = ([], env, error) @@ -738,6 +738,134 @@ where = (True, attr_env) = contains_coercion offered next_offered attr_env +:: Format = + { form_properties :: !BITVECT + , form_position :: ![Int] + } + +cNoProperties :== 0 +cCommaSeperator :== 1 +cBrackets :== 2 +cAttributed :== 4 +cAnnotated :== 8 + +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)} + +class (<::) infixl a :: !*File (!Format, !a) -> *File + +instance <:: SymbolType +where + (<::) file (form, {st_args, st_arity, st_result, st_context, st_attr_env}) + | st_arity > 0 + = show_environment form (show_context form (file <:: (form, st_args) <<< " -> " <:: (form, st_result)) st_context) st_attr_env + = show_environment form ((show_context form (file <:: (form, st_result))) st_context) st_attr_env + where + show_context form file [] + = file + show_context form file contexts + = file <<< " | " <:: (setProperty form cCommaSeperator, contexts) + + show_environment form file [] + = file + show_environment form file environ + = file <<< ", " <:: (setProperty form cCommaSeperator, environ) + +instance <:: TypeContext +where + (<::) file (form, {tc_class={glob_object={ds_ident}}, tc_types}) + = file <<< ds_ident <<< ' ' <:: (form, tc_types) + +instance <:: AttrInequality +where + (<::) file (form, {ai_demanded, ai_offered}) + = file <<< ai_offered <<< " <= " <<< ai_demanded + +instance <:: AType +where + (<::) file (form, {at_attribute, at_annotation, at_type}) + | checkProperty form cAnnotated + = show_attributed_type (file <<< at_annotation) form at_attribute at_type + = show_attributed_type file form at_attribute at_type + where + show_attributed_type file form TA_Multi type + = file <:: (form, type) + show_attributed_type file form attr type + | checkProperty form cAttributed + = file <<< attr <:: (setProperty form cBrackets, type) + = file <:: (form, type) + +instance <:: Type +where + (<::) file (form, TV varid) + = file <<< varid + (<::) file (form, TempV tv_number) + = file <<< 'v' <<< tv_number + (<::) file (form, TA {type_name,type_index,type_arity} types) + | is_predefined type_index + | is_list type_name + = file <<< '[' <:: (setProperty form cCommaSeperator, types) <<< ']' + | is_lazy_array type_name + = file <<< '{' <:: (setProperty form cCommaSeperator, types) <<< '}' + | is_strict_array type_name + = file <<< "{!" <:: (setProperty form cCommaSeperator, types) <<< '}' + | is_unboxed_array type_name + = file <<< "{#" <:: (setProperty form cCommaSeperator, types) <<< '}' + | is_tuple type_name type_arity + = file <<< '(' <:: (setProperty form cCommaSeperator, types) <<< ')' + | checkProperty form cBrackets && type_arity > 0 + = file <<< '(' <<< type_name <<< ' ' <:: (form, types) <<< ')' + = file <<< type_name <<< ' ' <:: (setProperty form cBrackets, types) + | checkProperty form cBrackets && type_arity > 0 + = file <<< '(' <<< type_name <<< ' ' <:: (form, types) <<< ')' + = file <<< type_name <<< ' ' <:: (setProperty form cBrackets, types) + where + is_predefined {glob_module} = glob_module == cPredefinedModuleIndex + + is_list {id_name} = id_name == "_list" + is_tuple {id_name} tup_arity = id_name == "_tuple" +++ toString tup_arity + is_lazy_array {id_name} = id_name == "_array" + is_strict_array {id_name} = id_name == "_!array" + is_unboxed_array {id_name} = id_name == "_#array" + + (<::) file (form, arg_type --> res_type) + | checkProperty form cBrackets + = file <<< '(' <:: (form, arg_type) <<< " -> " <:: (form, res_type) <<< ')' + = file <:: (setProperty form cBrackets, arg_type) <<< " -> " <:: (setProperty form cBrackets, res_type) + (<::) file (form, type :@: types) + | checkProperty form cBrackets + = file <<< '(' <<< type <<< ' ' <:: (form, types) <<< ')' + = file <<< type <<< ' ' <:: (setProperty form cBrackets, types) + (<::) file (form, TB tb) + = file <<< tb + (<::) file (form, TQV varid) + = file <<< "E." <<< varid + (<::) file (form, TempQV tv_number) + = file <<< "E." <<< tv_number <<< ' ' + (<::) file (form, TE) + = file <<< "__" + + +instance <:: [a] | <:: a +where + (<::) file (form, [type]) + | checkProperty form cCommaSeperator + = file <:: (clearProperty form cCommaSeperator, type) + = file <:: (setProperty form cBrackets, type) + (<::) file (form, [type : types]) + | checkProperty form cCommaSeperator + = file <:: (clearProperty form cCommaSeperator, type) <<< ',' <:: (form, types) + = file <:: (setProperty form cBrackets, type) <<< ' ' <:: (form, types) + (<::) file (form, []) + = file + +from compare_constructor import equal_constructor + +instance == Format +where + (==) form1 form2 = equal_constructor form1 form2 + instance <<< TypeContext where (<<<) file tc = file <<< tc.tc_class.glob_object.ds_ident <<< ' ' <<< tc.tc_types |