[m-dev.] for review: improve typeclass error message

[Fergus Henderson]

Estimated hours taken: 0.75

Improve the error message for errors in type class instance
definitions that use the named (e.g. "pred(foo/N) is bar") syntax, as
suggested by Ralph Becket: for such procedures, just output "in bar/N"
rather than "in call to bar/N", since the user didn't write any
explicit call.

compiler/hlds_pred.m:
	Add a new marker `named_class_instance_method' to the pred_marker type.

compiler/hlds_out.m:
compiler/intermod.m:
	Handle the new marker.

compiler/check_typeclass.m:
	For instance methods defined using the named syntax,
	add the `named_class_instance_method' marker to their markers.

compiler/typecheck.m:
compiler/mode_errors.m:
	Pass the pred_markers down to hlds_out__write_call_arg_id.

compiler/hlds_out.m:
	Change hlds_out__write_call_arg_id so that for predicates with
	the `named_class_instance_method' marker, it doesn't output the
	"call to".

Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.36
diff -u -d -r1.36 check_typeclass.m
--- compiler/check_typeclass.m	2000/11/01 05:11:49	1.36
+++ compiler/check_typeclass.m	2000/11/02 01:42:23
@@ -663,7 +663,17 @@
 
 	Cond = true,
 	map__init(Proofs),
-	add_marker(Markers0, class_instance_method, Markers),
+	add_marker(Markers0, class_instance_method, Markers1),
+	( InstancePredDefn = name(_) ->
+		% For instance methods which are defined using the named
+		% syntax (e.g. "pred(...) is ...") rather than the clauses
+		% syntax, we record an additional marker; the only effect
+		% of this marker is that we output slightly different
+		% error messages for such predicates.
+		add_marker(Markers1, named_class_instance_method, Markers)
+	;
+		Markers = Markers1
+	),
 	module_info_globals(ModuleInfo0, Globals),
 	globals__lookup_string_option(Globals, aditi_user, User),
 
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.248
diff -u -d -r1.248 hlds_out.m
--- compiler/hlds_out.m	2000/11/01 05:11:53	1.248
+++ compiler/hlds_out.m	2000/11/02 02:14:19
@@ -87,8 +87,13 @@
 :- mode hlds_out__simple_call_id_to_string(in, out) is det.
 
 	% Write "argument %i of call to pred_or_func `foo/n'".
-:- pred hlds_out__write_call_arg_id(call_id, int, io__state, io__state).
-:- mode hlds_out__write_call_arg_id(in, in, di, uo) is det.
+	% The pred_markers argument is used to tell if the calling
+	% predicate is a type class method implementation; if so,
+	% we omit the "call to" part, since the user didn't write
+	% any explicit call.
+:- pred hlds_out__write_call_arg_id(call_id, int, pred_markers,
+		io__state, io__state).
+:- mode hlds_out__write_call_arg_id(in, in, in, di, uo) is det.
 
 :- pred hlds_out__write_pred_or_func(pred_or_func, io__state, io__state).
 :- mode hlds_out__write_pred_or_func(in, di, uo) is det.
@@ -400,7 +405,7 @@
 	io__write_strings(["`", Name, "' of "]),
 	hlds_out__write_simple_call_id(CallId).
 
