[m-dev.] diff: fix typeclass bug

[Fergus Henderson]

Estimated hours taken: 1.5

Fix a bug reported by Dominique de Waleffe <ddw at miscrit.be>.

compiler/typecheck.m:
	Fix a bug: it was not applying the type bindings to the constraint
	proof map.  This caused a map__lookup error in polymorphism.m when
	it tried to look up the constraints in the constraint proof map.

tests/valid/Mmakefile:
tests/valid/constraint_proof_bug.m:
tests/valid/constraint_proof_bug_lib.m:
	Add a regression test for the above-mentioned bug.

cvs diff -N compiler/typecheck.m tests/valid/Mmakefile tests/valid/constraint_proof_bug.m tests/valid/constraint_proof_bug_lib.m
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.264
diff -u -r1.264 typecheck.m
--- typecheck.m	1999/07/13 08:53:36	1.264
+++ typecheck.m	1999/07/22 15:47:02
@@ -3068,10 +3068,12 @@
 		type_assign_get_typeclass_constraints(TypeAssign,
 			TypeConstraints),
 		type_assign_get_constraint_proofs(TypeAssign,
-			ConstraintProofs),
+			ConstraintProofs0),
 
 		map__keys(VarTypes0, Vars),
 		expand_types(Vars, TypeBindings, VarTypes0, VarTypes),
+		apply_rec_subst_to_constraint_proofs(TypeBindings,
+			ConstraintProofs0, ConstraintProofs),
 
 		%
 		% figure out how we should rename the existential types
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.37
diff -u -r1.37 Mmakefile
--- Mmakefile	1999/07/14 17:04:31	1.37
+++ Mmakefile	1999/07/22 16:43:26
@@ -20,6 +20,7 @@
 	semi_fail_in_non_ite.m
 
 TYPECLASS_SOURCES= \
+	constraint_proof_bug.m \
 	func_method.m \
 	instance_superclass.m \
 	instance_unconstrained_tvar.m
Index: tests/valid/constraint_proof_bug.m
===================================================================
RCS file: constraint_proof_bug.m
diff -N constraint_proof_bug.m
--- /dev/null	Fri Jul 23 03:05:01 1999
+++ constraint_proof_bug.m	Fri Jul 23 02:39:42 1999
@@ -0,0 +1,46 @@
+:- module constraint_proof_bug.
+
+:-interface.
+
+:-import_module io.
+
+:-pred main(io:state::di,io:state::uo) is det.
+
+:- implementation.
+:-import_module constraint_proof_bug_lib,io,string,require.
+
+:-type service==string.
+:-type prestationid==int.
+:-type provider==int.
+
+:-type bevent--->
+       prest(prestationid,date,code,provider)
+ ;     day(int,date)
+ ;     admit(date,service)
+ ;     discharge(date,service)
+ ;     transfer(date,service,service)
+ ;     wrong(date).
+
+:-some [T] pred get_field(bevent,string,T) => constrainable(T).
+:-mode get_field(in,in,out) is semidet.
+
+get_field(Ev,Field,R) :-
+	Field="date" -> R=d(Dt),get_date_field(Ev,Dt)
+	;
+	Field="code" -> R=c(Cd),get_code_field(Ev,Cd)
+	;
+	error("No handler for this field"). 
+
+:-pred get_date_field(bevent::in,date::out) is det.
+get_date_field(prest(_,Dt,_,_),Dt).
+get_date_field(day(_,Dt),Dt).
+get_date_field(admit(Dt,_),Dt).
+get_date_field(discharge(Dt,_),Dt).
+get_date_field(transfer(Dt,_,_),Dt).
+get_date_field(wrong(Dt),Dt).
+
+:-pred get_code_field(bevent::in,code::out) is semidet.
+get_code_field(prest(_,_,Cd,_),Cd).
+
+main-->
+	print("hello world\n").
Index: tests/valid/constraint_proof_bug_lib.m
===================================================================
RCS file: constraint_proof_bug_lib.m
diff -N constraint_proof_bug_lib.m
--- /dev/null	Fri Jul 23 03:05:01 1999
+++ constraint_proof_bug_lib.m	Fri Jul 23 02:35:47 1999
@@ -0,0 +1,57 @@
+:-module constraint_proof_bug_lib.
+
+:-interface.
+:-type date.
+:-type code.
+:-type field(T1,T2)---> d(T1);c(T2).
+:-type dep_op==string.
+
+:-typeclass constrainable(T) 
+  where [
+	  pred apply_op(T::in,dep_op::in,T::in) is semidet
+	  ].
+:-instance constrainable(date). 
+:-instance constrainable(code). 
+:-instance constrainable(field(T,T2)).
+
+:-pred get_date_date(int::out,int::out,int::out,date::in) is det.
+
+:- implementation.
+
+:-type code==int.
+:-type date--->d(int).
+
+get_date_date(Y,M,D,_Date):-Y=1999,M=6,D=25 .
+
+:-instance constrainable(date) 
+  where [
+	  pred(apply_op/3) is apply_op_dates
+	    ].
+
+:-pred apply_op_dates(date::in,dep_op::in,date::in) is semidet.
+apply_op_dates(D1,"=",D2):-
+	get_date_date(Y1,M1,Day1,D1),
+	get_date_date(Y1,M1,Day1,D2).
+
+:-instance constrainable(code) 
+  where [
+	  pred(apply_op/3) is apply_op_codes
+	    ].
+
+:-pred apply_op_codes(code::in,dep_op::in,code::in) is semidet.
+apply_op_codes(D1,"=",D2):-compare((=),D1,D2).
+
+
+:-instance constrainable(field(T,T2)) <= (constrainable(T),constrainable(T2)) 
+  where [
+	  pred(apply_op/3) is apply_op_fields
+	    ].
+
+:-pred apply_op_fields(field(T,T2),dep_op,field(T,T2)) <= (constrainable(T),
+							   constrainable(T2)).
+:-mode apply_op_fields(in,in,in) is semidet.
+
+apply_op_fields(d(D1),Op,d(D2)):-apply_op(D1,Op,D2).
+apply_op_fields(c(D1),Op,c(D2)):-apply_op(D1,Op,D2).
+
+
-- 
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.
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------