for review: rewrite of check_typeclass.m

David Glen JEFFERY dgj at cs.mu.OZ.AU
Wed May 20 22:23:17 AEST 1998


Hi,

Can you please review this, Fergus?

----------------------------------------------------------------------------

Estimated hours taken: 25

A re-work on check_typeclass.m. Now, rather than the ad-hoc approach of 
checking each method of each instance declaration for *exact* type and mode
correctness, we generate a new predicate that gets inserted into the HLDS.
This predicate is checked for type, mode, uniqueness and determinism 
correctness in the appropriate compiler passes.

As a consequence, the check_typeclass pass now has to come before typecheck.m.
Previously, it was the final semantic analysis pass because it had to use
type, mode, uniqueness and determinism information. The new approach does not
need that information to be available.

This has the following user-visible improvements:
	- constraints on class methods are now checked properly. An
	  instance's implementation of a method may be less constrained.
	  (Previously, these constraints weren't even checked at all. Oops).
	- a method implementation may be more polymorphic than expected
	- implied modes will be used for methods if necessary
	- some of the error messages will be more friendly (seeing that they
	  won't be generated by check_typeclass.m ;-) )

This is a much more robust approach (and it co-incides with the typeclass 
paper ;-) ).

TODO: (I will do these in the next change):
	- fix the error messages in check_typeclass.m
	- Make typechecking, mode, uniqueness and determinism give a special
	  error message if they notice that the pred they just found an
	  error in has a name of the form that the check_typeclass mangler
	  uses.
	- Propagate the term__context of the instance decl through everything
	  so that the error message can be improved even more.

compiler/check_typeclass.m:
	Introduce the auxiliary predicate for the instance method. As an
	optimisation, do not introduce the predicate if the implementation
	given is an *exact* match (in terms of types, modes and determinism).
compiler/mercury_compile.m:
	Put the check_typeclass pass before typechecking.
compiler/type_util.m:
	Change type_list_matches_exactly to
	type_and_constraint_list_matches_exactly since check_typeclass is
	also responsible for checking constraints on method implementations.
	(This is only used in the optimisation mentioned above).

Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/check_typeclass.m,v
retrieving revision 1.6
diff -u -t -r1.6 check_typeclass.m
--- check_typeclass.m	1998/05/07 06:40:35	1.6
+++ check_typeclass.m	1998/05/20 11:40:55
@@ -5,9 +5,40 @@
 %---------------------------------------------------------------------------%
 %
 % This module checks conformance of instance declarations to the typeclass
-% declaration. (ie. it checks that for every method of the class, the
-% types in the instance are correct, and that there is a mode of the instance
-% method that matches the typeclass method mode _exactly_).
+% declaration. 
+% 
+% It does so by, for every method of every instance, generating a new pred
+% whose types and modes are as expected by the typeclass declaration and
+% whose body just calls the implementation provided by the instance 
+% declaration.
+%
+% eg. given the declarations:
+%
+% :- typeclass c(T) where [
+%       pred m(T::in, T::out) is semidet
+% ].
+%
+% :- instance c(int) where [
+%       pred(m/2) is my_m
+% ].
+%
+% The correctness of my_m/2 as an implementation of m/2 is checked by 
+% generating the new predicate:
+%       
+% :- pred 'implementation of m/2'(int::in, int::out) is semidet.
+%
+% 'implementation of m/2'(HeadVar_1, HeadVar_2) :-
+%       my_m(HeadVar_1, HeadVar_2).
+%
+% By generating the new pred, we check the instance method for type, mode,
+% determinism and uniqueness correctness since the generated pred is checked
+% in each of those passes too.
+%
+% In addition, this pass checks that all superclass constraints are satisfied
+% by the instance declaration.
+%
+% This pass fills in the super class proofs and instance method pred/proc ids
+% in the instance table of the HLDS.
 %
 % Author: dgj.
 %
@@ -16,8 +47,6 @@
 :- module check_typeclass.
 
 
-        % XXX what about constraints on class methods?
-        
 :- interface.
 
 :- import_module hlds_module, bool, io.
@@ -30,25 +59,26 @@
 
 :- import_module map, list, std_util, hlds_pred, hlds_data, prog_data, require.
 :- import_module type_util, assoc_list, mode_util, inst_match, hlds_module.
-:- import_module term, varset, typecheck, int.
+:- import_module term, varset, typecheck, int, globals, make_hlds. 
+:- import_module base_typeclass_info, string, hlds_goal, set.
 
 check_typeclass__check_instance_decls(ModuleInfo0, ModuleInfo, FoundError, 
                 IO0, IO) :-
         module_info_classes(ModuleInfo0, ClassTable),
         module_info_instances(ModuleInfo0, InstanceTable0),
         map__to_assoc_list(InstanceTable0, InstanceList0),
-        list__map_foldl(check_one_class(ClassTable, ModuleInfo0), InstanceList0,
-                InstanceList, [], Errors),
+        list__map_foldl(check_one_class(ClassTable), InstanceList0,
+                InstanceList, [] - ModuleInfo0, Errors - ModuleInfo1),
         (
                 Errors = []
         ->
                 map__from_assoc_list(InstanceList, InstanceTable),
-                module_info_set_instances(ModuleInfo0, InstanceTable,
+                module_info_set_instances(ModuleInfo1, InstanceTable,
                         ModuleInfo),
                 IO = IO0,
                 FoundError = no
         ;
-                ModuleInfo = ModuleInfo0,
+                ModuleInfo = ModuleInfo1,
                 list__reverse(Errors, ErrorList),
                 io__write_list(ErrorList, "\n", io__write_string, IO0, IO1),
                 io__write_string("\n", IO1, IO2),
@@ -57,13 +87,15 @@
         ).  
                 
         % check all the instances of one class.
-:- pred check_one_class(class_table, module_info, 
+:- pred check_one_class(class_table,
         pair(class_id, list(hlds_instance_defn)), 
-        pair(class_id, list(hlds_instance_defn)), list(string), list(string)).
-:- mode check_one_class(in, in, in, out, in, out) is det.
+        pair(class_id, list(hlds_instance_defn)), 
+        pair(list(string), module_info), 
+        pair(list(string), module_info)).
+:- mode check_one_class(in, in, out, in, out) is det.
 
-check_one_class(ClassTable, ModuleInfo, ClassId - InstanceDefns0, 
-        ClassId - InstanceDefns, Errors0, Errors) :-
+check_one_class(ClassTable, ClassId - InstanceDefns0, 
+        ClassId - InstanceDefns, ModuleInfo0, ModuleInfo) :-
 
         map__lookup(ClassTable, ClassId, ClassDefn),
         ClassDefn = hlds_class_defn(SuperClasses, ClassVars, ClassInterface,
@@ -75,53 +107,88 @@
                                 ClassProc = hlds_class_proc(PredId, _)
                         )),
                 PredIds),
