Commit ff5df190 authored by John van Groningen's avatar John van Groningen
Browse files

in error message for incorrect field type print name of field instead of argument number of record

parent e2f46796
......@@ -1424,7 +1424,8 @@ instance == OverloadedListType
:: CoercionPosition
= CP_Expression !Expression
| CP_FunArg !Ident !Int // Function symbol, argument position (>=1)
| CP_FunArg !Ident !Int // Function or constructor ident, argument position (>=1)
| CP_SymbArg !SymbIdent !Int // Function or constructor symbol, argument position (>=1)
| CP_LiftedFunArg !Ident !Ident // Function symbol, lifted argument ident
:: IdentPos =
......
......@@ -842,6 +842,8 @@ instance <<< CoercionPosition
where
(<<<) file (CP_FunArg fun_name arg_nr)
= file <<< "argument " <<< arg_nr <<< " of " <<< readable fun_name
(<<<) file (CP_SymbArg fun_name arg_nr)
= file <<< "argument " <<< arg_nr <<< " of " <<< readable fun_name.symb_ident
(<<<) file (CP_LiftedFunArg fun_name arg_name)
= file <<< "lifted argument " <<< arg_name <<< " of " <<< readable fun_name
(<<<) file (CP_Expression expression) = show_expression file expression
......
......@@ -210,37 +210,44 @@ where
type_error =: "Type error"
type_error_format =: { form_properties = cNoProperties, form_attr_position = No }
cannotUnify t1 t2 position=:(CP_Expression expr) err=:{ea_loc=[ip:_]}
cannotUnify t1 t2 position=:(CP_Expression expr) common_defs err=:{ea_loc=[ip:_]}
= case tryToOptimizePosition expr of
Yes (id_name, line)
# err = pushErrorAdmin { ip & ip_ident.id_name = id_name, ip_line = line } err
err = errorHeading type_error err
err = popErrorAdmin err
# err = { err & ea_file = err.ea_file <<< " cannot unify types:\n" }
# err = { err & ea_file = err.ea_file <<< " " <:: (type_error_format, t1, No) <<< '\n' }
# err = { err & ea_file = err.ea_file <<< " " <:: (type_error_format, t2, No) <<< '\n' }
-> err;
err = { err & ea_file = err.ea_file <<< " cannot unify demanded type with offered type:\n" }
err = { err & ea_file = err.ea_file <<< " " <:: (type_error_format, t1, No) <<< '\n' }
err = { err & ea_file = err.ea_file <<< " " <:: (type_error_format, t2, No) <<< '\n' }
-> err
_
-> cannot_unify t1 t2 position err
cannotUnify t1 t2 position err
= cannot_unify t1 t2 position err
-> cannot_unify t1 t2 position common_defs err
cannotUnify t1 t2 position common_defs err
= cannot_unify t1 t2 position common_defs err
cannot_unify t1 t2 position err
cannot_unify t1 t2 position common_defs err
# (err=:{ea_file}) = errorHeading type_error err
ea_file = case position of
CP_FunArg _ _
-> ea_file <<< "\"" <<< position <<< "\""
CP_SymbArg {symb_kind=SK_Constructor {glob_module,glob_object},symb_ident} arg_n
-> case common_defs.[glob_module].com_type_defs.[glob_object].td_rhs of
RecordType {rt_fields}
# field_name = rt_fields.[arg_n-1].fs_ident.id_name
record_name = symb_ident.id_name
record_name = if (record_name.[0]=='_') (record_name % (1,size record_name-1)) record_name
-> ea_file <<< "\"" <<< "field " <<< field_name <<< " of " <<< record_name <<< "\""
_
-> ea_file <<< "\"" <<< position <<< "\""
CP_SymbArg _ _
-> ea_file <<< "\"" <<< position <<< "\""
CP_LiftedFunArg _ _
-> ea_file <<< "\"" <<< position <<< "\""
_
-> ea_file
ea_file = case position of
CP_Expression _
-> ea_file <<< " near " <<< position <<< " :"
_
-> ea_file
ea_file = ea_file <<< " cannot unify types:\n"
ea_file = ea_file <<< " cannot unify demanded type with offered type:\n"
ea_file = ea_file <<< " " <:: (type_error_format, t1, No) <<< "\n"
ea_file = ea_file <<< " " <:: (type_error_format, t2, No) <<< "\n"
= { err & ea_file = ea_file}
......@@ -1384,23 +1391,24 @@ where
get_n_lifted_arguments _ _ ts
= (0,[],ts)
requirements_of_lifted_and_normal_args :: !TypeInput !SymbIdent !Int ![FreeVar] ![Expression] ![AType] !(!u:Requirements, !*TypeState) -> (!u:Requirements, !*TypeState)
requirements_of_lifted_and_normal_args :: !TypeInput SymbIdent !Int ![FreeVar] ![Expression] ![AType] !(!u:Requirements, !*TypeState) -> (!u:Requirements, !*TypeState)
requirements_of_lifted_and_normal_args ti fun_ident arg_nr _ exprs lts reqs_ts
| arg_nr>0
= requirements_of_args ti fun_ident arg_nr exprs lts reqs_ts
requirements_of_lifted_and_normal_args ti fun_ident arg_nr [{fv_ident}:fun_args] [expr:exprs] [lt:lts] reqs_ts
# (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr reqs_ts
position = CP_LiftedFunArg fun_ident.symb_ident fv_ident
req_type_coercions = [{ tc_demanded = lt, tc_offered = e_type, tc_position = position, tc_coercible = True } : reqs.req_type_coercions ]
#! type_coercion = {tc_demanded = lt, tc_offered = e_type, tc_position = CP_LiftedFunArg fun_ident.symb_ident fv_ident, tc_coercible = True}
# req_type_coercions = [type_coercion : reqs.req_type_coercions]
ts_expr_heap = storeAttribute opt_expr_ptr lt.at_attribute ts.ts_expr_heap
= requirements_of_lifted_and_normal_args ti fun_ident (arg_nr+1) fun_args exprs lts ({reqs & req_type_coercions = req_type_coercions}, {ts & ts_expr_heap = ts_expr_heap})
requirements_of_args :: !TypeInput !SymbIdent !Int ![Expression] ![AType] !(!u:Requirements, !*TypeState) -> (!u:Requirements, !*TypeState)
requirements_of_args :: !TypeInput SymbIdent !Int ![Expression] ![AType] !(!u:Requirements, !*TypeState) -> (!u:Requirements, !*TypeState)
requirements_of_args ti _ _ [] [] reqs_ts
= reqs_ts
requirements_of_args ti fun_ident arg_nr [expr:exprs] [lt:lts] reqs_ts
# (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr reqs_ts
req_type_coercions = [{tc_demanded = lt, tc_offered = e_type, tc_position = CP_FunArg fun_ident.symb_ident arg_nr, tc_coercible = True} : reqs.req_type_coercions ]
#! type_coercion = {tc_demanded = lt, tc_offered = e_type, tc_position = CP_SymbArg fun_ident arg_nr, tc_coercible = True}
# req_type_coercions = [type_coercion : reqs.req_type_coercions]
ts_expr_heap = storeAttribute opt_expr_ptr lt.at_attribute ts.ts_expr_heap
= requirements_of_args ti fun_ident (arg_nr+1) exprs lts ({reqs & req_type_coercions = req_type_coercions}, {ts & ts_expr_heap = ts_expr_heap})
......@@ -1968,15 +1976,14 @@ attributedBasicType (BT_String string_type) ts=:{ts_attr_store}
attributedBasicType bas_type ts=:{ts_attr_store}
= ({ at_attribute = TA_TempVar ts_attr_store, at_type = TB bas_type}, {ts & ts_attr_store = inc ts_attr_store})
unify_coercions [{tc_demanded,tc_offered,tc_position}:coercions] modules subst heaps err
# (succ, subst, heaps) = unify tc_demanded tc_offered modules subst heaps
unify_coercions [{tc_demanded,tc_offered,tc_position}:coercions] ti subst heaps err
# (succ, subst, heaps) = unify tc_demanded tc_offered ti subst heaps
| succ
= unify_coercions coercions modules subst heaps err
= unify_coercions coercions ti subst heaps err
# (_, subst_demanded, subst) = arraySubst tc_demanded subst
(_, subst_offered, subst) = arraySubst tc_offered subst
= (subst, heaps, cannotUnify subst_demanded subst_offered tc_position err)
// ---> ("unify_coercions", subst_demanded, subst_offered)
unify_coercions [] modules subst heaps err
= (subst, heaps, cannotUnify subst_demanded subst_offered tc_position ti.ti_common_defs err)
unify_coercions [] ti subst heaps err
= (subst, heaps, err)
InitFunEnv :: !Int -> *{! FunctionType}
......@@ -2594,6 +2601,8 @@ where
case tc_position of
CP_FunArg _ _
-> ea_file <<< "\"" <<< tc_position <<< "\" "
CP_SymbArg _ _
-> ea_file <<< "\"" <<< tc_position <<< "\" "
CP_LiftedFunArg _ _
-> ea_file <<< "\"" <<< tc_position <<< "\" "
_
......
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