[m-rev.] for prelim review: check instance declaration compatibility

[Peter Ross]

Hi,

This code still needs to boot check, and for a test case to be
added to the test suite, but I am submitting it for prelim review
now, as I don't have time to do the rest today.


===================================================================


Estimated hours taken: 1
Branches: main

The following code causes code to be generated which seg-faults

 :- interface
 :- instance tc(list(T)).
 :- implementation.
 :- instance tc(list(T)) <= tc(T) where [...].

because the exported instance declaration doesn't contain the
typeclass constraint.

compiler/add_class.m:
	Check that for all the "same" instance declarations
	the instance constraints are exactly the same on each
	declaration.


Index: compiler/add_class.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_class.m,v
retrieving revision 1.26
diff -u -r1.26 add_class.m
--- compiler/add_class.m	19 Jan 2007 07:04:07 -0000	1.26
+++ compiler/add_class.m	18 May 2007 05:27:42 -0000
@@ -461,8 +461,11 @@
         NewInstanceDefn = hlds_instance_defn(InstanceModuleName, Status,
             Context, Constraints, Types, Body, no, VarSet, Empty),
         map.lookup(Instances0, ClassId, InstanceDefns),
+
         check_for_overlapping_instances(NewInstanceDefn, InstanceDefns,
             ClassId, !Specs),
+        check_instance_constraints(NewInstanceDefn, InstanceDefns, !Specs),
+
         map.det_update(Instances0, ClassId,
             [NewInstanceDefn | InstanceDefns], Instances),
         module_info_set_instance_table(Instances, !ModuleInfo)
@@ -508,6 +511,88 @@
     Msg2 = error_msg(yes(OtherContext), yes, 0, [always(Pieces2)]),
     Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg1, Msg2]),
     !:Specs = [Spec | !.Specs].
+
+
+:- pred check_instance_constraints(hlds_instance_defn::in,
+    list(hlds_instance_defn)::in,
+    list(error_spec)::in, list(error_spec)::out) is det.
+
+check_instance_constraints(InstanceDefn, InstanceDefns, !Specs) :-
+    list.filter_map(
+        (pred(ID::in, {ID, R}::out) is semidet :-
+            same_type_hlds_instance_defn(InstanceDefn, ID, R)
+        ), InstanceDefns, EquivInstanceDefns),
+    list.foldl(check_instance_constraint(InstanceDefn),
+        EquivInstanceDefns, !Specs).
+
+:- pred check_instance_constraint(hlds_instance_defn::in,
+    {hlds_instance_defn, tvar_renaming}::in,
+    list(error_spec)::in, list(error_spec)::out) is det.
+
+check_instance_constraint(InstanceDefnA, {InstanceDefnB, Renaming}, !Specs) :-
+    ConstraintsA = InstanceDefnA ^ instance_constraints,
+    ConstraintsB = InstanceDefnB ^ instance_constraints,
+    ( same_prog_constraint_list(Renaming, ConstraintsA, ConstraintsB) ->
+        true
+    ;
+        ContextA = InstanceDefnA ^ instance_context, 
+        TxtA = always([string_to_words_piece("instance constraints incompatible")]),
+        MsgA = simple_msg(ContextA, [TxtA]),
+
+        ContextB = InstanceDefnB ^ instance_context,
+        TxtB = always([string_to_words_piece("with instance constraints here.")]),
+        MsgB = simple_msg(ContextB, [TxtB]),
+
+        Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [MsgA, MsgB]),
+        !:Specs = [Spec | !.Specs]
+    ).
+
+    %
+    % Do two hlds_instance_defn refer to the same type?
+    % eg "instance tc(f(T))" compares equal to "instance tc(f(U))"
+    % 
+    % Note we don't check that the constraits of the declarations are the
+    % same.
+    %
+:- pred same_type_hlds_instance_defn(hlds_instance_defn::in,
+    hlds_instance_defn::in, tvar_renaming::out) is semidet.
+
+same_type_hlds_instance_defn(InstanceDefnA, InstanceDefnB, Renaming) :-
+    TypesA = InstanceDefnA ^ instance_types,
+    TypesB = InstanceDefnB ^ instance_types,
+
+    VarSetA = InstanceDefnA ^ instance_tvarset,
+    VarSetB = InstanceDefnB ^ instance_tvarset,
+
+    tvarset_merge_renaming(VarSetA, VarSetB, _NewVarSet, Renaming),
+    apply_variable_renaming_to_type_list(Renaming, TypesB, NewTypesB),
+    type_list_subsumes(TypesA, NewTypesB, _).
+    
+    % same_prog_constraint_list(R, CsA, CsB)
+    %
+    % checks that the constraints list, CsB, is exactly the same
+    % as the list, CsA, after the type variables in CsB have
+    % been renamed using R.
+    %
+    % Note by the same we also mean the constraints are listed
+    % in the same order.
+    %
+:- pred same_prog_constraint_list(tvar_renaming::in,
+    list(prog_constraint)::in, list(prog_constraint)::in) is semidet.
+
+same_prog_constraint_list(_, [], []).
+same_prog_constraint_list(RenamingForB,
+        [ConstraintA | ConstraintsA], [ConstraintB | ConstraintsB]) :-
+    apply_variable_renaming_to_prog_constraint(RenamingForB,
+        ConstraintB, NewConstraintB),
+    same_constraint(ConstraintA, NewConstraintB),
+    same_prog_constraint_list(RenamingForB, ConstraintsA, ConstraintsB).
+
+:- pred same_constraint(prog_constraint::in, prog_constraint::in) is semidet.
+
+same_constraint(constraint(NameA, TypesA), constraint(NameB, TypesB)) :-
+    NameA = NameB,
+    type_list_subsumes(TypesA, TypesB, _).
 
 do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc, PredArity,
         ArgTypes, Markers, Context, Status, ClausesInfo, !ModuleInfo,

--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------