-        list__map_foldl(check_class_instance(SuperClasses, ClassVars,
-                                ClassInterface, ClassVarSet, ModuleInfo,
+        list__map_foldl(check_class_instance(ClassId, SuperClasses, ClassVars,
+                                ClassInterface, ClassVarSet,
                                 PredIds),
-                InstanceDefns0, InstanceDefns, Errors0, Errors).
+                InstanceDefns0, InstanceDefns, 
+                ModuleInfo0, ModuleInfo).
 
 
         % check one instance of one class
-:- pred check_class_instance(list(class_constraint), list(var),
-        hlds_class_interface, varset, module_info, list(pred_id), 
-        hlds_instance_defn, hlds_instance_defn, list(string), list(string)).
+:- pred check_class_instance(class_id, list(class_constraint), list(var),
+        hlds_class_interface, varset, list(pred_id), 
+        hlds_instance_defn, hlds_instance_defn, 
+        pair(list(string), module_info), 
+        pair(list(string), module_info)).
 :- mode check_class_instance(in, in, in, in, in, in, in, out, in, out) is det.
 
-check_class_instance(SuperClasses, Vars, ClassInterface, ClassVarSet,
-                ModuleInfo, PredIds, InstanceDefn0, InstanceDefn, 
-                Errors0, Errors):-
+check_class_instance(ClassId, SuperClasses, Vars, ClassInterface, ClassVarSet,
+                PredIds, InstanceDefn0, InstanceDefn, 
+                ModuleInfo0, ModuleInfo):-
                 
                 % check conformance of the instance interface
         (
                 PredIds \= []
         ->
-                list__foldl2(check_instance_pred(Vars, ClassInterface,
-                        ModuleInfo), PredIds, InstanceDefn0, InstanceDefn1,
-                        Errors0, Errors1)
+                list__foldl2(
+                        check_instance_pred(ClassId, Vars, ClassInterface), 
+                        PredIds, InstanceDefn0, InstanceDefn1,
+                        ModuleInfo0, ModuleInfo1)
         ;
                 % there are no methods for this class
                 InstanceDefn0 = hlds_instance_defn(A, B, C, D, 
                                 _MaybeInstancePredProcs, F, G),
                 InstanceDefn1 = hlds_instance_defn(A, B, C, D, 
                                 yes([]), F, G),
-                Errors1 = Errors0
+                ModuleInfo1 = ModuleInfo0
         ),
 
 
                 % check that the superclass constraints are satisfied for the
                 % types in this instance declaration
         check_superclass_conformance(SuperClasses, Vars, ClassVarSet,
-                ModuleInfo, InstanceDefn1, InstanceDefn, Errors1, Errors).
+                InstanceDefn1, InstanceDefn, ModuleInfo1, ModuleInfo).
 
