diff: some more type class improvements

Fergus Henderson fjh at cs.mu.OZ.AU
Fri Apr 10 04:30:02 AEST 1998
Previous message: [m-dev.] for review: change typecheck.m to handle type class inference
Next message: [m-dev.] diff: some more type class improvements
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
Estimated hours taken: 4

A few more improvements to type class checking.

compiler/typecheck.m:
	Ensure that we run a final pass of context reduction at the
	end of typechecking each predicate (or function).

	Change the way perform_context_reduction recovers after errors
	to avoid reporting the same error more than once
	(e.g. for tests/invalid/typeclass_test_1.m).

	Simplify the code to check for and report unsatisfied
	type class constraints.

	Change write_type_assign so that it prints out the
	type class constraints as well as the variable types.

tests/invalid/typeclass_test_{1,2}.err_exp:
	Add a full stop that was missing at the end of
	the "unsatisfied typeclass constraint" error message.

Index: typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.235
diff -u -u -r1.235 typecheck.m
--- typecheck.m	1998/04/09 15:29:33	1.235
+++ typecheck.m	1998/04/09 18:15:08
@@ -481,13 +481,19 @@
 				TypeVarSet0, VarSet, ExplicitVarTypes,
 				HeadTypeParams, Constraints, Status,
 				TypeCheckInfo1),
+		typecheck_info_get_type_assign_set(TypeCheckInfo1,
+				OrigTypeAssignSet),
 		typecheck_clause_list(Clauses0, HeadVars, ArgTypes0, Clauses,
 				TypeCheckInfo1, TypeCheckInfo2),
-		typecheck_constraints(Inferring, TypeCheckInfo2,
+		% we need to perform a final pass of context reduction
+		% at the end, before checking the typeclass constraints
+		perform_context_reduction(OrigTypeAssignSet, TypeCheckInfo2,
 				TypeCheckInfo3),
+		typecheck_constraints(Inferring, TypeCheckInfo3,
+				TypeCheckInfo4),
 		typecheck_check_for_ambiguity(whole_pred, HeadVars,
-				TypeCheckInfo3, TypeCheckInfo4),
-		typecheck_info_get_final_info(TypeCheckInfo4, TypeVarSet, 
+				TypeCheckInfo4, TypeCheckInfo5),
+		typecheck_info_get_final_info(TypeCheckInfo5, TypeVarSet, 
 				InferredVarTypes0, InferredTypeConstraints,
 				ConstraintProofs),
 		map__optimize(InferredVarTypes0, InferredVarTypes),
@@ -2925,25 +2931,15 @@
 
 typecheck_constraints(yes, TypeCheckInfo, TypeCheckInfo).
 typecheck_constraints(no, TypeCheckInfo0, TypeCheckInfo) :-
-		% get the declared constraints
-	typecheck_info_get_constraints(TypeCheckInfo0, DeclaredConstraints),
-
+		% reject any type assignment whose constraints have
+		% not all been eliminated by context reduction
+		% (i.e. those chich have constraints which do not match the
+		% declared constraints and which are not redundant for any
+		% other reason)
 	typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet0),
-
-	ConstraintsMatch = lambda([TypeAssign::in] is semidet,
-		(
-			type_assign_get_typeclass_constraints(TypeAssign,
-				CalculatedConstraints0),
-			type_assign_get_type_bindings(TypeAssign, Bindings),
-			apply_rec_subst_to_constraints(Bindings,
-				CalculatedConstraints0, CalculatedConstraints),
-			constraints_match(CalculatedConstraints,
-				DeclaredConstraints)
-		)),
-
-		% reject any type assignment whose constraints don't match the
-		% declared ones
-	list__filter(ConstraintsMatch, TypeAssignSet0, TypeAssignSet),
+	NoConstraints = lambda([TypeAssign::in] is semidet,
+		type_assign_get_typeclass_constraints(TypeAssign, [])),
+	list__filter(NoConstraints, TypeAssignSet0, TypeAssignSet),
 	(
 			% Check that we haven't just eliminated
 			% all the type assignments. 
@@ -2958,14 +2954,6 @@
 	).
 
 			
