[m-rev.] for review: functional dependencies

Mark Brown mark at cs.mu.OZ.AU
Wed Jun 7 22:23:21 AEST 2006


Hi,

This addresses the issue that Ian raised earlier this year.  Since we've
decided the change is a bugfix rather than a new feature, I'm planning
to include this on the release branch as well.

Cheers,
Mark.

Estimated hours taken: 12
Branches: main, release

Use functional dependencies on superclasses (in addition to the class itself)
to relax the restrictions on method constraints.

compiler/check_typeclass.m:
	Derive induced dependencies from the class_fundep_ancestors field,
	after renaming apart the ancestors and substituting parameters.

tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/fundeps_6.exp:
tests/hard_coded/typeclasses/fundeps_6.m:
tests/hard_coded/typeclasses/fundeps_7.exp:
tests/hard_coded/typeclasses/fundeps_7.m:
	New test cases.

Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.93
diff -u -r1.93 check_typeclass.m
--- compiler/check_typeclass.m	20 Apr 2006 05:36:49 -0000	1.93
+++ compiler/check_typeclass.m	7 Jun 2006 06:45:11 -0000
@@ -1437,10 +1437,11 @@
     module_info::out, bool::in, bool::out, io::di, io::uo) is det.
 
 check_pred_type_ambiguities(PredInfo, !ModuleInfo, !FoundError, !IO) :-
+    pred_info_get_typevarset(PredInfo, TVarSet),
     pred_info_get_arg_types(PredInfo, ArgTypes),
     pred_info_get_class_context(PredInfo, Constraints),
     prog_type.vars_list(ArgTypes, TVars),
-    get_unbound_tvars(TVars, Constraints, !.ModuleInfo, UnboundTVars),
+    get_unbound_tvars(TVarSet, TVars, Constraints, !.ModuleInfo, UnboundTVars),
     (
         UnboundTVars = []
     ;
@@ -1474,7 +1475,8 @@
     prog_type.vars_list(ArgTypes, ArgTVars),
     list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)),
         ArgTVars, ExistQArgTVars),
-    get_unbound_tvars(ExistQArgTVars, constraints([], Constraints),
+    get_type_defn_tvarset(TypeDefn, TVarSet),
+    get_unbound_tvars(TVarSet, ExistQArgTVars, constraints([], Constraints),
         !.ModuleInfo, UnboundTVars),
     (
         UnboundTVars = []
@@ -1486,12 +1488,12 @@
         module_info_incr_errors(!ModuleInfo)
     ).
 
-:- pred get_unbound_tvars(list(tvar)::in, prog_constraints::in,
+:- pred get_unbound_tvars(tvarset::in, list(tvar)::in, prog_constraints::in,
     module_info::in, list(tvar)::out) is det.
 
-get_unbound_tvars(TVars, Constraints, ModuleInfo, UnboundTVars) :-
+get_unbound_tvars(TVarSet, TVars, Constraints, ModuleInfo, UnboundTVars) :-
     module_info_get_class_table(ModuleInfo, ClassTable),
-    InducedFunDeps = induced_fundeps(ClassTable, Constraints),
+    InducedFunDeps = induced_fundeps(ClassTable, TVarSet, Constraints),
     FunDepsClosure = fundeps_closure(InducedFunDeps, list_to_set(TVars)),
     solutions.solutions(
         constrained_var_not_in_closure(Constraints, FunDepsClosure),
@@ -1518,16 +1520,53 @@
                 range       :: set(tvar)
             ).
 
-:- func induced_fundeps(class_table, prog_constraints) = induced_fundeps.
+:- func induced_fundeps(class_table, tvarset, prog_constraints)
+    = induced_fundeps.
+
+induced_fundeps(ClassTable, TVarSet, constraints(UnivCs, ExistCs))
+    = foldl(induced_fundeps_2(ClassTable, TVarSet), UnivCs,
+        foldl(induced_fundeps_2(ClassTable, TVarSet), ExistCs, [])).
+
+:- func induced_fundeps_2(class_table, tvarset, prog_constraint,
+    induced_fundeps) = induced_fundeps.
 
-induced_fundeps(ClassTable, constraints(UnivCs, ExistCs))
-    = foldl(induced_fundeps_2(ClassTable), UnivCs,
-        foldl(induced_fundeps_2(ClassTable), ExistCs, [])).
+induced_fundeps_2(ClassTable, TVarSet, Constraint, FunDeps0) = FunDeps :-
+    Constraint = constraint(Name, Args),
+    Arity = length(Args),
+    ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)),
+    % The ancestors includes all superclasses of Constraint which have
+    % functional dependencies on them (possibly including Constraint itself).
+    ClassAncestors = ClassDefn ^ class_fundep_ancestors,
+    (
+        % Optimize the common case.
+        ClassAncestors = [],
+        FunDeps = FunDeps0
+    ;
+        ClassAncestors = [_ | _],
+        ClassTVarSet = ClassDefn ^ class_tvarset,
+        ClassParams = ClassDefn ^ class_vars,
+
+        % We can ignore the resulting tvarset, since any new variables
+        % will become bound when the arguments are bound. (This follows
+        % from the fact that constraints on class declarations can only use
+        % variables that appear in the head of the declaration.)
+
+        tvarset_merge_renaming(TVarSet, ClassTVarSet, _, Renaming),
+        apply_variable_renaming_to_prog_constraint_list(Renaming,
+            ClassAncestors, RenamedAncestors),
+        apply_variable_renaming_to_tvar_list(Renaming, ClassParams,
+            RenamedParams),
+        map.from_corresponding_lists(RenamedParams, Args, Subst),
+        apply_subst_to_prog_constraint_list(Subst, RenamedAncestors,
+            Ancestors),
+        FunDeps = foldl(induced_fundeps_3(ClassTable), Ancestors, FunDeps0)
+    ).
 