+%----------------------------------------------------------------------------%
+
+        % This structure holds the information about a particular instance
+        % method
+:- type instance_method_info ---> instance_method_info(
+                module_info,
+                sym_name,                               % Name that the
+                                                        % introduced pred
+                                                        % should be given.
+                arity,                                  % Arity of the method.
+                list(type),                             % Expected types of
+                                                        % arguments.
+                list(class_constraint),                 % Constraints from
+                                                        % class method.
+                list(pair(list(mode), determinism)),    % Modes and 
+                                                        % determinisms of the
+                                                        % required procs.
+                list(string),                           % Error messages
+                                                        % that have been
+                                                        % generated.
+                tvarset,                
+                import_status,                          % Import status of
+                                                        % instance decl.
+                pred_or_func,                           % Is method pred or
+                                                        % func?
+                term__context                           % Context of instance
+                                                        % decl.
+        ).
+
+%----------------------------------------------------------------------------%
 
         % check one pred in one instance of one class
-:- pred check_instance_pred(list(var), hlds_class_interface, module_info,
+:- pred check_instance_pred(class_id, list(var), hlds_class_interface, 
         pred_id, hlds_instance_defn, hlds_instance_defn,
-        list(string), list(string)).
-:- mode check_instance_pred(in, in, in, in, in, out, in, out) is det.
+        pair(list(string), module_info), pair(list(string), module_info)).
+:- mode check_instance_pred(in,in, in, in, in, out, in, out) is det.
 
-check_instance_pred(ClassVars, ClassInterface, ModuleInfo, PredId,
-                InstanceDefn0, InstanceDefn, Errors0, Errors):-
+check_instance_pred(ClassId, ClassVars, ClassInterface, PredId,
+                InstanceDefn0, InstanceDefn, 
+                Errors0 - ModuleInfo0, Errors - ModuleInfo):-
         solutions(
                 lambda([ProcId::out] is nondet, 
                         (
@@ -129,11 +196,20 @@
                                 ClassProc = hlds_class_proc(PredId, ProcId)
                         )),
                 ProcIds),
-        module_info_pred_info(ModuleInfo, PredId, PredInfo),
-        pred_info_arg_types(PredInfo, _ArgTypeVars, ArgTypes),
-        pred_info_name(PredInfo, PredName0),
+        module_info_pred_info(ModuleInfo0, PredId, PredInfo),
+        pred_info_arg_types(PredInfo, ArgTypeVars, ArgTypes),
+        pred_info_get_class_context(PredInfo, ClassContext0),
+        (
+                ClassContext0 = [_|Tail]
+        ->
+                ClassContext = Tail
+        ;
+                error("check_instance_pred: no constraint on class method")
+        ),
+
+        pred_info_name(PredInfo, MethodName0),
         pred_info_module(PredInfo, PredModule),
-        PredName = qualified(PredModule, PredName0),
+        MethodName = qualified(PredModule, MethodName0),
         pred_info_arity(PredInfo, PredArity),
         pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
         pred_info_procedures(PredInfo, ProcTable),
@@ -148,23 +224,44 @@
                         )),
                 ProcIds, 
                 ArgModes),