-	% The calculated constraints must be a subset of the declared
-	% constraints.
-:- pred constraints_match(list(class_constraint)::in,
-		list(class_constraint)::in) is semidet.
-constraints_match(CalculatedConstraints, DeclaredConstraints) :-
-	all [C] list__member(C, CalculatedConstraints) =>
-		list__member(C, DeclaredConstraints).
-
 %-----------------------------------------------------------------------------%
 
 :- pred report_unsatisfied_constraints(type_assign_set, typecheck_info,
@@ -2976,8 +2964,6 @@
 report_unsatisfied_constraints(TypeAssignSet, TypeCheckInfo0, TypeCheckInfo) :-
 	typecheck_info_get_io_state(TypeCheckInfo0, IOState0),
 
-	typecheck_info_get_constraints(TypeCheckInfo0, DeclaredConstraints),
-
 	typecheck_info_get_context(TypeCheckInfo0, Context),
 	write_context_and_pred_id(TypeCheckInfo0, IOState0, IOState1),
 	prog_out__write_context(Context, IOState1, IOState2),
@@ -2994,11 +2980,9 @@
 				TheConstraints0, TheConstraints1),
 			list__sort_and_remove_dups(TheConstraints1,
 				TheConstraints),
-			list__delete_elems(TheConstraints, DeclaredConstraints,
-				Unsatisfied),
 			prog_out__write_context(Context, IO0, IO1),
 			io__write_string("  ", IO1, IO2),
-			io__write_list(Unsatisfied, ", ",
+			io__write_list(TheConstraints, ", ",
 				mercury_output_constraint(TheVarSet), IO2, IO3),
 			io__write_string(".\n", IO3, IO)
 		)),
@@ -3045,10 +3029,11 @@
 %	instance declaration for that type.
 %
 %	If all type_assigns from the typecheck_info are rejected, than an
-%	appropriate error message is given, and the type_assign_set is
-%	restored to the original one given by OrigTypeAssignSet.
+%	appropriate error message is given, the type_assign_set is
+%	restored to the original one given by OrigTypeAssignSet,
+%	but without any typeclass constraints.
 %	The reason for this is to avoid reporting the same error at
-%	every subsequent call to perform_context_reduction.
+%	subsequent calls to perform_context_reduction.
 
 :- pred perform_context_reduction(type_assign_set,
 			typecheck_info, typecheck_info).
@@ -3072,8 +3057,13 @@
 	->
 		report_unsatisfied_constraints(TypeAssignSet0,
 			TypeCheckInfo0, TypeCheckInfo1),
+		DeleteConstraints = lambda([TA0::in, TA::out] is det,
+			type_assign_set_typeclass_constraints(TA0, [], TA)
+		),
+		list__map(DeleteConstraints, OrigTypeAssignSet,
+			NewTypeAssignSet),
 		typecheck_info_set_type_assign_set(TypeCheckInfo1,
-			OrigTypeAssignSet, TypeCheckInfo)
+			NewTypeAssignSet, TypeCheckInfo)
 	;
 		typecheck_info_set_type_assign_set(TypeCheckInfo0,
 			TypeAssignSet, TypeCheckInfo)
@@ -4055,27 +4045,30 @@
 write_type_assign(TypeAssign, VarSet) -->
 	{
 	  type_assign_get_var_types(TypeAssign, VarTypes),
+	  type_assign_get_typeclass_constraints(TypeAssign, Constraints),
 	  type_assign_get_type_bindings(TypeAssign, TypeBindings),
 	  type_assign_get_typevarset(TypeAssign, TypeVarSet),
 	  map__keys(VarTypes, Vars)
 	},
-	write_type_assign_2(Vars, VarSet, VarTypes, TypeBindings, TypeVarSet,
-			no),
+	write_type_assign_types(Vars, VarSet, VarTypes,
+			TypeBindings, TypeVarSet, no),
+	write_type_assign_constraints(Constraints,
+			TypeBindings, TypeVarSet, no),
 	io__write_string("\n").
 
