[m-rev.] for review: allow arbitrary types in class constraints
David Overton
dmo at cs.mu.OZ.AU
Fri Apr 12 12:51:22 AEST 2002
Hi,
This change would probably be best reviewed by Fergus or DJ, but since
I'm not sure whether either of them is able to do it at the moment, if
anyone else wants to that would be great.
David
Estimated hours taken: 25
Branches: main
Allow constraints on pred/func, instance and typeclass declarations to
constraint arbitrary types rather than just type variables. The only
restriction is that each constraint must contain at least one type
variable and that all type variables in the constraint must also occur
somewhere else in the declaration.
compiler/prog_io_typeclass.m:
When parsing class constraints (on pred/func, instance and
typeclass declarations) remove the restriction that the
arguments must all be variables. Instead, ensure that at least
one argument contains at least one variable.
compiler/hlds_data.m:
compiler/hlds_out.m:
compiler/make_hlds.m:
Allow superclass constraints to have arguments of arbitrary type
(rather than just variables) in the superclass table.
compiler/polymorphism.m:
compiler/typecheck.m:
Put in some checks to ensure that we don't get into an infinite
loop when processing mutually constrained intances, e.g.
:- instance c(f(T)) <= d(g(T)).
:- instance d(g(T)) <= c(f(T)).
doc/reference_manual.texi:
Document the change.
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/arbitrary_constraint_class.exp:
tests/hard_coded/typeclasses/arbitrary_constraint_class.m:
tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.exp:
tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.m:
tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.exp:
tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.m:
tests/hard_coded/typeclasses/recursive_instance_1.exp:
tests/hard_coded/typeclasses/recursive_instance_1.m:
tests/hard_coded/typeclasses/recursive_instance_2.exp:
tests/hard_coded/typeclasses/recursive_instance_2.m:
tests/invalid/Mmakefile:
tests/invalid/typeclass_constraint_extra_var.err_exp:
tests/invalid/typeclass_constraint_extra_var.m:
tests/invalid/typeclass_constraint_no_var.err_exp:
tests/invalid/typeclass_constraint_no_var.m:
Add some test cases.
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.68
diff -u -r1.68 hlds_data.m
--- compiler/hlds_data.m 20 Mar 2002 12:36:16 -0000 1.68
+++ compiler/hlds_data.m 12 Apr 2002 02:30:15 -0000
@@ -985,7 +985,8 @@
:- type subclass_details
---> subclass_details(
- list(tvar), % variables of the superclass
+ list(type), % arguments of the
+ % superclass constraint
class_id, % name of the subclass
list(tvar), % variables of the subclass
tvarset % the names of these vars
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.282
diff -u -r1.282 hlds_out.m
--- compiler/hlds_out.m 28 Mar 2002 03:43:01 -0000 1.282
+++ compiler/hlds_out.m 12 Apr 2002 02:30:15 -0000
@@ -3080,7 +3080,7 @@
{ SuperClassId = class_id(SuperSymName, _SuperArity) },
prog_out__write_sym_name(SuperSymName),
io__write_char('('),
- io__write_list(SuperClassVars, ", ", PrintVar),
+ io__write_list(SuperClassVars, ", ", term_io__write_term(VarSet)),
io__write_char(')').
%-----------------------------------------------------------------------------%
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.408
diff -u -r1.408 make_hlds.m
--- compiler/make_hlds.m 7 Apr 2002 10:22:34 -0000 1.408
+++ compiler/make_hlds.m 12 Apr 2002 02:30:15 -0000
@@ -2454,11 +2454,10 @@
SuperTypes),
list__length(SuperTypes,
SuperClassArity),
- term__vars_list(SuperTypes, SuperVars),
SuperClassId = class_id(SuperName,
SuperClassArity),
SubClassDetails =
- subclass_details(SuperVars,
+ subclass_details(SuperTypes,
ClassId, Vars, VarSet),
multi_map__set(Ss0, SuperClassId,
SubClassDetails, Ss)
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.221
diff -u -r1.221 polymorphism.m
--- compiler/polymorphism.m 28 Mar 2002 03:43:31 -0000 1.221
+++ compiler/polymorphism.m 12 Apr 2002 02:30:15 -0000
@@ -2107,9 +2107,11 @@
ExtraVars0 = [],
ExtraGoals0 = [],
+ SeenInstances = [],
+
% do the work
polymorphism__make_typeclass_info_vars_2(PredClassContext,
- ExistQVars, Context,
+ SeenInstances, ExistQVars, Context,
ExtraVars0, ExtraVars1,
ExtraGoals0, ExtraGoals1,
Info0, Info),
@@ -2121,38 +2123,39 @@
% Accumulator version of the above.
:- pred polymorphism__make_typeclass_info_vars_2(
list(class_constraint),
+ list(class_constraint),
existq_tvars, prog_context,
list(prog_var), list(prog_var),
list(hlds_goal), list(hlds_goal),
poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_vars_2(in, in, in,
+:- mode polymorphism__make_typeclass_info_vars_2(in, in, in, in,
in, out, in, out, in, out) is det.
-polymorphism__make_typeclass_info_vars_2([], _ExistQVars,
+polymorphism__make_typeclass_info_vars_2([], _Seen, _ExistQVars,
_Context, ExtraVars, ExtraVars,
ExtraGoals, ExtraGoals,
Info, Info).
-polymorphism__make_typeclass_info_vars_2([C|Cs], ExistQVars,
+polymorphism__make_typeclass_info_vars_2([C|Cs], Seen, ExistQVars,
Context, ExtraVars0, ExtraVars,
ExtraGoals0, ExtraGoals,
Info0, Info) :-
- polymorphism__make_typeclass_info_var(C, ExistQVars,
+ polymorphism__make_typeclass_info_var(C, [C | Seen], ExistQVars,
Context, ExtraGoals0, ExtraGoals1,
Info0, Info1, MaybeExtraVar),
maybe_insert_var(MaybeExtraVar, ExtraVars0, ExtraVars1),
- polymorphism__make_typeclass_info_vars_2(Cs,
+ polymorphism__make_typeclass_info_vars_2(Cs, Seen,
ExistQVars, Context,
ExtraVars1, ExtraVars,
ExtraGoals1, ExtraGoals,
Info1, Info).
:- pred polymorphism__make_typeclass_info_var(class_constraint,
- existq_tvars, prog_context, list(hlds_goal), list(hlds_goal),
- poly_info, poly_info, maybe(prog_var)).
-:- mode polymorphism__make_typeclass_info_var(in, in, in, in, out,
+ list(class_constraint), existq_tvars, prog_context, list(hlds_goal),
+ list(hlds_goal), poly_info, poly_info, maybe(prog_var)).
+:- mode polymorphism__make_typeclass_info_var(in, in, in, in, in, out,
in, out, out) is det.
-polymorphism__make_typeclass_info_var(Constraint, ExistQVars,
+polymorphism__make_typeclass_info_var(Constraint, Seen, ExistQVars,
Context, ExtraGoals0, ExtraGoals,
Info0, Info, MaybeVar) :-
(
@@ -2175,9 +2178,9 @@
map__search(Info0^proof_map, Constraint, Proof)
->
- polymorphism__make_typeclass_info_from_proof(Constraint, Proof,
- ExistQVars, Context, MaybeVar, ExtraGoals0, ExtraGoals,
- Info0, Info)
+ polymorphism__make_typeclass_info_from_proof(Constraint, Seen,
+ Proof, ExistQVars, Context, MaybeVar, ExtraGoals0,
+ ExtraGoals, Info0, Info)
;
polymorphism__make_typeclass_info_head_var(Constraint,
NewVar, Info0, Info1),
@@ -2189,13 +2192,15 @@
).
:- pred polymorphism__make_typeclass_info_from_proof(class_constraint,
- constraint_proof, existq_tvars, prog_context, maybe(prog_var),
- list(hlds_goal), list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_from_proof(in, in, in, in, out,
+ list(class_constraint), constraint_proof, existq_tvars, prog_context,
+ maybe(prog_var), list(hlds_goal), list(hlds_goal), poly_info,
+ poly_info).
+:- mode polymorphism__make_typeclass_info_from_proof(in, in, in, in, in, out,
in, out, in, out) is det.
-polymorphism__make_typeclass_info_from_proof(Constraint, Proof, ExistQVars,
- Context, MaybeVar, ExtraGoals0, ExtraGoals, Info0, Info) :-
+polymorphism__make_typeclass_info_from_proof(Constraint, Seen, Proof,
+ ExistQVars, Context, MaybeVar, ExtraGoals0, ExtraGoals,
+ Info0, Info) :-
Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
Constraint = constraint(ClassName, ConstrainedTypes),
@@ -2239,7 +2244,9 @@
apply_subst_to_constraint_list(RenameSubst,
InstanceConstraints0, InstanceConstraints1),
apply_rec_subst_to_constraint_list(InstanceSubst,
- InstanceConstraints1, InstanceConstraints),
+ InstanceConstraints1, InstanceConstraints2),
+ InstanceConstraints =
+ InstanceConstraints2 `list__delete_elems` Seen,
apply_subst_to_constraint_proofs(RenameSubst,
SuperClassProofs0, SuperClassProofs1),
apply_rec_subst_to_constraint_proofs(InstanceSubst,
@@ -2268,7 +2275,7 @@
% constraints from the context of the
% instance decl.
polymorphism__make_typeclass_info_vars_2(
- InstanceConstraints,
+ InstanceConstraints, Seen,
ExistQVars, Context,
[], InstanceExtraTypeClassInfoVars0,
ExtraGoals0, ExtraGoals1,
@@ -2335,7 +2342,7 @@
% Make the typeclass_info for the subclass
polymorphism__make_typeclass_info_var(
- SubClassConstraint,
+ SubClassConstraint, Seen,
ExistQVars, Context,
ExtraGoals0, ExtraGoals1,
Info1, Info2,
@@ -2585,7 +2592,7 @@
polymorphism__make_superclasses_from_proofs(Cs,
ExistQVars, Goals0, Goals1, Info0, Info1, Vars0, Vars1),
term__context_init(Context),
- polymorphism__make_typeclass_info_var(C,
+ polymorphism__make_typeclass_info_var(C, [],
ExistQVars, Context, Goals1, Goals, Info1, Info,
MaybeVar),
maybe_insert_var(MaybeVar, Vars1, Vars).
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.24
diff -u -r1.24 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 20 Mar 2002 12:37:14 -0000 1.24
+++ compiler/prog_io_typeclass.m 12 Apr 2002 02:30:15 -0000
@@ -155,9 +155,7 @@
:- mode parse_superclass_constraints(in, in, out) is det.
parse_superclass_constraints(ModuleName, Constraints, Result) :-
- parse_simple_class_constraints(ModuleName, Constraints,
- "constraints on class declaration may only constrain type variables, not compound types",
- Result).
+ parse_class_constraints(ModuleName, Constraints, Result).
:- pred parse_unconstrained_class(module_name, term, tvarset, maybe1(item)).
:- mode parse_unconstrained_class(in, in, in, out) is det.
@@ -277,55 +275,6 @@
extract_class_constraints(Result0, Result).
parse_class_and_inst_constraints(ModuleName, ConstraintsTerm, Result) :-
- parse_simple_class_and_inst_constraints(ModuleName, ConstraintsTerm,
- "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, ConstraintsTerm, ErrorMessage,
- Result) :-
- parse_simple_class_and_inst_constraints(ModuleName, ConstraintsTerm,
- ErrorMessage, Result0),
- extract_class_constraints(Result0, Result).
-
-:- pred parse_simple_class_and_inst_constraints(module_name, term, string,
- maybe_class_and_inst_constraints).
-:- mode parse_simple_class_and_inst_constraints(in, in, in, out) is det.
-
-parse_simple_class_and_inst_constraints(ModuleName, ConstraintsTerm,
- ErrorMessage, Result) :-
- parse_arbitrary_class_and_inst_constraints(ModuleName, ConstraintsTerm,
- Result0),
- (
- Result0 = ok(ConstraintList, _),
- (
- list__member(Constraint, ConstraintList),
- Constraint = constraint(_, Types),
- list__member(Type, Types),
- \+ type_util__var(Type, _)
- ->
- Result = error(ErrorMessage, ConstraintsTerm)
- ;
- Result = Result0
- )
- ;
- Result0 = error(_, _),
- Result = Result0
- ).
-
-% Parse constraints which can constrain arbitrary types
-
-:- pred parse_arbitrary_class_and_inst_constraints(module_name, term,
- maybe_class_and_inst_constraints).
-:- mode parse_arbitrary_class_and_inst_constraints(in, in, out) is det.
-
-parse_arbitrary_class_and_inst_constraints(ModuleName, ConstraintsTerm,
- Result) :-
conjunction_to_list(ConstraintsTerm, ConstraintList),
parse_class_and_inst_constraint_list(ModuleName, ConstraintList,
Result).
@@ -376,7 +325,15 @@
% constraints do not contain any info in their prog_context
% fields
list__map(convert_type, Args0, Args),
- Result = ok(class_constraint(constraint(ClassName, Args)))
+
+ % Check that the arguments contain at least one type variable.
+ ( term__contains_var_list(Args, _) ->
+ Result = ok(class_constraint(constraint(ClassName,
+ Args)))
+ ;
+ Result = error("class constraint contains no variables",
+ ConstraintTerm)
+ )
;
Result = error("expected atom as class name or inst constraint",
ConstraintTerm)
@@ -464,9 +421,7 @@
:- mode parse_instance_constraints(in, in, out) is det.
parse_instance_constraints(ModuleName, Constraints, Result) :-
- parse_simple_class_constraints(ModuleName, Constraints,
- "constraints on instance declaration may only constrain type variables, not compound types",
- Result).
+ parse_class_constraints(ModuleName, Constraints, Result).
:- pred parse_underived_instance(module_name, term, tvarset, maybe1(item)).
:- mode parse_underived_instance(in, in, in, out) is det.
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.317
diff -u -r1.317 typecheck.m
--- compiler/typecheck.m 7 Apr 2002 10:22:51 -0000 1.317
+++ compiler/typecheck.m 12 Apr 2002 02:30:16 -0000
@@ -4038,12 +4038,31 @@
typecheck__reduce_context_by_rule_application(InstanceTable, SuperClassTable,
AssumedConstraints, Bindings, Tvarset0, Tvarset,
Proofs0, Proofs, Constraints0, Constraints) :-
+ typecheck__reduce_context_by_rule_application_2(InstanceTable,
+ SuperClassTable, AssumedConstraints, Bindings, Tvarset0,
+ Tvarset, Proofs0, Proofs, Constraints0, Constraints,
+ Constraints0, _).
+
+:- pred typecheck__reduce_context_by_rule_application_2(instance_table,
+ superclass_table, list(class_constraint), tsubst, tvarset, tvarset,
+ map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof),
+ list(class_constraint), list(class_constraint),
+ list(class_constraint), list(class_constraint)).
+:- mode typecheck__reduce_context_by_rule_application_2(in, in, in, in,
+ in, out, in, out, in, out, in, out) is det.
+
+typecheck__reduce_context_by_rule_application_2(InstanceTable,
+ SuperClassTable, AssumedConstraints, Bindings, Tvarset0,
+ Tvarset, Proofs0, Proofs, Constraints0, Constraints, Seen0,
+ Seen) :-
apply_rec_subst_to_constraint_list(Bindings, Constraints0,
Constraints1),
eliminate_assumed_constraints(Constraints1, AssumedConstraints,
Constraints2, Changed1),
apply_instance_rules(Constraints2, InstanceTable,
- Tvarset0, Tvarset1, Proofs0, Proofs1, Constraints3, Changed2),
+ Tvarset0, Tvarset1, Proofs0, Proofs1, Seen0, Seen1,
+ Constraints3, Changed2),
varset__vars(Tvarset1, Tvars),
apply_class_rules(Constraints3, AssumedConstraints, Tvars,
SuperClassTable, Tvarset0, Proofs1, Proofs2, Constraints4,
@@ -4054,12 +4073,13 @@
% We have reached fixpoint
list__sort_and_remove_dups(Constraints4, Constraints),
Tvarset = Tvarset1,
- Proofs = Proofs2
+ Proofs = Proofs2,
+ Seen = Seen1
;
- typecheck__reduce_context_by_rule_application(InstanceTable,
+ typecheck__reduce_context_by_rule_application_2(InstanceTable,
SuperClassTable, AssumedConstraints,
Bindings, Tvarset1, Tvarset, Proofs2, Proofs,
- Constraints4, Constraints)
+ Constraints4, Constraints, Seen1, Seen)
).
:- pred eliminate_assumed_constraints(list(class_constraint),
@@ -4081,34 +4101,42 @@
:- pred apply_instance_rules(list(class_constraint), instance_table,
tvarset, tvarset, map(class_constraint, constraint_proof),
- map(class_constraint, constraint_proof), list(class_constraint), bool).
-:- mode apply_instance_rules(in, in, in, out, in, out, out, out) is det.
+ map(class_constraint, constraint_proof), list(class_constraint),
+ list(class_constraint), list(class_constraint), bool).
+:- mode apply_instance_rules(in, in, in, out, in, out, in, out, out, out)
+ is det.
-apply_instance_rules([], _, Names, Names, Proofs, Proofs, [], no).
+apply_instance_rules([], _, Names, Names, Proofs, Proofs, Seen, Seen, [], no).
apply_instance_rules([C|Cs], InstanceTable, TVarSet, NewTVarSet,
- Proofs0, Proofs, Constraints, Changed) :-
+ Proofs0, Proofs, Seen0, Seen, Constraints, Changed) :-
C = constraint(ClassName, Types),
list__length(Types, Arity),
map__lookup(InstanceTable, class_id(ClassName, Arity), Instances),
(
find_matching_instance_rule(Instances, ClassName, Types,
TVarSet, NewTVarSet0, Proofs0, Proofs1,
- NewConstraints0)
+ NewConstraints0),
+
+ % Remove any constraints we've already seen.
+ % This ensures we don't get into an infinite loop.
+ NewConstraints1 = NewConstraints0 `list__delete_elems` Seen0
->
% Put the new constraints at the front of the list
- NewConstraints = NewConstraints0,
+ NewConstraints = NewConstraints1,
NewTVarSet1 = NewTVarSet0,
Proofs2 = Proofs1,
+ Seen1 = NewConstraints ++ Seen0,
Changed1 = yes
;
% Put the old constraint at the front of the list
NewConstraints = [C],
NewTVarSet1 = TVarSet,
Proofs2 = Proofs0,
+ Seen1 = Seen0,
Changed1 = no
),
apply_instance_rules(Cs, InstanceTable, NewTVarSet1,
- NewTVarSet, Proofs2, Proofs, TheRest, Changed2),
+ NewTVarSet, Proofs2, Proofs, Seen1, Seen, TheRest, Changed2),
bool__or(Changed1, Changed2, Changed),
list__append(NewConstraints, TheRest, Constraints).
@@ -4246,8 +4274,7 @@
term__var_list_to_term_list(SubVars0, SubVars1),
term__apply_substitution_to_list(SubVars1,
RenameSubst, SubVars),
- term__var_list_to_term_list(SuperVars0, SuperVars1),
- term__apply_substitution_to_list(SuperVars1,
+ term__apply_substitution_to_list(SuperVars0,
RenameSubst, SuperVars),
% Work out what the (renamed) vars from the
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.246
diff -u -r1.246 reference_manual.texi
--- doc/reference_manual.texi 16 Mar 2002 05:37:03 -0000 1.246
+++ doc/reference_manual.texi 12 Apr 2002 02:30:18 -0000
@@ -4264,12 +4264,16 @@
A type class constraint is of the form:
@example
- <= @var{Typeclass}(@var{TypeVariable}, @dots{}), @dots{}
+ <= @var{Typeclass}(@var{Type}, @dots{}), @dots{}
@end example
@noindent
-where @var{Typeclass} is the name of a type class and @var{TypeVariable} is
-a type variable that appears in the predicate's or function's type signature.
+where @var{Typeclass} is the name of a type class and @var{Type} is
+a type.
+Any variable that appears in @var{Type} must also appear in
+the predicate's or function's type signature.
+Each type class constraint in a predicate or function declaration must contain
+at least one variable.
For example
@@ -4296,7 +4300,8 @@
Type class constraints may also appear in @code{typeclass} declarations,
meaning that one type class is a ``superclass'' of another.
-The variables that appear as arguments to the type classes in the constraints
+The variables that appear in the arguments to the type classes in the
+constraints
must also be arguments to the type class in question.
For example, the following declares the @samp{ring} type class, which describes
@@ -4335,7 +4340,8 @@
@section Type class constraints on instance declarations
Typeclass constraints may also be placed upon instance declarations. The
-variables that appear as arguments to the type classes in the constraints must
+variables that appear in the arguments to the type classes in the
+constraints must
all be type variables that appear in the types in the instance declarations.
For example, consider the following declaration of a type class of types that
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.44
diff -u -r1.44 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 12 Feb 2001 05:14:57 -0000 1.44
+++ tests/hard_coded/typeclasses/Mmakefile 12 Apr 2002 02:30:18 -0000
@@ -8,6 +8,9 @@
#-----------------------------------------------------------------------------#
PROGS= \
+ arbitrary_constraint_class \
+ arbitrary_constraint_pred_2 \
+ arbitrary_constraint_pred_1 \
constrained_lambda \
extract_typeinfo \
exist_disjunction \
@@ -42,6 +45,8 @@
nondet_class_method \
operator_classname \
record_syntax \
+ recursive_instance_1 \
+ recursive_instance_2 \
reordered_existential_constraint \
superclass_bug \
superclass_bug2 \
Index: tests/hard_coded/typeclasses/arbitrary_constraint_class.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/arbitrary_constraint_class.exp
diff -N tests/hard_coded/typeclasses/arbitrary_constraint_class.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/arbitrary_constraint_class.exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1 @@
+0.00000000000000
Index: tests/hard_coded/typeclasses/arbitrary_constraint_class.m
===================================================================
RCS file: tests/hard_coded/typeclasses/arbitrary_constraint_class.m
diff -N tests/hard_coded/typeclasses/arbitrary_constraint_class.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/arbitrary_constraint_class.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,37 @@
+:- module arbitrary_constraint_class.
+:- interface.
+
+:- import_module float, string, io.
+
+:- typeclass solver_for(B, S) where [
+ func coerce(B) = S
+].
+
+:- typeclass solver_for_float(U) <= solver_for(float, U) where [].
+
+:- instance solver_for(float, string) where [
+ coerce(Float) = string__float_to_string(Float)
+].
+
+:- instance solver_for_float(string) where [].
+
+:- pred mg(T, T) <= solver_for_float(T).
+:- mode mg(in, out) is det.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+mg(S0, S) :-
+ ( semidet_succeed ->
+ S = coerce(0.0)
+ ;
+ S = S0
+ ).
+
+
+main -->
+ { mg("1.0", S) },
+ io__write_string(S),
+ io__nl.
Index: tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.exp
diff -N tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1 @@
+0.00000000000000
Index: tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.m
===================================================================
RCS file: tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.m
diff -N tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/arbitrary_constraint_pred_1.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,33 @@
+:- module arbitrary_constraint_pred_1.
+:- interface.
+
+:- import_module float, string, io.
+
+:- typeclass solver_for(B, S) where [
+ func coerce(B) = S
+].
+
+:- instance solver_for(float, string) where [
+ coerce(Float) = string__float_to_string(Float)
+].
+
+:- pred mg(T, T) <= solver_for(float, T).
+:- mode mg(in, out) is det.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+mg(S0, S) :-
+ ( semidet_succeed ->
+ S = coerce(0.0)
+ ;
+ S = S0
+ ).
+
+
+main -->
+ { mg("1.0", S) },
+ io__write_string(S),
+ io__nl.
Index: tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.exp
diff -N tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1 @@
+42.0000000000000
Index: tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.m
===================================================================
RCS file: tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.m
diff -N tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/arbitrary_constraint_pred_2.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,34 @@
+:- module arbitrary_constraint_pred_2.
+:- interface.
+
+:- import_module float, io.
+:- import_module list.
+
+:- typeclass solver_for(B, S) where [
+ func coerce(B) = S
+].
+
+:- instance solver_for(list(T), float) where [
+ coerce(_) = 42.0
+].
+
+:- pred mg(T, T) <= solver_for(list(T), T).
+:- mode mg(in, out) is det.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+mg(S0, S) :-
+ ( semidet_succeed ->
+ S = coerce([S0])
+ ;
+ S = S0
+ ).
+
+
+main -->
+ { mg(1.0, S) },
+ io__print(S),
+ io__nl.
Index: tests/hard_coded/typeclasses/recursive_instance_1.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/recursive_instance_1.exp
diff -N tests/hard_coded/typeclasses/recursive_instance_1.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/recursive_instance_1.exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1 @@
+[0, 1, 2]
Index: tests/hard_coded/typeclasses/recursive_instance_1.m
===================================================================
RCS file: tests/hard_coded/typeclasses/recursive_instance_1.m
diff -N tests/hard_coded/typeclasses/recursive_instance_1.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/recursive_instance_1.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,23 @@
+:- module recursive_instance_1.
+:- interface.
+
+:- import_module int, io.
+:- import_module list.
+
+:- typeclass foo(T) where [
+ func bar(T) = T
+].
+
+:- instance foo(list(T)) <= foo(list(T)) where [
+ bar(Xs) = Xs
+].
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+main -->
+ { X = bar([0,1,2]) },
+ io__print(X),
+ io__nl.
Index: tests/hard_coded/typeclasses/recursive_instance_2.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/recursive_instance_2.exp
diff -N tests/hard_coded/typeclasses/recursive_instance_2.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/recursive_instance_2.exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1 @@
+[0, 1, 2]
Index: tests/hard_coded/typeclasses/recursive_instance_2.m
===================================================================
RCS file: tests/hard_coded/typeclasses/recursive_instance_2.m
diff -N tests/hard_coded/typeclasses/recursive_instance_2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/recursive_instance_2.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,26 @@
+:- module recursive_instance_2.
+:- interface.
+
+:- import_module int, io.
+:- import_module list, std_util.
+
+:- typeclass foo(T) where [
+ func bar(T) = T
+].
+:- typeclass baz(T) where [].
+
+:- instance foo(list(T)) <= baz(maybe(T)) where [
+ bar(Xs) = Xs
+].
+
+:- instance baz(maybe(T)) <= foo(list(T)) where [].
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+main -->
+ { X = bar([0,1,2]) },
+ io__print(X),
+ io__nl.
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.108
diff -u -r1.108 Mmakefile
--- tests/invalid/Mmakefile 25 Mar 2002 21:13:29 -0000 1.108
+++ tests/invalid/Mmakefile 12 Apr 2002 02:30:18 -0000
@@ -103,6 +103,8 @@
type_mismatch.m \
type_vars.m \
typeclass_bogus_method.m \
+ typeclass_constraint_extra_var.m \
+ typeclass_constraint_no_var.m \
typeclass_mode.m \
typeclass_missing_det.m \
typeclass_missing_det_2.m \
Index: tests/invalid/typeclass_constraint_extra_var.err_exp
===================================================================
RCS file: tests/invalid/typeclass_constraint_extra_var.err_exp
diff -N tests/invalid/typeclass_constraint_extra_var.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/typeclass_constraint_extra_var.err_exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,8 @@
+typeclass_constraint_extra_var.m:015: In declaration for predicate `typeclass_constraint_extra_var:mg/2':
+typeclass_constraint_extra_var.m:015: error in type class constraints: type variable
+typeclass_constraint_extra_var.m:015: `U' occurs only in the constraints,
+typeclass_constraint_extra_var.m:015: not in the predicate's argument types.
+typeclass_constraint_extra_var.m:025: In clause for predicate `typeclass_constraint_extra_var:mg/2':
+typeclass_constraint_extra_var.m:025: unsatisfiable typeclass constraint(s):
+typeclass_constraint_extra_var.m:025: `typeclass_constraint_extra_var:solver_for((list:list(T)), T)'.
+For more information, try recompiling with `-E'.
Index: tests/invalid/typeclass_constraint_extra_var.m
===================================================================
RCS file: tests/invalid/typeclass_constraint_extra_var.m
diff -N tests/invalid/typeclass_constraint_extra_var.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/typeclass_constraint_extra_var.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,34 @@
+:- module typeclass_constraint_extra_var.
+:- interface.
+
+:- import_module float, io.
+:- import_module list.
+
+:- typeclass solver_for(B, S) where [
+ func coerce(B) = S
+].
+
+:- instance solver_for(list(T), float) where [
+ coerce(_) = 42.0
+].
+
+:- pred mg(T, T) <= solver_for(list(U), T).
+:- mode mg(in, out) is det.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+mg(S0, S) :-
+ ( semidet_succeed ->
+ S = coerce([S0])
+ ;
+ S = S0
+ ).
+
+
+main -->
+ { mg(1.0, S) },
+ io__print(S),
+ io__nl.
Index: tests/invalid/typeclass_constraint_no_var.err_exp
===================================================================
RCS file: tests/invalid/typeclass_constraint_no_var.err_exp
diff -N tests/invalid/typeclass_constraint_no_var.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/typeclass_constraint_no_var.err_exp 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,5 @@
+typeclass_constraint_no_var.m:015: Error: class constraint contains no variables: solver_for(list(float), float).
+typeclass_constraint_no_var.m:016: Error: mode declaration for predicate `typeclass_constraint_no_var:mg/2'
+typeclass_constraint_no_var.m:016: without preceding `pred' declaration.
+typeclass_constraint_no_var.m:016: Inferred :- pred mg(T1, T1).
+For more information, try recompiling with `-E'.
Index: tests/invalid/typeclass_constraint_no_var.m
===================================================================
RCS file: tests/invalid/typeclass_constraint_no_var.m
diff -N tests/invalid/typeclass_constraint_no_var.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/typeclass_constraint_no_var.m 12 Apr 2002 02:30:18 -0000
@@ -0,0 +1,34 @@
+:- module typeclass_constraint_no_var.
+:- interface.
+
+:- import_module float, io.
+:- import_module list.
+
+:- typeclass solver_for(B, S) where [
+ func coerce(B) = S
+].
+
+:- instance solver_for(list(T), float) where [
+ coerce(_) = 42.0
+].
+
+:- pred mg(T, T) <= solver_for(list(float), float).
+:- mode mg(in, out) is det.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module std_util.
+
+mg(S0, S) :-
+ ( semidet_succeed ->
+ S = S0
+ ;
+ S = S0
+ ).
+
+
+main -->
+ { mg(1.0, S) },
+ io__print(S),
+ io__nl.
--
David Overton Computer Science and Software Engineering
PhD Student The University of Melbourne +61 3 8344 9159
Research Fellow Monash University (Clayton) +61 3 9905 5779
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list