-:- func induced_fundeps_2(class_table, prog_constraint, induced_fundeps)
+:- func induced_fundeps_3(class_table, prog_constraint, induced_fundeps)
     = induced_fundeps.
 
-induced_fundeps_2(ClassTable, constraint(Name, Args), FunDeps0) = FunDeps :-
+induced_fundeps_3(ClassTable, Constraint, FunDeps0) = FunDeps :-
+    Constraint = constraint(Name, Args),
     Arity = length(Args),
     ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)),
     FunDeps = foldl(induced_fundep(Args), ClassDefn ^ class_fundeps, FunDeps0).
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.56
diff -u -r1.56 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile	31 May 2006 16:00:40 -0000	1.56
+++ tests/hard_coded/typeclasses/Mmakefile	7 Jun 2006 04:20:47 -0000
@@ -25,6 +25,8 @@
 	fundeps_3 \
 	fundeps_4 \
 	fundeps_5 \
+	fundeps_6 \
+	fundeps_7 \
 	ground_constraint \
 	ground_constraint_2 \
 	ho_map \
Index: tests/hard_coded/typeclasses/fundeps_6.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_6.exp
diff -N tests/hard_coded/typeclasses/fundeps_6.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_6.exp	7 Jun 2006 04:14:27 -0000
@@ -0,0 +1 @@
+no
Index: tests/hard_coded/typeclasses/fundeps_6.m
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_6.m
diff -N tests/hard_coded/typeclasses/fundeps_6.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_6.m	7 Jun 2006 04:18:22 -0000
@@ -0,0 +1,37 @@
+:- module fundeps_6.
+:- interface.
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- typeclass a(A, X) <= (A -> X) where [
+].
+
+:- typeclass b(B, X) <= a(B, X) where [
+	% X is determined by the functional dependency on a/2, which we
+	% should inherit.
+	func b(B) = int
+].
+
+:- instance a(int, int) where [
+].
+
+:- instance b(int, int) where [
+	(b(N) = N)
+].
+
+	% X is determined by the functional dependency on a/2, which
+	% should be inherited by b/2.
+	%
+:- type foo ---> some [B, X] foo(B) => b(B, X).
+
+main(!IO)  :-
+	(
+		b(1) = b(2)
+	->
+		write_string("yes\n", !IO)
+	;
+		write_string("no\n", !IO)
+	).
+
Index: tests/hard_coded/typeclasses/fundeps_7.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_7.exp
diff -N tests/hard_coded/typeclasses/fundeps_7.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_7.exp	7 Jun 2006 04:20:33 -0000
@@ -0,0 +1 @@
+no
Index: tests/hard_coded/typeclasses/fundeps_7.m
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_7.m
diff -N tests/hard_coded/typeclasses/fundeps_7.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_7.m	7 Jun 2006 04:22:10 -0000
@@ -0,0 +1,37 @@
+:- module fundeps_7.
+:- interface.
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- typeclass a(X, A) <= (A -> X) where [
+].
+
+:- typeclass b(B, X) <= a(X, B) where [
+	% X is determined by the functional dependency on a/2, which we
+	% should inherit.
+	func b(B) = int
+].
+
+:- instance a(int, int) where [
+].
+
+:- instance b(int, int) where [
+	(b(N) = N)
+].
+
+	% X is determined by the functional dependency on a/2, which
+	% should be inherited by b/2.
+	%
+:- type foo ---> some [B, X] foo(B) => b(B, X).
+
+main(!IO)  :-
+	(
+		b(1) = b(2)
+	->
+		write_string("yes\n", !IO)
+	;
+		write_string("no\n", !IO)
+	).
+
--------------------------------------------------------------------------
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