-:- pred write_type_assign_2(list(var), varset, map(var, type),
+:- pred write_type_assign_types(list(var), varset, map(var, type),
 			tsubst, tvarset, bool, io__state, io__state).
-:- mode write_type_assign_2(in, in, in, in, in, in, di, uo) is det.
+:- mode write_type_assign_types(in, in, in, in, in, in, di, uo) is det.
 
-write_type_assign_2([], _, _, _, _, FoundOne) -->
+write_type_assign_types([], _, _, _, _, FoundOne) -->
 	( { FoundOne = no } ->
 		io__write_string("(No variables were assigned a type)")
 	;
 		[]
 	).
 
-write_type_assign_2([Var | Vars], VarSet, VarTypes, TypeBindings, TypeVarSet,
-			FoundOne) -->
+write_type_assign_types([Var | Vars], VarSet, VarTypes, TypeBindings,
+				TypeVarSet, FoundOne) -->
 	( 
 		{ map__search(VarTypes, Var, Type) }
 	->
@@ -4087,12 +4080,30 @@
 		mercury_output_var(Var, VarSet, no),
 		io__write_string(" :: "),
 		write_type_b(Type, TypeVarSet, TypeBindings),
-		write_type_assign_2(Vars, VarSet, VarTypes, TypeBindings,
+		write_type_assign_types(Vars, VarSet, VarTypes, TypeBindings,
 			TypeVarSet, yes)
 	;
-		write_type_assign_2(Vars, VarSet, VarTypes, TypeBindings,
+		write_type_assign_types(Vars, VarSet, VarTypes, TypeBindings,
 			TypeVarSet, FoundOne)
 	).
+
+:- pred write_type_assign_constraints(list(class_constraint),
+			tsubst, tvarset, bool, io__state, io__state).
+:- mode write_type_assign_constraints(in, in, in, in, di, uo) is det.
+
+write_type_assign_constraints([], _, _, _) --> [].
+write_type_assign_constraints([Constraint | Constraints],
+			TypeBindings, TypeVarSet, FoundOne) -->
+	( { FoundOne = no } ->
+		io__write_string("\n\t<= ")
+	;
+		io__write_string(",\n\t   ")
+	),
+	{ apply_rec_subst_to_constraint(TypeBindings, Constraint,
+		BoundConstraint) },
+	mercury_output_constraint(TypeVarSet, BoundConstraint),
+	write_type_assign_constraints(Constraints,
+		TypeBindings, TypeVarSet, yes).
 
 	% write_type_b writes out a type after applying the type bindings.
 

Index: typeclass_test_1.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/typeclass_test_1.err_exp,v
retrieving revision 1.2
diff -u -u -r1.2 typeclass_test_1.err_exp
--- typeclass_test_1.err_exp	1998/02/02 02:55:57	1.2
+++ typeclass_test_1.err_exp	1998/04/09 18:22:40
@@ -3,5 +3,5 @@
 typeclass_test_1.m:017: Syntax error at variable `_': operator or `.' expected.
 typeclass_test_1.m:007: In clause for predicate `typeclass_test_1:main/2':
 typeclass_test_1.m:007:   unsatisfied typeclass constraint(s):
-typeclass_test_1.m:007:   typeclass_test_1:numbered_type(int)
+typeclass_test_1.m:007:   typeclass_test_1:numbered_type(int).
 For more information, try recompiling with `-E'.
Index: typeclass_test_2.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/typeclass_test_2.err_exp,v
retrieving revision 1.3
diff -u -u -r1.3 typeclass_test_2.err_exp
--- typeclass_test_2.err_exp	1998/03/03 17:48:02	1.3
+++ typeclass_test_2.err_exp	1998/04/09 18:22:18
@@ -4,6 +4,6 @@
 typeclass_test_2.m:018:   without preceding `func' declaration.
 typeclass_test_2.m:008: In clause for predicate `typeclass_test_2:main/2':
 typeclass_test_2.m:008:   unsatisfied typeclass constraint(s):
-typeclass_test_2.m:008:   typeclass_test_2:numbered_type(int)
+typeclass_test_2.m:008:   typeclass_test_2:numbered_type(int).
 typeclass_test_2.m:018: Inferred :- func foo_type_num(T1) = int.
 For more information, try recompiling with `-E'.

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>  |  of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3        |     -- the last words of T. S. Garp.
Previous message: [m-dev.] for review: change typecheck.m to handle type class inference
Next message: [m-dev.] diff: some more type class improvements
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
More information about the developers mailing list