-        check_instance_pred_procs(ModuleInfo, PredOrFunc, PredName, PredArity,
-                ArgTypes, ArgModes, ClassVars, InstanceDefn0, InstanceDefn,
-                Errors0, Errors).
-
-:- pred check_instance_pred_procs(module_info, pred_or_func, sym_name, arity,
-        list(type), list(pair(list(mode), determinism)), list(var),
-        hlds_instance_defn, hlds_instance_defn, list(string), list(string)).
-:- mode check_instance_pred_procs(in, in, in, in, in, in, in, in, out, 
-        in, out) is det.
-
-check_instance_pred_procs(ModuleInfo, PredOrFunc, PredName, PredArity,
-                ArgTypes0, ArgModes, ClassVars, InstanceDefn0, InstanceDefn, 
-                Errors0, Errors) :-
-        InstanceDefn0 = hlds_instance_defn(A, B, InstanceTypes,
-                                InstanceInterface, MaybeInstancePredProcs, 
-                                E, F),
-        get_matching_instance_names(InstanceInterface, PredOrFunc, PredName,
+        
+                % XXX The correct context should be added to the
+                % XXX hlds_instance_defn
+        term__context_init(Context),
+
+        InstanceDefn0 = hlds_instance_defn(Status, _, InstanceTypes, 
+                _, _, _, _),
+
+                % Work out what the name of the predicate that we generate
+                % to check this instance method should be.
+        make_introduced_pred_name(ClassId, MethodName, PredArity, 
+                InstanceTypes, PredName),
+        
+        Info0 = instance_method_info(ModuleInfo0, PredName, PredArity, 
+                ArgTypes, ClassContext, ArgModes, Errors0, ArgTypeVars,
+                Status, PredOrFunc, Context),
+
+        check_instance_pred_procs(ClassVars, MethodName,
+                InstanceDefn0, InstanceDefn, Info0, Info),
+
+        Info = instance_method_info(ModuleInfo, _PredName, _PredArity, 
+                _ArgTypes, _ClassContext, _ArgModes, Errors, _ArgTypeVars,
+                _Status, _PredOrFunc, _Context).
+
+:- pred check_instance_pred_procs(list(var), sym_name,
+        hlds_instance_defn, hlds_instance_defn, 
+        instance_method_info, instance_method_info).
+:- mode check_instance_pred_procs(in, in, in, out, in, out) is det.
+
+check_instance_pred_procs(ClassVars, MethodName, InstanceDefn0, InstanceDefn, 
+                Info0, Info) :-
+        InstanceDefn0 = hlds_instance_defn(A, InstanceConstraints,
+                                InstanceTypes, InstanceInterface,
+                                MaybeInstancePredProcs, E, F),
+        Info0 = instance_method_info(ModuleInfo, PredName, PredArity, 
+                ArgTypes, ClassContext, ArgModes, Errors0, ArgTypeVars,
+                Status, PredOrFunc, Context),
+        get_matching_instance_names(InstanceInterface, PredOrFunc, MethodName,
                 PredArity, InstanceNames),
         (
                 InstanceNames = [InstancePredName]
@@ -174,10 +271,10 @@
                                 InstancePredName, PredOrFunc, PredArity,
                                 InstancePredIds)
                 ->
-                        handle_instance_method_overloading(ModuleInfo,
-                                ClassVars, InstanceTypes, ArgTypes0, ArgModes,
-                                InstancePredIds, Errors0, Errors,
-                                InstancePredId, InstanceProcIds),
+                        handle_instance_method_overloading(ClassVars, 
+                                InstanceTypes, InstanceConstraints, 
+                                InstancePredName, InstancePredIds,
+                                InstancePredId, InstanceProcIds, Info0, Info),
 
                         MakeClassProc = 
                                 lambda([TheProcId::in, PredProcId::out] is det,
@@ -197,13 +294,18 @@
                                 MaybeInstancePredProcs = no,
                                 InstancePredProcs = InstancePredProcs1
                         ),
-                        InstanceDefn = hlds_instance_defn(A, B, InstanceTypes,
+                        InstanceDefn = hlds_instance_defn(A,
+                                        InstanceConstraints, InstanceTypes,
                                         InstanceInterface,
                                         yes(InstancePredProcs), E, F)
                 ;
                         InstanceDefn = InstanceDefn0,
                                 % XXX make a better error message
-                        Errors = ["instance method not found"|Errors0]
+                        Errors = ["instance method not found"|Errors0],
+                        Info = instance_method_info(ModuleInfo, PredName,
+                                PredArity, ArgTypes, ClassContext, ArgModes,
+                                Errors, ArgTypeVars, Status, PredOrFunc,
+                                Context)
                 )
         ;
                 InstanceNames = [_,_|_]
@@ -211,12 +313,18 @@
                         % one kind of error
                         % XXX make a better error message
                 InstanceDefn = InstanceDefn0,
-                Errors = ["multiply defined class method"|Errors0]
+                Errors = ["multiply defined class method"|Errors0],
+                Info = instance_method_info(ModuleInfo, PredName, PredArity,
+                        ArgTypes, ClassContext, ArgModes, Errors, ArgTypeVars,
+                        Status, PredOrFunc, Context)
         ;
                          % another kind of error
                          % XXX make a better error message
                 InstanceDefn = InstanceDefn0,
-                Errors = ["undefined class method"|Errors0]
+                Errors = ["undefined class method"|Errors0],
+                Info = instance_method_info(ModuleInfo, PredName, PredArity,
+                        ArgTypes, ClassContext, ArgModes, Errors, ArgTypeVars,
+                        Status, PredOrFunc, Context)
         ).
 
 :- pred get_matching_instance_names(list(instance_method), pred_or_func,
@@ -265,33 +373,53 @@
         predicate_table_search_pf_sym_arity(PredicateTable,
                 PredOrFunc, InstancePredName, PredArity, InstancePredIds).
 
-:- pred handle_instance_method_overloading(module_info, list(var), list(type),
-        list(type), list(pair(list(mode), determinism)), list(pred_id), 
-        list(string), list(string), pred_id, list(proc_id)).
-:- mode handle_instance_method_overloading(in, in, in, in, in, in, in, 
-        out, out, out) is det.
-
-handle_instance_method_overloading(ModuleInfo, ClassVars, InstanceTypes,
-                ArgTypes0, ArgModes, InstancePredIds, Errors0, Errors,
-                InstancePredId, InstanceProcIds) :-
+        % Just a bit simpler than using a pair of pairs
+:- type triple(T1, T2, T3) ---> triple(T1, T2, T3).
+
+:- pred handle_instance_method_overloading(list(var), 
+        list(type), list(class_constraint), sym_name, list(pred_id), 
+        pred_id, list(proc_id), instance_method_info, instance_method_info).
+:- mode handle_instance_method_overloading(in, in, in, in, in, out, out, 
+        in, out) is det.
+
+handle_instance_method_overloading(ClassVars, 
+                InstanceTypes, InstanceConstraints, InstancePredName,
+                InstancePredIds, InstancePredId, InstanceProcIds, 
+                Info0, Info) :-
+
+        Info0 = instance_method_info(ModuleInfo, PredName, PredArity, 
+                ArgTypes0, ClassContext0, ArgModes, Errors0, ArgTypeVars,
+                Status, PredOrFunc, Context),
+
         module_info_get_predicate_table(ModuleInfo, PredicateTable),
         predicate_table_get_preds(PredicateTable, PredTable),
+
+        map__from_corresponding_lists(ClassVars,
+                InstanceTypes, TypeSubst),
+        term__apply_substitution_to_list(ArgTypes0,
+                TypeSubst, ArgTypes),
+
+                % Add the constraints from the instance declaration to the 
+                % constraints from the class method. This allows an instance
+                % method to have constraints on it which are part of the
+                % instance declaration as a whole.
+        apply_subst_to_constraints(TypeSubst, ClassContext0, ClassContext1),
+        list__append(InstanceConstraints, ClassContext1, ClassContext),
+
+        Info1 = instance_method_info(ModuleInfo, PredName, PredArity, 
+                ArgTypes, ClassContext, ArgModes, Errors0, ArgTypeVars,
+                Status, PredOrFunc, Context),
+
         (
                         % There is a single matching pred_id.
                         % No overloading
 
                 InstancePredIds = [InstancePredId0]
         ->
-                InstancePredId = InstancePredId0,
-                map__lookup(PredTable, InstancePredId,
-                        InstancePredInfo), 
-                map__from_corresponding_lists(ClassVars,
-                        InstanceTypes, TypeSubst),
-                term__apply_substitution_to_list(ArgTypes0,
-                        TypeSubst, ArgTypes),
-                check_instance_types_and_modes(ModuleInfo,
-                        InstancePredInfo, ArgTypes, ArgModes,
-                        Errors0, Errors, InstanceProcIds)
+                map__lookup(PredTable, InstancePredId0, InstancePredInfo), 
+                check_instance_types_and_modes(InstancePredName,
+                        InstancePredInfo, InstancePredId0, InstancePredId,
+                        InstanceProcIds, Info1, Info)
         ;
 
                 % Now we have a list of potential pred_ids for
@@ -300,17 +428,13 @@
                 % to see if it is type and mode correct.
 
                 Resolve = lambda(
-                        [PredId::in, Procs::out] is semidet,
+                        [PredId0::in, Procs::out] is semidet,
                         (
-                        map__lookup(PredTable, PredId, InstancePredInfo), 
-                        map__from_corresponding_lists(ClassVars, InstanceTypes,
-                                TypeSubst),
-                        term__apply_substitution_to_list(ArgTypes0, TypeSubst,
-                                ArgTypes),
-                        check_instance_types_and_modes(ModuleInfo,
-                                InstancePredInfo, ArgTypes, ArgModes, [], [],
-                                Procs0),
-                        Procs = PredId - Procs0
+                        map__lookup(PredTable, PredId0, InstancePredInfo), 
+                        check_instance_types_and_modes(
+                                InstancePredName, InstancePredInfo, 
+                                PredId0, PredId, Procs0, Info1, NewInfo),
+                        Procs = triple(PredId, Procs0, NewInfo)
                         )),
                 list__filter_map(Resolve, InstancePredIds,
                         Matches),
@@ -322,13 +446,16 @@
                                 % XXX improve error message
                         NewError = 
             "no type/mode-correct match for overloaded instance method name",
-                        Errors = [NewError|Errors0]
+                        Errors = [NewError|Errors0],
+                        Info = instance_method_info(ModuleInfo, PredName,
+                                PredArity, ArgTypes, ClassContext, ArgModes,
+                                Errors, ArgTypeVars, Status, PredOrFunc,
+                                Context)
                 ;
                                 % There is a single matching
                                 % pred_id. 
-                        Matches = [InstancePredId - 
-                                        InstanceProcIds],
-                        Errors  = Errors0
+                        Matches = [triple(InstancePredId,InstanceProcIds,
+                                Info)]
                 ;
                                 % unresolved overloading
                         Matches = [_,_|_],
@@ -336,55 +463,121 @@
                         InstanceProcIds = [],
                                 % XXX improve error message
                         NewError = "ambiguous overloading in instance method",
-                        Errors = [NewError|Errors0]
+                        Errors = [NewError|Errors0],
+                        Info = instance_method_info(ModuleInfo, PredName,
+                                PredArity, ArgTypes, ClassContext, ArgModes,
+                                Errors, ArgTypeVars, Status, PredOrFunc,
+                                Context)
                 )
         ).
 
