[m-rev.] diff: fix a bug with interface files and typeclasses

[Julien Fischer]

Estimated hours taken: 4
Branches: main, release

Fix a bug with interface files and typeclasses reported by Peter Ross.

Typeclass definitions in the implementation section of a module are written
out as abstract declarations in the implementation of the interface files.
The bug was that module imports from the implementation section that were
needed by items referred to from the typeclass constraints were not being
included in the implementation section of the interface file.  This caused a
map lookup abort when other modules were compiled against these interface
files.

The fix is to make sure that we consider any typeclass constraints when
computing the set of "necessary" implementation imports, i.e. those that
must appear in the interface files.

compiler/modules.m:
 	Include module imports required by typeclass constraints in the
 	set of modules that must appear in the implementation section of
 	an interface file.

tests/valid/Mmakefile:
tests/valid/tc_map_lookup.m:
tests/valid/tc_map_lookup_2.m:
 	Testcase for the above.

Julien.

Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.408
diff -u -r1.408 modules.m
--- compiler/modules.m	18 Oct 2006 09:58:18 -0000	1.408
+++ compiler/modules.m	6 Nov 2006 11:50:35 -0000
@@ -1486,7 +1486,17 @@
          % types and dummy types in the implementation.
          get_requirements_of_impl_exported_types(!.IntTypesMap, !.ImplTypesMap,
              NecessaryDummyTypeCtors, NecessaryEqvTypeCtors,
-            NecessaryImplImports),
+            NecessaryTypeImplImports),
+
+        % Work out which module imports in the implementation section of
+        % the interface are required by the definitions of typeclasses
+        % in the implementation.  Specifically, we require that ones
+        % that are needed by any constraints on the typeclasses.
+        get_requirements_of_impl_typeclasses(!.ImplItems,
+            NecessaryTypeclassImplImports),
+
+        NecessaryImplImports = NecessaryTypeImplImports `set.union`
+            NecessaryTypeclassImplImports,

          % If a type in the implementation section isn't dummy and doesn't have
          % foreign type alternatives, make it abstract.
@@ -1495,7 +1505,6 @@
          % If there is an exported type declaration for a type with an abstract
          % declaration in the implementation (usually it will originally
          % have been a d.u. type), remove the declaration in the implementation.
-
          FindAbstractExportedTypes =
              (pred(TypeCtor::out) is nondet :-
                  map.member(!.ImplTypesMap, TypeCtor, Defns),
@@ -1529,6 +1538,7 @@
          IntItems = [make_pseudo_decl(md_interface) | IntItems0],

          maybe_strip_import_decls(!ImplItems),
+
          strip_unnecessary_impl_imports(NecessaryImplImports, !ImplItems),
          set.union(NecessaryDummyTypeCtors, NecessaryEqvTypeCtors,
              AllNecessaryTypeCtors),
@@ -1979,6 +1989,94 @@

  gather_type_defn(TypeCtor, Body, Item, DefnMap0, DefnMap) :-
      multi_map.set(DefnMap0, TypeCtor, Body - Item, DefnMap).
+ 
+:- pred get_requirements_of_impl_typeclasses(item_list::in,
+    set(module_name)::out) is det.
+
+get_requirements_of_impl_typeclasses(ImplItems, Modules) :-
+    list.foldl(get_requirements_of_impl_typeclass,
+        ImplItems, set.init, Modules).
+
+:- pred get_requirements_of_impl_typeclass(item_and_context::in,
+    set(module_name)::in, set(module_name)::out) is det.
+
+get_requirements_of_impl_typeclass(Item - _, !Modules) :-
+    (
+        Item = item_typeclass(Constraints, _, _, _, _, _),
+        list.foldl(get_requirements_of_impl_from_constraint, Constraints,
+            !Modules)
+    ;
+        ( Item = item_clause(_, _, _, _, _, _)
+        ; Item = item_type_defn(_, _, _, _, _)
+        ; Item = item_inst_defn(_, _, _, _, _)
+        ; Item = item_mode_defn(_, _, _, _, _)
+        ; Item = item_module_defn(_, _)
+        ; Item = item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _)
+        ; Item = item_pred_or_func_mode(_, _, _, _, _, _, _)
+        ; Item = item_pragma(_, _)
+        ; Item = item_promise(_, _, _, _)
+        ; Item = item_instance(_, _, _, _, _, _)
+        ; Item = item_initialise(_, _, _)
+        ; Item = item_finalise(_, _, _)
+        ; Item = item_mutable(_, _, _, _, _, _)
+        ; Item = item_nothing(_)
+        )
+    ).
+ 
+:- pred get_requirements_of_impl_from_constraint(prog_constraint::in,
+    set(module_name)::in, set(module_name)::out) is det.
+
+get_requirements_of_impl_from_constraint(Constraint, !Modules) :-
+    Constraint = constraint(ClassName, Args),
+    % NOTE: this assumes that everything has been module qualified.
+    ( sym_name_get_module_name(ClassName, ModuleName) ->
+        svset.insert(ModuleName, !Modules)
+    ;
+        unexpected(this_file, "get_requirements_of_impl_from_constraint: " ++
+            "unknown typeclass in constraint.")
+    ),
+    get_modules_from_constraint_arg_types(Args, !Modules).
+
+:- pred get_modules_from_constraint_arg_types(list(mer_type)::in,
+    set(module_name)::in, set(module_name)::out) is det.
+
+get_modules_from_constraint_arg_types(ArgTypes, !Modules) :-
+    list.foldl(get_modules_from_constraint_arg_type, ArgTypes, !Modules).
+
+:- pred get_modules_from_constraint_arg_type(mer_type::in,
+    set(module_name)::in, set(module_name)::out) is det.
+
+get_modules_from_constraint_arg_type(ArgType, !Modules) :-
+    (
+        % Do nothing for these types - they cannot affect the set of 
+        % implementation imports in an interface file.
+        ( ArgType = type_variable(_, _)
+        ; ArgType = builtin_type(_)
+        )
+    ;
+        ArgType = defined_type(TypeName, Args, _),
+        ( sym_name_get_module_name(TypeName, ModuleName) ->
+            svset.insert(ModuleName, !Modules)
+        ; 
+            unexpected(this_file, "get_modules_from_constraint_arg: " ++
+                "unknown type encountered.")
+        ),
+        get_modules_from_constraint_arg_types(Args, !Modules)
+    ;
+        ( ArgType = tuple_type(Args, _)
+        ; ArgType = apply_n_type(_, Args, _)
+        ; ArgType = kinded_type(KindedType, _), Args = [KindedType]
+        ; ArgType = higher_order_type(Args0, MaybeRetType, _, _),
+          (
+                MaybeRetType = yes(RetType),
+                Args = [ RetType  | Args0 ]
+          ;
+                MaybeRetType = no,
+                Args = Args0
+          )
+        ),
+        get_modules_from_constraint_arg_types(Args, !Modules)
+    ).

  %-----------------------------------------------------------------------------%

