[m-dev.] diff: catch typeclass constraints on compound types

[Fergus Henderson]

Estimated hours taken: 1

compiler/prog_io_typeclass.m:
	Detect the case of constraints on compound types,
	and report a "sorry, not implemented" error message
	for them.

tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/complicated_constraint.m:
	Add a test case for complicated constraints.
	This test case is not yet enabled, since we currently
	print out a `sorry, not implemented' message for it.

Workspace: /home/mercury0/fjh/mercury
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.11
diff -u -d -r1.11 prog_io_typeclass.m
--- prog_io_typeclass.m	1999/02/12 03:46:59	1.11
+++ prog_io_typeclass.m	1999/10/30 09:09:23
@@ -127,29 +127,9 @@
 :- mode parse_superclass_constraints(in, in, out) is det.
 
 parse_superclass_constraints(ModuleName, Constraints, Result) :-
-	parse_class_constraints(ModuleName, Constraints, ParsedConstraints),
-	(
-		ParsedConstraints = ok(ConstraintList),
-		(
-			NonVarArg = lambda([C::in, NonVar::out] is semidet, (
-				C = constraint(_, Types),
-				list__filter(
-					lambda([A::in] is semidet, 
-						\+ type_util__var(A, _)),
-					Types, [NonVar | _])
-			)),
-			list__filter_map(NonVarArg, ConstraintList, [E0|_Es])
-		->
-			term__coerce(E0, E),
-			Result = error("constraints on class declaration may only constrain type variables, not compound types", E)
-		;
-			Result = ParsedConstraints
-		)
-	;
-		ParsedConstraints = error(_, _),
-		Result = ParsedConstraints
-	).
-
+	parse_simple_class_constraints(ModuleName, Constraints, 
+		"constraints on class declaration may only constrain type variables, not compound types",
+		Result).
 
 :- pred parse_unconstrained_class(module_name, term, tvarset, maybe1(item)).
 :- mode parse_unconstrained_class(in, in, in, out) is det.
@@ -264,7 +244,48 @@
 
 %-----------------------------------------------------------------------------%
 
-parse_class_constraints(ModuleName, Constraints, ParsedConstraints) :-
+% Parse constraints on a pred or func declaration,
+% or on an existentially quantified type definition.
+
+parse_class_constraints(ModuleName, Constraints, Result) :-
+	parse_simple_class_constraints(ModuleName, Constraints, 
+		"sorry, not implemented: constraints may only constrain type variables, not compound types",
+		Result).
+
+% Parse constraints which can only constrain type variables
+
+:- pred parse_simple_class_constraints(module_name, term, string,
+		maybe1(list(class_constraint))).
+:- mode parse_simple_class_constraints(in, in, in, out) is det.
+
+parse_simple_class_constraints(ModuleName, Constraints, ErrorMessage,
+		Result) :-
+	parse_arbitrary_class_constraints(ModuleName, Constraints,
+		ParsedConstraints),
+	(
+		ParsedConstraints = ok(ConstraintList),
+		(
+			list__member(Constraint, ConstraintList),
+			Constraint = constraint(_, Types),
+			list__member(Type, Types),
+			\+ type_util__var(Type, _)
+		->
+			Result = error(ErrorMessage, Constraints)
+		;
+			Result = ParsedConstraints
+		)
+	;
+		ParsedConstraints = error(_, _),
+		Result = ParsedConstraints
+	).
+
+% Parse constraints which can constrain arbitrary types
+
+:- pred parse_arbitrary_class_constraints(module_name, term,
+		maybe1(list(class_constraint))).
+:- mode parse_arbitrary_class_constraints(in, in, out) is det.
+
+parse_arbitrary_class_constraints(ModuleName, Constraints, ParsedConstraints) :-
 	conjunction_to_list(Constraints, ConstraintList),
 	parse_class_constraint_list(ModuleName, ConstraintList, 
 		ParsedConstraints).
@@ -375,28 +396,9 @@
 :- mode parse_instance_constraints(in, in, out) is det.
 
 parse_instance_constraints(ModuleName, Constraints, Result) :-
-	parse_class_constraints(ModuleName, Constraints, ParsedConstraints),
-	(
-		ParsedConstraints = ok(ConstraintList),
-		(
-			NonVarArg = lambda([C::in, NonVar::out] is semidet, (
-				C = constraint(_, Types),
-				list__filter(
-					lambda([A::in] is semidet, 
-						\+ type_util__var(A, _)),
-					Types, [NonVar | _])
-			)),
-			list__filter_map(NonVarArg, ConstraintList, [E0|_Es])
-		->
-			term__coerce(E0, E),
-			Result = error("constraints on instance declaration may only constrain type variables, not compound types", E)
-		;
-			Result = ParsedConstraints
-		)
-	;
-		ParsedConstraints = error(_, _),
-		Result = ParsedConstraints
-	).
+	parse_simple_class_constraints(ModuleName, Constraints,
+		"constraints on instance declaration may only constrain type variables, not compound types",
+		Result).
 
 :- pred parse_underived_instance(module_name, term, tvarset, maybe1(item)).
 :- mode parse_underived_instance(in, in, in, out) is det.
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.22
diff -u -d -r1.22 Mmakefile
--- Mmakefile	1999/10/30 08:49:35	1.22
+++ Mmakefile	1999/10/30 09:16:47
@@ -36,6 +36,10 @@
 	typeclass_test_6 \
 	use_abstract_instance
 
+# The following tests are not enabled:
+#	complicated_constraint --
+#		because we don't support that feature yet
+
 # These tests are all failing in jump and fast grades b/c we can't use static
 # code initialisers.
 
cvs diff: tests/hard_coded/typeclasses/complicated_constraint.m is a new entry, no comparison available
:- module complicated_constraint.
:- interface.
:- import_module io.

:- typeclass printable(A) where [
	pred p(A::in, io__state::di, io__state::uo) is det
].
:- typeclass foo(A) <= printable(A) where [
	pred b(A::in) is semidet
].

:- instance printable(int).
:- instance foo(int).
:- instance printable(list(T)) <= foo(T).
:- instance foo(list(T)) <= foo(T).

:- pred main(io__state::di, io__state::uo) is det.

:- implementation.
:- import_module list, int.

:- instance printable(int) where [
	pred(p/3) is io__write_int
].

:- instance foo(int) where [
	pred(b/1) is foo_b
].
:- instance foo(list(T)) <= foo(T) where [
	pred(b/1) is list_b
].
:- instance printable(list(T)) <= foo(T) where [
	pred(p/3) is p_list
].

:- pred p_list(list(T), state, state) <= printable(T).
:- mode p_list(in, di, uo) is det.
p_list(Xs) --> list__foldl(p, Xs).

main -->
	p(42), 
	io__write_string("\n"),
	p_list([1,2,3]), 
	io__write_string("\n"),
	p([1,2,3]), 
	io__write_string("\n"),
	blah(101),
	io__write_string("\n").


:- pred list_b(list(T)::in) is semidet <= foo(T).
list_b(List) :-
	list__map((pred(A::in, A::out) is semidet :- b(A)), List, _).

:- pred foo_b(int::in) is semidet.
foo_b(1).

% This tests complicated constraints of the form `foo(bar(T))'.

:- pred blah(T, io__state, io__state) <= (foo(list(T)), printable(list(T))).
:- mode blah(in, di, uo) is det.

blah(X) -->
	(
		% This also tests the semidet class method call mechanism
		{ b([X, X]) }
	->
		io__write_string("true\n")
	;
		io__write_string("false\n")
	),

	p([X]).

-- 
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
--------------------------------------------------------------------------