-:- pred check_instance_types_and_modes(module_info, pred_info, list(type),
-        list(pair(list(mode), determinism)), list(string), list(string),
-        list(proc_id)).
-:- mode check_instance_types_and_modes(in, in, in, in, in, out, out) is det.
-
-check_instance_types_and_modes(ModuleInfo, InstancePredInfo, ArgTypes, ArgModes,
-                Errors0, Errors, InstanceProcIds) :-
+:- pred check_instance_types_and_modes(sym_name, pred_info, pred_id, pred_id, 
+        list(proc_id), instance_method_info, instance_method_info).
+:- mode check_instance_types_and_modes(in, in, in, out, out, in, out) is det.
+
+check_instance_types_and_modes(InstancePredName, InstancePredInfo, 
+                PredId0, PredId, InstanceProcIds, Info0, Info) :-
+        Info0 = instance_method_info(ModuleInfo0, PredName, PredArity, ArgTypes,
+                ClassContext, ArgModes, Errors, ArgTypeVars, Status,
+                PredOrFunc, Context),
         pred_info_arg_types(InstancePredInfo, _, InstanceArgTypes),
+        pred_info_get_class_context(InstancePredInfo, InstanceClassContext),
         (
-                type_list_matches_exactly(InstanceArgTypes, ArgTypes)
-        ->
+                        % As an optimisation, if the types and constraints
+                        % are _exactly_ the same, there is no point introducing
+                        % a predicate to call the instance method
+
+                type_and_constraint_list_matches_exactly(
+                        InstanceArgTypes, InstanceClassContext,
+                        ArgTypes, ClassContext),
                 pred_info_procedures(InstancePredInfo, InstanceProcedures0),
                 map__to_assoc_list(InstanceProcedures0, InstanceProcedures),
-                list__map_foldl(
-                        check_instance_modes(ModuleInfo, InstanceProcedures), 
-                        ArgModes, InstanceProcIds, Errors0, Errors)
-        ;
-                        % XXX fix the error message
-                Errors = ["types don't match"|Errors0],
-                InstanceProcIds = []
-        ).
-
-:- pred check_instance_modes(module_info, assoc_list(proc_id, proc_info),
-        pair(list(mode), determinism), proc_id, list(string), list(string)).
-:- mode check_instance_modes(in, in, in, out, in, out) is det.
-
-check_instance_modes(ModuleInfo, Procedures, ArgModes, ProcId, 
-                Errors0, Errors) :-
-        (
-                find_first_matching_proc(ModuleInfo, Procedures, ArgModes,
-                        ProcId0)
+                list__map(
+                        check_instance_modes(ModuleInfo0, InstanceProcedures), 
+                        ArgModes, InstanceProcIds0)
         ->
-                ProcId = ProcId0,
-                Errors = Errors0
+                Info = Info0,
+                PredId = PredId0,
+                InstanceProcIds = InstanceProcIds0
         ;
-                        % XXX Fix the error message
-                Errors = ["no such mode with correct detism for pred/func"|Errors0],
-                invalid_proc_id(ProcId)
+                        % Introduce a new predicate which calls the
+                        % implementation given in the instance declaration.
+                        % This allows the type to be more polymorphic than
+                        % expected etc.
+                module_info_name(ModuleInfo0, ModuleName),
+
+                Cond = true,
+                map__init(Proofs),
+                init_markers(Markers),
+
+                        % We have to add the actual clause after we have
+                        % added the procs because we need a list of proc 
+                        % numbers for which the clauses holds.
+                DummyClause = [],
+                varset__init(VarSet0),
+                make_n_fresh_vars("HeadVar__", PredArity, VarSet0, HeadVars,
+                        VarSet), 
+                map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
+                DummyClausesInfo = clauses_info(VarSet, VarTypes, VarTypes,
+                        HeadVars, DummyClause),
+
+
+                pred_info_init(ModuleName, PredName, PredArity, ArgTypeVars, 
+                        ArgTypes, Cond, Context, DummyClausesInfo, Status,
+                        Markers, none, PredOrFunc, ClassContext, Proofs,
+                        PredInfo0),
+
+                module_info_globals(ModuleInfo0, Globals),
+                globals__get_args_method(Globals, ArgsMethod),
+
+                        % Add procs with the expected modes and determinisms
+                AddProc = lambda([ModeAndDet::in, NewProcId::out,
+                                OldPredInfo::in, NewPredInfo::out] is det,
+                (
+                        ModeAndDet = Modes - Det,
+                        add_new_proc(OldPredInfo, PredArity, Modes, yes(Modes),
+                                no, yes(Det), Context, ArgsMethod,
+                                NewPredInfo, NewProcId)
+                )),
+                list__map_foldl(AddProc, ArgModes, InstanceProcIds, 
+                        PredInfo0, PredInfo1),
+
+                        % Add the body of the introduced pred
+
+                        % First the goal info
+                goal_info_init(GoalInfo0),
+                goal_info_set_context(GoalInfo0, Context, GoalInfo1),
+                set__list_to_set(HeadVars, NonLocals),
+                goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo),
+
+                        % Then the goal itself
+                invalid_pred_id(InvalidPredId),
+                invalid_proc_id(InvalidProcId),
+                Call = call(InvalidPredId, InvalidProcId, HeadVars, 
+                        not_builtin, no, InstancePredName),
+                IntroducedGoal = Call - GoalInfo,
+                IntroducedClause = clause(InstanceProcIds, IntroducedGoal, 
+                        Context),
+                ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes,
+                        HeadVars, [IntroducedClause]),
+                pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo),
+
+                module_info_get_predicate_table(ModuleInfo0, PredicateTable0),
+                predicate_table_insert(PredicateTable0, PredInfo,
+                        may_be_unqualified, PredId, PredicateTable),
+                module_info_set_predicate_table(ModuleInfo0, PredicateTable,
+                        ModuleInfo),
+
+                Info = instance_method_info(ModuleInfo, PredName, PredArity,
+                        ArgTypes, ClassContext, ArgModes, Errors, ArgTypeVars,
+                        Status, PredOrFunc, Context)
         ).
 