@@ -7254,6 +7352,7 @@
  include_in_short_interface(item_pragma(_, pragma_foreign_import_module(_, _))).

      % Could this item use items from imported modules.
+    %
  :- func item_needs_imports(item) = bool.

  item_needs_imports(item_clause(_, _, _, _, _, _)) = yes.
@@ -7266,20 +7365,7 @@
  item_needs_imports(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _)) =
      yes.
  item_needs_imports(item_pred_or_func_mode(_, _, _, _, _, _, _)) = yes.
-item_needs_imports(Item @ item_typeclass(_, _, _, _, _, _)) =
-    (
-        Item ^ tc_class_methods = class_interface_abstract,
-        \+ (
-            list.member(Constraint, Item ^ tc_constraints),
-            Constraint = constraint(_, ConstraintArgs),
-            list.member(ConstraintArg, ConstraintArgs),
-            type_is_nonvar(ConstraintArg)
-        )
-    ->
-        no
-    ;
-        yes
-    ).
+item_needs_imports(item_typeclass(_, _, _, _, _, _)) = yes.
  item_needs_imports(item_instance(_, _, _, _, _, _)) = yes.
  item_needs_imports(item_promise(_, _, _, _)) = yes.
  item_needs_imports(item_initialise(_, _, _)) = yes.
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.182
diff -u -r1.182 Mmakefile
--- tests/valid/Mmakefile	29 Oct 2006 03:18:59 -0000	1.182
+++ tests/valid/Mmakefile	6 Nov 2006 11:32:21 -0000
@@ -39,6 +39,7 @@
  	repeated_class_constraint \
  	superclass_bug \
  	superclass_improvement \
+	tc_map_lookup \
  	typeclass_constraint_no_var \
  	typeclass_constraint_nonvar_bug \
  	typeclass_det_warning
Index: tests/valid/tc_map_lookup.m
===================================================================
RCS file: tests/valid/tc_map_lookup.m
diff -N tests/valid/tc_map_lookup.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/valid/tc_map_lookup.m	6 Nov 2006 11:35:41 -0000
@@ -0,0 +1,16 @@
+% Mercury rotd-2006-11-04 and before could not compile this module because
+% the .int file for tc_map_lookup_2 did not contain the (implementation)
+% imports required by the typeclass constraints on the typeclass tc/1.
+%
+:- module tc_map_lookup.
+:- interface.
+
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module tc_map_lookup_2.
+
+main -->
+    io.write_string("hi.\n").
Index: tests/valid/tc_map_lookup_2.m
===================================================================
RCS file: tests/valid/tc_map_lookup_2.m
diff -N tests/valid/tc_map_lookup_2.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/valid/tc_map_lookup_2.m	6 Nov 2006 11:35:38 -0000
@@ -0,0 +1,13 @@
+:- module tc_map_lookup_2.
+:- interface.
+
+:- type t ---> t.
+
+:- implementation.
+
+:- import_module term_to_xml.
+
+:- typeclass tc(T) <= xmlable(T) where [
+	func f(T) = string
+].
+

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