-hlds_out__write_call_arg_id(CallId, ArgNum) -->
+hlds_out__write_call_arg_id(CallId, ArgNum, PredMarkers) -->
 	( { ArgNum =< 0 } ->
 		% Argument numbers that are less than or equal to zero
 		% are used for the type_info and typeclass_info arguments
@@ -416,12 +421,26 @@
 		io__write_string(" of ")
 	),	
 	(
-		{ CallId = generic_call(GenericCall) },
-		\+ { GenericCall = class_method(_, _) },
-		\+ { GenericCall = aditi_builtin(aditi_call(_, _, _, _), _) }
+		(
+			% The text printed for generic calls other than
+			% `aditi_call' and `class__method' does not need
+			% the "call to" prefix ("in call to higher-order
+			% call" is redundant, it's much better to just say
+			% "in higher-order call").
+			{ CallId = generic_call(GenericCall) },
+			\+ { GenericCall = class_method(_, _) },
+			\+ { GenericCall = aditi_builtin(aditi_call(_, _,
+				_, _), _) }
+		;
+			% For calls from type class instance implementations
+			% that were defined using the named syntax rather
+			% than the clause syntax, we also omit the "call to",
+			% since in that case there was no explicit call in
+			% the user's source code.
+			{ check_marker(PredMarkers,
+				named_class_instance_method) }
+		)
 	->
-		% The text printed for generic calls other than `aditi_call'
-		% and `class__method' does not need the "call to" prefix.
 		[]
 	;
 		io__write_string("call to ")
@@ -545,7 +564,15 @@
 
 hlds_out__write_unify_main_context(First, call(CallId, ArgNum), Context, no) -->
 	hlds_out__start_in_message(First, Context),
-	hlds_out__write_call_arg_id(CallId, ArgNum),
+	% The markers argument below is used only for type class method
+	% implementations defined using the named syntax rather than
+	% the clause syntax, and the bodies of such procedures should
+	% only contain a single call, so we shouldn't get unifications
+	% nested inside calls.  Hence we can safely initialize the
+	% markers to empty here.  (Anyway the worst possible consequence
+	% is slightly sub-optimal text for an error message.)
+	{ init_markers(Markers) },
+	hlds_out__write_call_arg_id(CallId, ArgNum, Markers),
 	io__write_string(":\n").
 
 :- pred hlds_out__write_unify_sub_contexts(bool, unify_sub_contexts,
@@ -833,6 +860,8 @@
 hlds_out__marker_name(obsolete, "obsolete").
 hlds_out__marker_name(class_method, "class_method").
 hlds_out__marker_name(class_instance_method, "class_instance_method").
+hlds_out__marker_name(named_class_instance_method,
+		"named_class_instance_method").
 hlds_out__marker_name((impure), "impure").
 hlds_out__marker_name((semipure), "semipure").
 hlds_out__marker_name(promised_pure, "promise_pure").
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.85
diff -u -d -r1.85 hlds_pred.m
--- compiler/hlds_pred.m	2000/10/13 13:55:25	1.85
+++ compiler/hlds_pred.m	2000/11/02 01:43:36
@@ -371,6 +371,15 @@
 				% This predicate was automatically
 				% generated for the implementation of
 				% a class method for an instance.
+	;	named_class_instance_method
+				% This predicate was automatically
+				% generated for the implementation of
+				% a class method for an instance,
+				% and the instance was defined using the
+				% named syntax (e.g. "pred(...) is ...")
+				% rather than the clause syntax.
+				% (For such predicates, we output slightly
+				% different error messages.)
 
 	;	(impure)	% Requests that no transformation that would
 				% be inappropriate for impure code be
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.86
diff -u -d -r1.86 intermod.m
--- compiler/intermod.m	2000/11/01 05:11:55	1.86
+++ compiler/intermod.m	2000/11/02 01:57:10
@@ -1563,6 +1563,7 @@
 	% There is no pragma required for generated class methods.
 intermod__should_output_marker(class_method, no).
 intermod__should_output_marker(class_instance_method, no).
+intermod__should_output_marker(named_class_instance_method, no).
 	% The warning for calls to local obsolete predicates should appear
 	% once in the defining module, not in importing modules.
 intermod__should_output_marker(obsolete, no).
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.66
diff -u -d -r1.66 mode_errors.m
--- compiler/mode_errors.m	1999/10/26 07:39:45	1.66
+++ compiler/mode_errors.m	2000/11/02 02:37:15
@@ -817,11 +817,10 @@
 	{ mode_info_get_context(ModeInfo, Context) },
 	{ mode_info_get_predid(ModeInfo, PredId) },
 	{ mode_info_get_procid(ModeInfo, ProcId) },
-	{ module_info_preds(ModuleInfo, Preds) },
-	{ map__lookup(Preds, PredId, PredInfo) },
-	{ pred_info_procedures(PredInfo, Procs) },
+	{ module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
+		PredInfo, ProcInfo) },
 	{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
-	{ map__lookup(Procs, ProcId, ProcInfo) },
+	{ pred_info_get_markers(PredInfo, PredMarkers) },
 	{ proc_info_declared_argmodes(ProcInfo, Modes0) },
 	{ strip_builtin_qualifiers_from_mode_list(Modes0, Modes) },
 	{ pred_info_name(PredInfo, Name0) },
@@ -835,7 +834,7 @@
 				MaybeDet, Context),
 	io__write_string("':\n"),
 	{ mode_info_get_mode_context(ModeInfo, ModeContext) },
-	write_mode_context(ModeContext, Context, ModuleInfo).
+	write_mode_context(ModeContext, Context, PredMarkers, ModuleInfo).
 
 %-----------------------------------------------------------------------------%
 
@@ -883,20 +882,21 @@
 
 	% XXX some parts of the mode context never get set up
 
-:- pred write_mode_context(mode_context, prog_context, module_info,
-				io__state, io__state).
-:- mode write_mode_context(in, in, in, di, uo) is det.
+:- pred write_mode_context(mode_context, prog_context, pred_markers,
+		module_info, io__state, io__state).
+:- mode write_mode_context(in, in, in, in, di, uo) is det.
 
-write_mode_context(uninitialized, _Context, _ModuleInfo) -->
+write_mode_context(uninitialized, _Context, _Markers, _ModuleInfo) -->
 	[].
 
-write_mode_context(call(CallId, ArgNum), Context, _ModuleInfo) -->
+write_mode_context(call(CallId, ArgNum), Context, Markers, _ModuleInfo) -->
 	prog_out__write_context(Context),
 	io__write_string("  in "),
-	hlds_out__write_call_arg_id(CallId, ArgNum),
+	hlds_out__write_call_arg_id(CallId, ArgNum, Markers),
 	io__write_string(":\n").
 
-write_mode_context(unify(UnifyContext, _Side), Context, _ModuleInfo) -->
+write_mode_context(unify(UnifyContext, _Side), Context, _Markers,
+		_ModuleInfo) -->
 	hlds_out__write_unify_context(UnifyContext, Context).
 
 %-----------------------------------------------------------------------------%
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.290
diff -u -d -r1.290 typecheck.m
--- compiler/typecheck.m	2000/11/01 05:12:14	1.290
+++ compiler/typecheck.m	2000/11/02 17:30:49
@@ -3295,6 +3295,17 @@
 
 %-----------------------------------------------------------------------------%
 
+:- pred typecheck_info_get_pred_markers(typecheck_info, pred_markers).
+:- mode typecheck_info_get_pred_markers(in, out) is det.
+
+typecheck_info_get_pred_markers(TypeCheckInfo, PredMarkers) :-
+	typecheck_info_get_module_info(TypeCheckInfo, ModuleInfo),
+	typecheck_info_get_predid(TypeCheckInfo, PredId),
+	module_info_pred_info(ModuleInfo, PredId, PredInfo),
+	pred_info_get_markers(PredInfo, PredMarkers).
+
+%-----------------------------------------------------------------------------%
+
 :- pred typecheck_info_set_called_predid(call_id, typecheck_info,
 			typecheck_info).
 :- mode typecheck_info_set_called_predid(in, typecheck_info_di,
@@ -5186,6 +5197,7 @@
 :- mode report_error_var(typecheck_info_no_io, in, in, in, di, uo) is det.
 
 report_error_var(TypeCheckInfo, VarId, Type, TypeAssignSet0) -->
+	{ typecheck_info_get_pred_markers(TypeCheckInfo, PredMarkers) },
 	{ typecheck_info_get_called_predid(TypeCheckInfo, CalledPredId) },
 	{ typecheck_info_get_arg_num(TypeCheckInfo, ArgNum) },
 	{ typecheck_info_get_context(TypeCheckInfo, Context) },
@@ -5193,7 +5205,8 @@
 	{ get_type_stuff(TypeAssignSet0, VarId, TypeStuffList) },
 	{ typecheck_info_get_varset(TypeCheckInfo, VarSet) },
 	write_context_and_pred_id(TypeCheckInfo),
-	write_call_context(Context, CalledPredId, ArgNum, UnifyContext),
+	write_call_context(Context, PredMarkers,
+		CalledPredId, ArgNum, UnifyContext),
 	prog_out__write_context(Context),
 	io__write_string("  type error: "),
 	( { TypeStuffList = [SingleTypeStuff] } ->
@@ -5231,6 +5244,7 @@
 :- mode report_error_arg_var(typecheck_info_no_io, in, in, di, uo) is det.
 
 report_error_arg_var(TypeCheckInfo, VarId, ArgTypeAssignSet0) -->
+	{ typecheck_info_get_pred_markers(TypeCheckInfo, PredMarkers) },
 	{ typecheck_info_get_called_predid(TypeCheckInfo, CalledPredId) },
 	{ typecheck_info_get_arg_num(TypeCheckInfo, ArgNum) },
 	{ typecheck_info_get_context(TypeCheckInfo, Context) },
@@ -5238,7 +5252,8 @@
 	{ get_arg_type_stuff(ArgTypeAssignSet0, VarId, ArgTypeStuffList) },
 	{ typecheck_info_get_varset(TypeCheckInfo, VarSet) },
 	write_context_and_pred_id(TypeCheckInfo),
-	write_call_context(Context, CalledPredId, ArgNum, UnifyContext),
+	write_call_context(Context, PredMarkers,
+		CalledPredId, ArgNum, UnifyContext),
 	prog_out__write_context(Context),
 	io__write_string("  type error: "),
 	( { ArgTypeStuffList = [SingleArgTypeStuff] } ->
@@ -5531,12 +5546,14 @@
 			in, in, di, uo) is det.
 
 report_error_undef_cons(TypeCheckInfo, InvalidFieldUpdates, Functor, Arity) -->
+	{ typecheck_info_get_pred_markers(TypeCheckInfo, PredMarkers) },
 	{ typecheck_info_get_called_predid(TypeCheckInfo, CalledPredId) },
 	{ typecheck_info_get_arg_num(TypeCheckInfo, ArgNum) },
 	{ typecheck_info_get_context(TypeCheckInfo, Context) },
 	{ typecheck_info_get_unify_context(TypeCheckInfo, UnifyContext) },
 	write_context_and_pred_id(TypeCheckInfo),
-	write_call_context(Context, CalledPredId, ArgNum, UnifyContext),
+	write_call_context(Context, PredMarkers,
+		CalledPredId, ArgNum, UnifyContext),
 	prog_out__write_context(Context),
 	%
 	% check for some special cases, so that we can give
@@ -5779,17 +5796,17 @@
 language_builtin("aditi_bulk_modify", 3).
 language_builtin("aditi_bulk_modify", 4).
 
-:- pred write_call_context(prog_context, call_id, int, unify_context,
-				io__state, io__state).
-:- mode write_call_context(in, in, in, in, di, uo) is det.
+:- pred write_call_context(prog_context, pred_markers,
+		call_id, int, unify_context, io__state, io__state).
+:- mode write_call_context(in, in, in, in, in, di, uo) is det.
 
-write_call_context(Context, CallId, ArgNum, UnifyContext) -->
+write_call_context(Context, PredMarkers, CallId, ArgNum, UnifyContext) -->
 	( { ArgNum = 0 } ->
 		hlds_out__write_unify_context(UnifyContext, Context)
 	;
 		prog_out__write_context(Context),
 		io__write_string("  in "),
-		hlds_out__write_call_arg_id(CallId, ArgNum),
+		hlds_out__write_call_arg_id(CallId, ArgNum, PredMarkers),
 		io__write_string(":\n")
 	).
 

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
                                    |  of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh>  |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------