-:- pred find_first_matching_proc(module_info, assoc_list(proc_id, proc_info),
+:- pred check_instance_modes(module_info, assoc_list(proc_id, proc_info),
         pair(list(mode), determinism), proc_id).
-:- mode find_first_matching_proc(in, in, in, out) is semidet.
+:- mode check_instance_modes(in, in, in, out) is semidet.
 
-find_first_matching_proc(ModuleInfo, [ProcId - ProcInfo|Ps], ArgModes - Detism,
+check_instance_modes(ModuleInfo, [ProcId - ProcInfo|Ps], ArgModes - Detism,
                 TheProcId) :-
         proc_info_argmodes(ProcInfo, ProcArgModes),
                 % If there was a decl. for the proc, then use that determinism,
@@ -396,7 +589,7 @@
         ->
                 TheProcId = ProcId
         ;
-                find_first_matching_proc(ModuleInfo, Ps, ArgModes - Detism,
+                check_instance_modes(ModuleInfo, Ps, ArgModes - Detism,
                         TheProcId)
         ).
 
@@ -412,17 +605,55 @@
         matching_mode_list(ModuleInfo, As, Bs).
 
 %---------------------------------------------------------------------------%
+        % Make the name of the introduced pred used to check a particular
+        % instance of a particular class method
+        %
+        % XXX This isn't quite perfect, I suspect
+:- pred make_introduced_pred_name(class_id, sym_name, arity, list(type), 
+        sym_name).
+:- mode make_introduced_pred_name(in, in, in, in, out) is det.
+
+make_introduced_pred_name(ClassId, MethodName, _PredArity, 
+                InstanceTypes, PredName) :-
+        ClassId = class_id(ClassName, _ClassArity),
+        unqualify(ClassName, ClassNameString),
+        unqualify(MethodName, MethodNameString),
+                % Perhaps we should include the pred arity in this mangled
+                % string?
+        % string__int_to_string(PredArity, PredArityString),
+        base_typeclass_info__make_instance_string(InstanceTypes, 
+                InstanceString),
+        string__append_list(
+                ["Introduced predicate for ",
+                ClassNameString,
+                "(",
+                InstanceString,
+                ") method ",
+                MethodNameString
+                ], 
+                PredNameString),
+        PredName = unqualified(PredNameString).
+
+:- pred unqualify(sym_name::in, string::out) is det.
+
+unqualify(unqualified(X), X).
+unqualify(qualified(M0, X), Result) :-
+        unqualify(M0, M),
+        string__append_list([M, "__", X], Result).
+
+%---------------------------------------------------------------------------%
 
 % check that the superclass constraints are satisfied for the
 % types in this instance declaration
 
 :- pred check_superclass_conformance(list(class_constraint), list(var),
-        varset, module_info, hlds_instance_defn, hlds_instance_defn, 
-        list(string), list(string)).
-:- mode check_superclass_conformance(in, in, in, in, in, out, in, out) is det.
+        varset, hlds_instance_defn, hlds_instance_defn, 
+        pair(list(string), module_info), pair(list(string), module_info)).
+:- mode check_superclass_conformance(in, in, in, in, out, in, out) is det.
 
 check_superclass_conformance(SuperClasses0, ClassVars0, ClassVarSet, 
-                ModuleInfo, InstanceDefn0, InstanceDefn, Errors0, Errors) :-
+                InstanceDefn0, InstanceDefn, 
+                Errors0 - ModuleInfo, Errors - ModuleInfo) :-
 
         InstanceDefn0 = hlds_instance_defn(A, InstanceConstraints,
                 InstanceTypes, D, E, InstanceVarSet0, Proofs0),
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.87
diff -u -t -r1.87 mercury_compile.m
--- mercury_compile.m	1998/05/16 07:30:23	1.87
+++ mercury_compile.m	1998/05/20 08:49:18
@@ -493,11 +493,17 @@
                     "% Program contains undefined type error(s).\n"),
             io__set_exit_status(1)
         ;
+                
+            maybe_write_string(Verbose, 
+                "% Checking typeclass instances...\n"),
+            check_typeclass__check_instance_decls(HLDS1, HLDS2,
+                FoundTypeclassError),
+            mercury_compile__maybe_dump_hlds(HLDS2, "2", "typeclass"), !,
 
             %
             % Next typecheck the clauses.
             %
-            typecheck(HLDS1, HLDS3, FoundUndefModeError, FoundTypeError), !,
+            typecheck(HLDS2, HLDS3, FoundUndefModeError, FoundTypeError), !,
             ( { FoundTypeError = yes } ->
                 maybe_write_string(Verbose,
                         "% Program contains type error(s).\n"),
@@ -514,7 +520,7 @@
             globals__io_lookup_bool_option(typecheck_only, TypecheckOnly),
             ( { TypecheckOnly = yes } ->
                 { HLDS = HLDS3 },
-                { FoundError = FoundTypeError }
+                { bool__or(FoundTypeError, FoundTypeclassError, FoundError) }
             ;
                 % only write out the `.opt' file if there are no type errors
                 globals__io_lookup_bool_option(make_optimization_interface,
@@ -528,7 +534,8 @@
                 % if our job was to write out the `.opt' file, then we're done
                 ( { MakeOptInt = yes } ->
                         { HLDS = HLDS4 },
-                        { FoundError = FoundTypeError }
+                        { bool__or(FoundTypeError, FoundTypeclassError,
+                                FoundError) }
                 ;
                         %
                         % We can't continue after an undefined inst/mode
@@ -548,7 +555,9 @@
                             mercury_compile__frontend_pass_2_by_phases(HLDS4,
                                         HLDS, FoundModeOrDetError),
                             { bool__or(FoundTypeError, FoundModeOrDetError,
-                                        FoundError) }
+                                        FoundError0) },
+                            { bool__or(FoundError0, FoundTypeclassError,
+                                FoundError) }
                         )
                 )
             )
@@ -674,14 +683,8 @@
                         HLDS9, FoundUniqError), !,
                 mercury_compile__maybe_dump_hlds(HLDS9, "09", "unique_modes"),
                 !,
-                
-                maybe_write_string(Verbose, 
-                        "% Mode and type checking typeclass instances...\n"),
-                check_typeclass__check_instance_decls(HLDS9, HLDS10,
-                        FoundTypeclassError),
-                mercury_compile__maybe_dump_hlds(HLDS10, "10", "typeclass"), !,
 
-                mercury_compile__check_stratification(HLDS10, Verbose, Stats, 
+                mercury_compile__check_stratification(HLDS9, Verbose, Stats, 
                         HLDS11, FoundStratError), !,
                 mercury_compile__maybe_dump_hlds(HLDS11, "11",
                         "stratification"), !,
@@ -699,7 +702,6 @@
                         { FoundDetError = no },
                         { FoundUniqError = no },
                         { FoundStratError = no },
-                        { FoundTypeclassError = no },
                         % Strictly speaking, we shouldn't need to check
                         % the exit status.  But the values returned for
                         % FoundModeError etc. aren't always correct.
Index: compiler/type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.52
diff -u -t -r1.52 type_util.m
--- type_util.m	1998/04/08 15:23:32	1.52
+++ type_util.m	1998/05/18 04:58:38
@@ -138,8 +138,9 @@
 
         % type_list_matches_exactly(TypesA, TypesB) succeeds iff TypesA and
         % TypesB are exactly the same modulo variable renaming. 
-:- pred type_list_matches_exactly(list(type), list(type)).
-:- mode type_list_matches_exactly(in, in) is semidet.
+:- pred type_and_constraint_list_matches_exactly(list(type),
+        list(class_constraint), list(type), list(class_constraint)).
+:- mode type_and_constraint_list_matches_exactly(in, in, in, in) is semidet.
 
         % apply a type substitution (i.e. map from tvar -> type)
         % to all the types in a variable typing (i.e. map from var -> type).
@@ -450,9 +451,14 @@
 
         % If this becomes a performance bottleneck, it can probably be coded
         % more efficiently.
-type_list_matches_exactly(TypesA, TypesB) :-
-        type_list_subsumes(TypesA, TypesB, _),
-        type_list_subsumes(TypesB, TypesA, _).
+type_and_constraint_list_matches_exactly(TypesA, ConstraintsA0, 
+                TypesB, ConstraintsB) :-
+        type_list_subsumes(TypesA, TypesB, Subst),
+        type_list_subsumes(TypesB, TypesA, _),
+        apply_subst_to_constraints(Subst, ConstraintsA0, ConstraintsA),
+        list__sort(ConstraintsA, SortedA),
+        list__sort(ConstraintsB, SortedB),
+        SortedA = SortedB.
 
 %-----------------------------------------------------------------------------%
 


love and cuddles,
dgj
-- 
David Jeffery (dgj at cs.mu.oz.au) |  Marge: Did you just call everyone "chicken"?
MEngSc student,                 |  Homer: Noooo.  I swear on this Bible!
Department of Computer Science  |  Marge: That's not a Bible; that's a book of
University of Melbourne         |         carpet samples!
Australia                       |  Homer: Ooooh... Fuzzy.



More information about the developers mailing list