diff --git a/compiler/add_class.m b/compiler/add_class.m index 61256ed8c..0479bcf0f 100644 --- a/compiler/add_class.m +++ b/compiler/add_class.m @@ -24,7 +24,11 @@ module_info::in, module_info::out, list(err_spec)::in, list(err_spec)::out) is det. -:- pred add_instance_defns(ims_list(item_instance_info)::in, +:- pred add_abstract_instance_defns(ims_list(item_abstract_instance_info)::in, + module_info::in, module_info::out, + list(err_spec)::in, list(err_spec)::out) is det. + +:- pred add_full_instance_defns(ims_list(item_instance_info)::in, module_info::in, module_info::out, list(err_spec)::in, list(err_spec)::out) is det. @@ -73,13 +77,38 @@ add_typeclass_defns([SecSubList | SecSubLists], !ModuleInfo, !Specs) :- Items, !ModuleInfo, !Specs), add_typeclass_defns(SecSubLists, !ModuleInfo, !Specs). -add_instance_defns([], !ModuleInfo, !Specs). -add_instance_defns([ImsSubList | ImsSubLists], !ModuleInfo, !Specs) :- +add_abstract_instance_defns([], !ModuleInfo, !Specs). +add_abstract_instance_defns([ImsSubList | ImsSubLists], !ModuleInfo, !Specs) :- + ImsSubList = ims_sub_list(ItemMercuryStatus, Items), + ( + ItemMercuryStatus = item_defined_in_this_module(_), + AbsItemMercuryStatus = ItemMercuryStatus + ; + ItemMercuryStatus = item_defined_in_other_module(ItemImport), + ( + ( ItemImport = item_import_int_concrete(_) + ; ItemImport = item_import_int_abstract + ), + AbsItemImport = item_import_int_abstract + ; + ItemImport = item_import_opt_int, + AbsItemImport = item_import_opt_int + ), + AbsItemMercuryStatus = item_defined_in_other_module(AbsItemImport) + ), + item_mercury_status_to_instance_status(AbsItemMercuryStatus, + InstanceStatus), + list.foldl2(add_instance_defn(InstanceStatus), coerce(Items), + !ModuleInfo, !Specs), + add_abstract_instance_defns(ImsSubLists, !ModuleInfo, !Specs). + +add_full_instance_defns([], !ModuleInfo, !Specs). +add_full_instance_defns([ImsSubList | ImsSubLists], !ModuleInfo, !Specs) :- ImsSubList = ims_sub_list(ItemMercuryStatus, Items), item_mercury_status_to_instance_status(ItemMercuryStatus, InstanceStatus), list.foldl2(add_instance_defn(InstanceStatus), Items, !ModuleInfo, !Specs), - add_instance_defns(ImsSubLists, !ModuleInfo, !Specs). + add_full_instance_defns(ImsSubLists, !ModuleInfo, !Specs). %---------------------------------------------------------------------------% @@ -145,9 +174,12 @@ add_typeclass_defn(ItemMercuryStatus, TypeClassStatus0, NeedQual, Interface = class_interface_concrete(_), OldInterface = class_interface_concrete(_) then - TypeClassStatus = typeclass_status(OldImportStatus), % This is a duplicate, but an identical duplicate. - ( if OldImportStatus = status_opt_imported then + ( if + TypeClassStatus = + typeclass_defined_in_other_module(Import), + Import = typeclass_import_full_opt + then true else report_multiply_defined("typeclass", ClassName, @@ -300,7 +332,7 @@ module_declare_class_method_preds(ClassName, ClassParamVars, TypeClassStatus, ClassPredOrFuncInfos = cord.list(ClassPredOrFuncInfosCord), % XXX STATUS - TypeClassStatus = typeclass_status(OldImportStatus), + OldImportStatus = new_typeclass_status_to_old(TypeClassStatus), PredStatus = pred_status(OldImportStatus), % Stage 2. list.foldl5( @@ -506,24 +538,21 @@ add_class_mode_decl(ItemMercuryStatus, PredStatus, MethodPredName, PredId, module_info::in, module_info::out, list(err_spec)::in, list(err_spec)::out) is det. -add_instance_defn(InstanceStatus0, ItemInstanceInfo, !ModuleInfo, !Specs) :- +add_instance_defn(InstanceStatus, ItemInstanceInfo, !ModuleInfo, !Specs) :- ItemInstanceInfo = item_instance_info(ClassName, Types, OriginalTypes, Constraints, InstanceBody0, TVarSet, InstanceModuleName, Context, _SeqNum), ( InstanceBody0 = instance_body_abstract, - InstanceBody = instance_body_abstract, - % XXX This can make the status abstract_imported even if the instance - % is NOT imported. - % When this is fixed, please undo the workaround for this bug - % in instance_used_modules in unused_imports.m. - instance_make_status_abstract(InstanceStatus0, InstanceStatus) + InstanceBody = instance_body_abstract + % We used to change the InstanceStatus here to make it abstract, + % but outside of intermodule optimization; *all* intermodule + % references to instances are abstract. ; InstanceBody0 = instance_body_concrete(InstanceMethods0), list.map(expand_bang_state_pairs_in_instance_method, InstanceMethods0, InstanceMethods), - InstanceBody = instance_body_concrete(InstanceMethods), - InstanceStatus = InstanceStatus0 + InstanceBody = instance_body_concrete(InstanceMethods) ), module_info_get_class_table(!.ModuleInfo, Classes), diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index a98b3df2e..aff901bb9 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -1242,7 +1242,8 @@ generate_instance_method_pred_and_procs(ClassId, ClassVars, ClassPredId, IsImported = instance_status_is_imported(InstanceStatus0), ( IsImported = yes, - InstanceStatus = instance_status(status_opt_imported) + InstanceStatus = + instance_defined_in_other_module(instance_import_full_opt) ; IsImported = no, InstanceStatus = InstanceStatus0 @@ -1266,7 +1267,7 @@ generate_instance_method_pred_and_procs(ClassId, ClassVars, ClassPredId, InstanceMethodConstraints)), map.init(VarNameRemap), % XXX STATUS - InstanceStatus = instance_status(OldImportStatus), + OldImportStatus = new_instance_status_to_old(InstanceStatus), PredStatus = pred_status(OldImportStatus), CurUserDecl = maybe.no, GoalType = goal_not_for_promise(np_goal_type_none), diff --git a/compiler/hlds_out_util.m b/compiler/hlds_out_util.m index 329e1cf6d..1a69630dd 100644 --- a/compiler/hlds_out_util.m +++ b/compiler/hlds_out_util.m @@ -852,10 +852,10 @@ inst_import_status_to_string(inst_status(InstModeStatus)) = instmode_status_to_string(InstModeStatus). mode_import_status_to_string(mode_status(InstModeStatus)) = instmode_status_to_string(InstModeStatus). -typeclass_import_status_to_string(typeclass_status(OldImportStatus)) = - old_import_status_to_string(OldImportStatus). -instance_import_status_to_string(instance_status(OldImportStatus)) = - old_import_status_to_string(OldImportStatus). +typeclass_import_status_to_string(TypeClassStatus) = + typeclass_status_to_string(TypeClassStatus). +instance_import_status_to_string(InstanceStatus) = + instance_status_to_string(InstanceStatus). pred_import_status_to_string(pred_status(OldImportStatus)) = old_import_status_to_string(OldImportStatus). @@ -888,6 +888,79 @@ instmode_status_to_string(InstModeStatus) = Str :- ) ). +:- func typeclass_status_to_string(new_typeclass_status) = string. + +typeclass_status_to_string(TypeClassStatus) = Str :- + ( + TypeClassStatus = typeclass_defined_in_this_module(TypeClassExport), + ( + TypeClassExport = typeclass_export_gen_none_sub_none, + Str = "this_module(gen_none_sub_none)" + ; + TypeClassExport = typeclass_export_gen_none_sub_full, + Str = "this_module(gen_none_sub_full)" + ; + TypeClassExport = typeclass_export_gen_abs_sub_full, + Str = "this_module(gen_abs_sub_full)" + ; + TypeClassExport = typeclass_export_gen_full_sub_full, + Str = "this_module(gen_full_sub_full)" + ) + ; + TypeClassStatus = typeclass_defined_in_other_module(TypeClassImport), + ( + TypeClassImport = typeclass_import_full_own_int, + Str = "other_module(full_own_int)" + ; + TypeClassImport = typeclass_import_full_own_imp, + Str = "other_module(full_own_imp)" + ; + TypeClassImport = typeclass_import_full_int0_int, + Str = "other_module(full_int0_int)" + ; + TypeClassImport = typeclass_import_full_int0_imp, + Str = "other_module(full_int0_imp)" + ; + TypeClassImport = typeclass_import_full_by_ancestor, + Str = "other_module(full_by_ancestor)" + ; + TypeClassImport = typeclass_import_full_opt, + Str = "other_module(full_opt)" + ; + TypeClassImport = typeclass_import_abstract, + Str = "other_module(abstract)" + ) + ). + +:- func instance_status_to_string(new_instance_status) = string. + +instance_status_to_string(InstanceStatus) = Str :- + ( + InstanceStatus = instance_defined_in_this_module(InstanceExport), + ( + InstanceExport = instance_export_gen_none_sub_none, + Str = "this_module(gen_none_sub_none)" + ; + InstanceExport = instance_export_gen_none_sub_abs, + Str = "this_module(gen_none_sub_ans)" + ; + InstanceExport = instance_export_gen_abs_sub_abs, + Str = "this_module(gen_abs_sub_abs)" + ; + InstanceExport = instance_export_full_opt, + Str = "this_module(full_opt)" + ) + ; + InstanceStatus = instance_defined_in_other_module(InstanceImport), + ( + InstanceImport = instance_import_full_opt, + Str = "other_module(full_opt)" + ; + InstanceImport = instance_import_abstract, + Str = "other_module(abstract)" + ) + ). + :- func old_import_status_to_string(old_import_status) = string. old_import_status_to_string(status_local) = diff --git a/compiler/instance_method_clauses.m b/compiler/instance_method_clauses.m index 0d89c4f58..22ce1add6 100644 --- a/compiler/instance_method_clauses.m +++ b/compiler/instance_method_clauses.m @@ -165,7 +165,7 @@ produce_instance_method_clause(PredOrFunc, Context, InstanceStatus, % dummy value should be ok. AllProcIds = [], % XXX STATUS - InstanceStatus = instance_status(OldImportStatus), + OldImportStatus = new_instance_status_to_old(InstanceStatus), PredStatus = pred_status(OldImportStatus), add_clause_to_clauses_info(all_modes, AllProcIds, PredStatus, clause_not_for_promise, PredOrFunc, PredSymName, HeadTerms, diff --git a/compiler/intermod.m b/compiler/intermod.m index 497f10140..a68a900e2 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -622,7 +622,7 @@ intermod_gather_class(ModuleName, ClassId, ClassDefn, !TypeClassesCord) :- ClassId = class_id(QualifiedClassName, _), ( if QualifiedClassName = qualified(ModuleName, _), - typeclass_status_to_write(TypeClassStatus) = yes + typeclass_status_to_write(TypeClassStatus) = yes(_) then FunDeps = list.map(unmake_hlds_class_fundep(TVars), HLDSFunDeps), ItemTypeClass = item_typeclass_info(QualifiedClassName, TVars, diff --git a/compiler/intermod_mark_exported.m b/compiler/intermod_mark_exported.m index 7ffad8a4f..5340e9a7f 100644 --- a/compiler/intermod_mark_exported.m +++ b/compiler/intermod_mark_exported.m @@ -171,9 +171,9 @@ maybe_opt_export_class_defn(ClassId - ClassDefn0, ClassId - ClassDefn, !ModuleInfo) :- ToWrite = typeclass_status_to_write(ClassDefn0 ^ classdefn_status), ( - ToWrite = yes, + ToWrite = yes(Export), ClassDefn = ClassDefn0 ^ classdefn_status := - typeclass_status(status_exported), + typeclass_defined_in_this_module(Export), method_infos_to_pred_ids(ClassDefn ^ classdefn_method_infos, PredIds), opt_export_preds(PredIds, !ModuleInfo) ; @@ -224,8 +224,8 @@ maybe_opt_export_instance_defn(Instance0, Instance, !ModuleInfo) :- Body, MaybeMethodInfos, Context), ToWrite = instance_status_to_write(InstanceStatus0), ( - ToWrite = yes, - InstanceStatus = instance_status(status_exported), + ToWrite = yes(Export), + InstanceStatus = instance_defined_in_this_module(Export), Instance = hlds_instance_defn(InstanceModule, InstanceStatus, TVarSet, OriginalTypes, Types, Constraints, MaybeSubsumedContext, ConstraintProofs, diff --git a/compiler/intermod_status.m b/compiler/intermod_status.m index 671d7e55e..257b17d19 100644 --- a/compiler/intermod_status.m +++ b/compiler/intermod_status.m @@ -19,14 +19,15 @@ :- import_module hlds.status. :- import_module bool. +:- import_module maybe. % Should a declaration with the given status be written to the `.opt' file? % :- func type_status_to_write(type_status) = bool. :- func inst_status_to_write(inst_status) = bool. :- func mode_status_to_write(mode_status) = bool. -:- func typeclass_status_to_write(typeclass_status) = bool. -:- func instance_status_to_write(instance_status) = bool. +:- func typeclass_status_to_write(typeclass_status) = maybe(typeclass_export). +:- func instance_status_to_write(instance_status) = maybe(instance_export). :- func pred_status_to_write(pred_status) = bool. %---------------------------------------------------------------------------% @@ -43,11 +44,11 @@ inst_status_to_write(inst_status(InstModeStatus)) = ToWrite :- mode_status_to_write(mode_status(InstModeStatus)) = ToWrite :- ToWrite = instmode_status_to_write(InstModeStatus). -typeclass_status_to_write(typeclass_status(OldStatus)) = ToWrite :- - ToWrite = old_status_to_write(OldStatus). +typeclass_status_to_write(TypeClassStatus) = ToWrite :- + ToWrite = new_typeclass_status_to_write(TypeClassStatus). -instance_status_to_write(instance_status(OldStatus)) = ToWrite :- - ToWrite = old_status_to_write(OldStatus). +instance_status_to_write(InstanceStatus) = ToWrite :- + ToWrite = new_instance_status_to_write(InstanceStatus). pred_status_to_write(pred_status(OldStatus)) = ToWrite :- ToWrite = old_status_to_write(OldStatus). @@ -73,6 +74,50 @@ instmode_status_to_write(InstModeStatus) = ToWrite :- ToWrite = no ). +:- func new_typeclass_status_to_write(new_typeclass_status) + = maybe(typeclass_export). + +new_typeclass_status_to_write(Status) = ToWrite :- + ( + Status = typeclass_defined_in_this_module(Export), + ( + ( Export = typeclass_export_gen_none_sub_none + ; Export = typeclass_export_gen_none_sub_full + ; Export = typeclass_export_gen_abs_sub_full + ), + ToWrite = yes(typeclass_export_gen_full_sub_full) + ; + Export = typeclass_export_gen_full_sub_full, + ToWrite = no + ) + ; + Status = typeclass_defined_in_other_module(_), + ToWrite = no + ). + +:- func new_instance_status_to_write(new_instance_status) + = maybe(instance_export). + +new_instance_status_to_write(Status) = ToWrite :- + ( + Status = instance_defined_in_this_module(Export), + ( + ( Export = instance_export_gen_none_sub_none + ; Export = instance_export_gen_none_sub_abs + ; Export = instance_export_gen_abs_sub_abs + ), + ToWrite = yes(instance_export_full_opt) + ; + Export = instance_export_full_opt, + % XXX INSTANCE_STATUS This seems strange, but + % it preserves old bevhavior. + ToWrite = no + ) + ; + Status = instance_defined_in_other_module(_), + ToWrite = no + ). + :- func old_status_to_write(old_import_status) = bool. old_status_to_write(status_imported(_)) = no. diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m index 5bce1f6ff..5ee3e2bdb 100644 --- a/compiler/make_hlds_passes.m +++ b/compiler/make_hlds_passes.m @@ -440,9 +440,9 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, % The items in MutablePredDecls do not have default modes to add. % Record instance definitions. - add_instance_defns(coerce(IntInstances), + add_abstract_instance_defns(IntInstances, !ModuleInfo, !ErrSpecs), - add_instance_defns(ImpInstances, + add_full_instance_defns(ImpInstances, !ModuleInfo, !ErrSpecs), % Implement several kinds of pragmas, the ones in the subtype diff --git a/compiler/status.m b/compiler/status.m index ff887cf37..c9c4d30bd 100644 --- a/compiler/status.m +++ b/compiler/status.m @@ -1,10 +1,10 @@ -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% % vim: ts=4 sw=4 expandtab ft=mercury -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% % Copyright (C) 2015, 2024-2025 The Mercury team. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% % % This module defines the type that holds the status of six kinds of % HLDS entities; types, insts, modes, typeclasses, instances and predicates. @@ -25,7 +25,7 @@ % around the old_import_status type. Later, they will be specialized to their % unique needs. % -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- module hlds.status. :- interface. @@ -55,23 +55,20 @@ :- type pred_status ---> pred_status(old_import_status). -:- type typeclass_status - ---> typeclass_status(old_import_status). +% The new_{typeclass,instance}_status types and these equivalences +% should go away after a transitional period. -:- type instance_status - ---> instance_status(old_import_status). +:- type typeclass_status == new_typeclass_status. -%-----------------------------------------------------------------------------% +:- type instance_status == new_instance_status. + +%---------------------------------------------------------------------------% % The type that should represent the import/export status of both % insts and modes, once we transition away from using old_import_status. :- type new_instmode_status - ---> instmode_defined_in_this_module( - instmode_export - ) - ; instmode_defined_in_other_module( - instmode_import - ). + ---> instmode_defined_in_this_module(instmode_export) + ; instmode_defined_in_other_module(instmode_import). :- type instmode_export ---> instmode_export_nowhere @@ -98,7 +95,83 @@ % (b) an interface file that was read to make sense % of a .opt or .trans_opt file. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- type new_typeclass_status + ---> typeclass_defined_in_this_module(typeclass_export) + ; typeclass_defined_in_other_module(typeclass_import). + +:- type typeclass_export + ---> typeclass_export_gen_none_sub_none + % Both the interface and the concrete definition of the typeclass + % are visible only in the current module. They would also be + % visible to its submodules, but there aren't any. + ; typeclass_export_gen_none_sub_full + % Both the interface and the concrete definition of the typeclass + % are visible only in the current module and its submodules. + ; typeclass_export_gen_abs_sub_full + % Both the interface and the concrete definition of the typeclass + % are visible in the current module and its submodules, and + % its interface is also visible to any other module that + % imports the current module. + ; typeclass_export_gen_full_sub_full. + % Both the interface and the concrete definition of the typeclass + % are visible in the current module, its submodules, and in + % any other module that imports the current module. + % + % A typeclass can have this typeclass_export value *either* + % because of the occurrence of the concrete typeclass definition + % in the interface section, *or* because intermod_status.m + % decides to opt-export the typeclass. This conflation + % is why there is no export mirror of typeclass_import_full_opt. + + % XXX TYPECLASS_STATUS Are any of these "full"s lies? + % XXX TYPECLASS_STATUS We need *some* of the distinctions between + % import locations, but do we need them *all*? +:- type typeclass_import + ---> typeclass_import_full_own_int + ; typeclass_import_full_own_imp + ; typeclass_import_full_int0_int + ; typeclass_import_full_int0_imp + ; typeclass_import_full_by_ancestor + ; typeclass_import_full_opt + ; typeclass_import_abstract. + +%---------------------------------------------------------------------------% + +:- type new_instance_status + ---> instance_defined_in_this_module(instance_export) + ; instance_defined_in_other_module(instance_import). + +:- type instance_export + ---> instance_export_gen_none_sub_none + % Both the abstract and concrete versions of the instance + % are visible only in the current module. The abstract version + % would also be visible in its submodules, but there aren't any. + ; instance_export_gen_none_sub_abs + % Both the abstract and concrete versions of the instance + % are visible in the current module. The abstract version + % is also visible in its submodules. + ; instance_export_gen_abs_sub_abs + % Both the abstract and concrete versions of the instance + % are visible in the current module. The abstract version + % is also visible in its submodules and in any other module + % that imports the current module. + ; instance_export_full_opt. + % Both the abstract and concrete versions of the instance + % are visible in the current module, in its submodules, + % and in any other module that imports the current module. + % + % A instance can have this instance_export value *only* + % because intermod_status.m decides to opt-export the instance. + % This conflation is why there is no export mirror of + % instance_import_full_opt. + +:- type instance_import + ---> instance_import_full_opt + ; instance_import_abstract. + +%---------------------------------------------------------------------------% % The type `old_import_status' describes whether an entity (a predicate, % type, inst, or mode) is local to the current module, exported from @@ -230,14 +303,12 @@ :- func typeclass_status_defined_in_impl_section(typeclass_status) = bool. :- func instance_status_defined_in_impl_section(instance_status) = bool. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- pred type_make_status_abstract(type_status::in, type_status::out) is det. :- pred pred_make_status_abstract(pred_status::in, pred_status::out) is det. :- pred typeclass_make_status_abstract(typeclass_status::in, typeclass_status::out) is det. -:- pred instance_make_status_abstract(instance_status::in, - instance_status::out) is det. % XXX Document me. % @@ -250,7 +321,7 @@ :- pred instance_combine_status(instance_status::in, instance_status::in, instance_status::out) is det. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- type item_mercury_status ---> item_defined_in_this_module( @@ -283,13 +354,24 @@ :- pred item_mercury_status_to_pred_status(item_mercury_status::in, pred_status::out) is det. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % Exported to add_class.m. + % +:- func new_typeclass_status_to_old(new_typeclass_status) = old_import_status. + + % Exported to check_typeclass.m. + % +:- func new_instance_status_to_old(new_instance_status) = old_import_status. + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- implementation. :- import_module require. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% type_status_is_exported(type_status(OldStatus)) = old_status_is_exported(OldStatus). @@ -304,31 +386,85 @@ mode_status_is_exported(ModeStatus) = IsExported :- pred_status_is_exported(pred_status(OldStatus)) = old_status_is_exported(OldStatus). -typeclass_status_is_exported(typeclass_status(OldStatus)) = - old_status_is_exported(OldStatus). -instance_status_is_exported(instance_status(OldStatus)) = - old_status_is_exported(OldStatus). + +typeclass_status_is_exported(TypeClassStatus) = IsExported :- + OldStatus = new_typeclass_status_to_old(TypeClassStatus), + OldIsExported = old_status_is_exported(OldStatus), + NewIsExported = new_typeclass_status_is_exported(TypeClassStatus), + IsExported = return_if_agreed(OldIsExported, NewIsExported). + +instance_status_is_exported(InstanceStatus) = IsExported :- + OldStatus = new_instance_status_to_old(InstanceStatus), + OldIsExported = old_status_is_exported(OldStatus), + NewIsExported = new_instance_status_is_exported(InstanceStatus), + IsExported = return_if_agreed(OldIsExported, NewIsExported). + +%---------------------% :- func instmode_status_is_exported(new_instmode_status) = bool. -instmode_status_is_exported(NewInstModeStatus) = NewIsExported :- +instmode_status_is_exported(InstModeStatus) = IsExported :- ( - NewInstModeStatus = instmode_defined_in_this_module(InstModeExport), + InstModeStatus = instmode_defined_in_this_module(InstModeExport), ( ( InstModeExport = instmode_export_anywhere ; InstModeExport = instmode_export_only_submodules ), - NewIsExported = yes + IsExported = yes ; InstModeExport = instmode_export_nowhere, - NewIsExported = no + IsExported = no ) ; - NewInstModeStatus = instmode_defined_in_other_module(_InstModeImport), - NewIsExported = no + InstModeStatus = instmode_defined_in_other_module(_InstModeImport), + IsExported = no ). -%-----------------------------------------------------------------------------% +%---------------------% + +:- func new_typeclass_status_is_exported(new_typeclass_status) = bool. + +new_typeclass_status_is_exported(TypeClassStatus) = IsExported :- + ( + TypeClassStatus = typeclass_defined_in_this_module(TypeClassExport), + ( + TypeClassExport = typeclass_export_gen_none_sub_none, + IsExported = no + ; + ( TypeClassExport = typeclass_export_gen_none_sub_full + ; TypeClassExport = typeclass_export_gen_abs_sub_full + ; TypeClassExport = typeclass_export_gen_full_sub_full + ), + IsExported = yes + ) + ; + TypeClassStatus = typeclass_defined_in_other_module(_TypeClassImport), + IsExported = no + ). + +%---------------------% + +:- func new_instance_status_is_exported(new_instance_status) = bool. + +new_instance_status_is_exported(InstanceStatus) = IsExported :- + ( + InstanceStatus = instance_defined_in_this_module(InstanceExport), + ( + InstanceExport = instance_export_gen_none_sub_none, + IsExported = no + ; + ( InstanceExport = instance_export_gen_none_sub_abs + ; InstanceExport = instance_export_gen_abs_sub_abs + ; InstanceExport = instance_export_full_opt + ), + IsExported = yes + ) + ; + InstanceStatus = instance_defined_in_other_module(_InstanceImport), + IsExported = no + ). + +%---------------------% old_status_is_exported(status_imported(_)) = no. old_status_is_exported(status_external(_)) = no. @@ -342,7 +478,7 @@ old_status_is_exported(status_pseudo_exported) = yes. old_status_is_exported(status_exported_to_submodules) = yes. old_status_is_exported(status_local) = no. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% type_status_is_exported_to_non_submodules(type_status(Status)) = old_status_is_exported_to_non_submodules(Status). @@ -357,10 +493,92 @@ mode_status_is_exported_to_non_submodules(ModeStatus) = IsExported :- pred_status_is_exported_to_non_submodules(pred_status(Status)) = old_status_is_exported_to_non_submodules(Status). -typeclass_status_is_exported_to_non_submodules(typeclass_status(Status)) = - old_status_is_exported_to_non_submodules(Status). -instance_status_is_exported_to_non_submodules(instance_status(Status)) = - old_status_is_exported_to_non_submodules(Status). + +typeclass_status_is_exported_to_non_submodules(TypeClassStatus) = IsExported :- + OldStatus = new_typeclass_status_to_old(TypeClassStatus), + OldIsExported = old_status_is_exported_to_non_submodules(OldStatus), + NewIsExported = + new_typeclass_status_is_exported_to_non_submodules(TypeClassStatus), + IsExported = return_if_agreed(OldIsExported, NewIsExported). + +instance_status_is_exported_to_non_submodules(InstanceStatus) = IsExported :- + OldStatus = new_instance_status_to_old(InstanceStatus), + OldIsExported = old_status_is_exported_to_non_submodules(OldStatus), + NewIsExported = + new_instance_status_is_exported_to_non_submodules(InstanceStatus), + IsExported = return_if_agreed(OldIsExported, NewIsExported). + +%---------------------% + +:- func instmode_status_is_exported_to_non_submodules(new_instmode_status) + = bool. + +instmode_status_is_exported_to_non_submodules(InstModeStatus) = IsExported :- + ( + InstModeStatus = instmode_defined_in_this_module(InstModeExport), + ( + InstModeExport = instmode_export_anywhere, + IsExported = yes + ; + ( InstModeExport = instmode_export_nowhere + ; InstModeExport = instmode_export_only_submodules + ), + IsExported = no + ) + ; + InstModeStatus = instmode_defined_in_other_module(_InstModeImport), + IsExported = no + ). + +%---------------------% + +:- func new_typeclass_status_is_exported_to_non_submodules( + new_typeclass_status) = bool. + +new_typeclass_status_is_exported_to_non_submodules(Status) = IsExported :- + ( + Status = typeclass_defined_in_this_module(Export), + ( + ( Export = typeclass_export_gen_none_sub_none + ; Export = typeclass_export_gen_none_sub_full + ), + IsExported = no + ; + ( Export = typeclass_export_gen_abs_sub_full + ; Export = typeclass_export_gen_full_sub_full + ), + IsExported = yes + ) + ; + Status = typeclass_defined_in_other_module(_Import), + IsExported = no + ). + +%---------------------% + +:- func new_instance_status_is_exported_to_non_submodules( + new_instance_status) = bool. + +new_instance_status_is_exported_to_non_submodules(Status) = IsExported :- + ( + Status = instance_defined_in_this_module(Export), + ( + ( Export = instance_export_gen_none_sub_none + ; Export = instance_export_gen_none_sub_abs + ), + IsExported = no + ; + ( Export = instance_export_gen_abs_sub_abs + ; Export = instance_export_full_opt + ), + IsExported = yes + ) + ; + Status = instance_defined_in_other_module(_Import), + IsExported = no + ). + +%---------------------% :- func old_status_is_exported_to_non_submodules(old_import_status) = bool. @@ -374,28 +592,7 @@ old_status_is_exported_to_non_submodules(Status) = no ). -:- func instmode_status_is_exported_to_non_submodules(new_instmode_status) - = bool. - -instmode_status_is_exported_to_non_submodules(NewInstModeStatus) - = NewIsExported :- - ( - NewInstModeStatus = instmode_defined_in_this_module(InstModeExport), - ( - InstModeExport = instmode_export_anywhere, - NewIsExported = yes - ; - ( InstModeExport = instmode_export_nowhere - ; InstModeExport = instmode_export_only_submodules - ), - NewIsExported = no - ) - ; - NewInstModeStatus = instmode_defined_in_other_module(_InstModeImport), - NewIsExported = no - ). - -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% type_status_is_imported(type_status(OldStatus)) = old_status_is_imported(OldStatus). @@ -422,17 +619,33 @@ mode_status_is_imported(ModeStatus) = IsImported :- pred_status_is_imported(pred_status(OldStatus)) = old_status_is_imported(OldStatus). -typeclass_status_is_imported(typeclass_status(OldStatus)) = - old_status_is_imported(OldStatus). -instance_status_is_imported(instance_status(OldStatus)) = - old_status_is_imported(OldStatus). + +typeclass_status_is_imported(Status) = IsDefnThisModule :- + ( + Status = typeclass_defined_in_this_module(_Export), + IsDefnThisModule = no + ; + Status = typeclass_defined_in_other_module(_Import), + IsDefnThisModule = yes + ). + +instance_status_is_imported(Status) = IsDefnThisModule :- + ( + Status = instance_defined_in_this_module(_Export), + IsDefnThisModule = no + ; + Status = instance_defined_in_other_module(_Import), + IsDefnThisModule = yes + ). + +%---------------------% :- func old_status_is_imported(old_import_status) = bool. old_status_is_imported(Status) = bool.not(old_status_defined_in_this_module(Status)). -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% type_status_defined_in_this_module(type_status(OldStatus)) = old_status_defined_in_this_module(OldStatus). @@ -459,10 +672,26 @@ mode_status_defined_in_this_module(ModeStatus) = IsDefnThisModule :- pred_status_defined_in_this_module(pred_status(OldStatus)) = old_status_defined_in_this_module(OldStatus). -typeclass_status_defined_in_this_module(typeclass_status(OldStatus)) = - old_status_defined_in_this_module(OldStatus). -instance_status_defined_in_this_module(instance_status(OldStatus)) = - old_status_defined_in_this_module(OldStatus). + +typeclass_status_defined_in_this_module(Status) = IsDefnThisModule :- + ( + Status = typeclass_defined_in_this_module(_Export), + IsDefnThisModule = yes + ; + Status = typeclass_defined_in_other_module(_Import), + IsDefnThisModule = no + ). + +instance_status_defined_in_this_module(Status) = IsDefnThisModule :- + ( + Status = instance_defined_in_this_module(_Export), + IsDefnThisModule = yes + ; + Status = instance_defined_in_other_module(_Import), + IsDefnThisModule = no + ). + +%---------------------% :- func old_status_defined_in_this_module(old_import_status) = bool. @@ -478,7 +707,7 @@ old_status_defined_in_this_module(status_pseudo_exported) = yes. old_status_defined_in_this_module(status_exported_to_submodules) = yes. old_status_defined_in_this_module(status_local) = yes. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% type_status_defined_in_impl_section(type_status(OldStatus)) = old_status_defined_in_impl_section(OldStatus). @@ -495,25 +724,22 @@ mode_status_defined_in_impl_section(ModeStatus) = IsDefnImplSection :- pred_status_defined_in_impl_section(pred_status(OldStatus)) = old_status_defined_in_impl_section(OldStatus). -typeclass_status_defined_in_impl_section(typeclass_status(OldStatus)) = - old_status_defined_in_impl_section(OldStatus). -instance_status_defined_in_impl_section(instance_status(OldStatus)) = - old_status_defined_in_impl_section(OldStatus). -:- func old_status_defined_in_impl_section(old_import_status) = bool. +typeclass_status_defined_in_impl_section(TypeClassStatus) = InImplSection :- + OldStatus = new_typeclass_status_to_old(TypeClassStatus), + OldInImplSection = old_status_defined_in_impl_section(OldStatus), + NewInImplSection = + new_typeclass_status_defined_in_impl_section(TypeClassStatus), + InImplSection = return_if_agreed(OldInImplSection, NewInImplSection). -old_status_defined_in_impl_section(status_abstract_exported) = yes. -old_status_defined_in_impl_section(status_exported_to_submodules) = yes. -old_status_defined_in_impl_section(status_local) = yes. -old_status_defined_in_impl_section(status_opt_imported) = no. -old_status_defined_in_impl_section(status_abstract_imported) = no. -old_status_defined_in_impl_section(status_pseudo_imported) = no. -old_status_defined_in_impl_section(status_exported) = no. -old_status_defined_in_impl_section(status_opt_exported) = yes. -old_status_defined_in_impl_section(status_pseudo_exported) = no. -old_status_defined_in_impl_section(status_external(Status)) = - old_status_defined_in_impl_section(Status). -old_status_defined_in_impl_section(status_imported(_ImportLocn)) = no. +instance_status_defined_in_impl_section(InstanceStatus) = InImplSection :- + OldStatus = new_instance_status_to_old(InstanceStatus), + OldInImplSection = old_status_defined_in_impl_section(OldStatus), + NewInImplSection = + new_instance_status_defined_in_impl_section(InstanceStatus), + InImplSection = return_if_agreed(OldInImplSection, NewInImplSection). + +%---------------------% :- func instmode_status_defined_in_impl_section(new_instmode_status) = bool. @@ -535,18 +761,130 @@ instmode_status_defined_in_impl_section(NewInstModeStatus) NewIsDefnImplSection = no ). -%-----------------------------------------------------------------------------% +%---------------------% + +:- func new_typeclass_status_defined_in_impl_section(new_typeclass_status) + = bool. + +new_typeclass_status_defined_in_impl_section(Status) = IsDefnImplSection :- + ( + Status = typeclass_defined_in_this_module(Export), + ( + ( Export = typeclass_export_gen_none_sub_none + ; Export = typeclass_export_gen_none_sub_full + ; Export = typeclass_export_gen_abs_sub_full + ), + IsDefnImplSection = yes + ; + Export = typeclass_export_gen_full_sub_full, + IsDefnImplSection = no + ) + ; + Status = typeclass_defined_in_other_module(_Import), + IsDefnImplSection = no + ). + +%---------------------% + +:- func new_instance_status_defined_in_impl_section(new_instance_status) + = bool. + +new_instance_status_defined_in_impl_section(Status) = IsDefnImplSection :- + ( + Status = instance_defined_in_this_module(Export), + ( + ( Export = instance_export_gen_none_sub_none + ; Export = instance_export_gen_none_sub_abs + ; Export = instance_export_gen_abs_sub_abs + ), + IsDefnImplSection = yes + ; + Export = instance_export_full_opt, + IsDefnImplSection = no + ) + ; + Status = instance_defined_in_other_module(_Import), + IsDefnImplSection = no + ). + +%---------------------% + +:- func old_status_defined_in_impl_section(old_import_status) = bool. + +old_status_defined_in_impl_section(status_abstract_exported) = yes. +old_status_defined_in_impl_section(status_exported_to_submodules) = yes. +old_status_defined_in_impl_section(status_local) = yes. +old_status_defined_in_impl_section(status_opt_imported) = no. +old_status_defined_in_impl_section(status_abstract_imported) = no. +old_status_defined_in_impl_section(status_pseudo_imported) = no. +old_status_defined_in_impl_section(status_exported) = no. +old_status_defined_in_impl_section(status_opt_exported) = yes. +old_status_defined_in_impl_section(status_pseudo_exported) = no. +old_status_defined_in_impl_section(status_external(Status)) = + old_status_defined_in_impl_section(Status). +old_status_defined_in_impl_section(status_imported(_ImportLocn)) = no. + +%---------------------------------------------------------------------------% type_make_status_abstract(type_status(Status), type_status(AbstractStatus)) :- old_make_status_abstract(Status, AbstractStatus). + pred_make_status_abstract(pred_status(Status), pred_status(AbstractStatus)) :- old_make_status_abstract(Status, AbstractStatus). -typeclass_make_status_abstract(typeclass_status(Status), - typeclass_status(AbstractStatus)) :- - old_make_status_abstract(Status, AbstractStatus). -instance_make_status_abstract(instance_status(Status), - instance_status(AbstractStatus)) :- - old_make_status_abstract(Status, AbstractStatus). + +typeclass_make_status_abstract(Status, AbstractStatus) :- + OldStatus = new_typeclass_status_to_old(Status), + old_make_status_abstract(OldStatus, OldAbstractStatus), + new_typeclass_status_make_status_abstract(Status, NewAbstractStatus), + OldNewAbstractStatus = new_typeclass_status_to_old(NewAbstractStatus), + ( if OldAbstractStatus = OldNewAbstractStatus then + AbstractStatus = NewAbstractStatus + else + unexpected($pred, "disagreement") + ). + +%---------------------% + +:- pred new_typeclass_status_make_status_abstract(new_typeclass_status::in, + new_typeclass_status::out) is det. + +new_typeclass_status_make_status_abstract(Status, AbstractStatus) :- + ( + Status = typeclass_defined_in_this_module(Export), + ( + ( Export = typeclass_export_gen_none_sub_none + ; Export = typeclass_export_gen_none_sub_full + ; Export = typeclass_export_gen_abs_sub_full + ), + AbstractStatus = Status + ; + Export = typeclass_export_gen_full_sub_full, + AbstractExport = typeclass_export_gen_abs_sub_full, + AbstractStatus = typeclass_defined_in_this_module(AbstractExport) + ) + ; + Status = typeclass_defined_in_other_module(Import), + ( + % XXX TYPECLASS It does not make sense to try to make + % typeclass_import_full_opt abstract. We could try throwing + % an exception whith typeclass_import_full_opt. + ( Import = typeclass_import_full_opt + ; Import = typeclass_import_abstract + ), + AbstractStatus = Status + ; + ( Import = typeclass_import_full_own_int + ; Import = typeclass_import_full_own_imp + ; Import = typeclass_import_full_int0_int + ; Import = typeclass_import_full_int0_imp + ; Import = typeclass_import_full_by_ancestor + ), + AbstractImport = typeclass_import_abstract, + AbstractStatus = typeclass_defined_in_other_module(AbstractImport) + ) + ). + +%---------------------% :- pred old_make_status_abstract(old_import_status::in, old_import_status::out) is det. @@ -560,7 +898,7 @@ old_make_status_abstract(Status, AbstractStatus) :- AbstractStatus = Status ). -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% type_combine_status(type_status(StatusA), type_status(StatusB), type_status(Status)) :- @@ -569,6 +907,7 @@ type_combine_status(type_status(StatusA), type_status(StatusB), else unexpected($pred, "unexpected status for type definition") ). + pred_combine_status(pred_status(StatusA), pred_status(StatusB), pred_status(Status)) :- ( if old_combine_status(StatusA, StatusB, CombinedStatus) then @@ -576,41 +915,234 @@ pred_combine_status(pred_status(StatusA), pred_status(StatusB), else unexpected($pred, "unexpected status for pred definition") ). -typeclass_combine_status(typeclass_status(StatusA), typeclass_status(StatusB), - typeclass_status(Status)) :- - ( if old_combine_status(StatusA, StatusB, CombinedStatus) then - Status = CombinedStatus + +typeclass_combine_status(StatusA, StatusB, Status) :- + ( if new_typeclass_combine_status(StatusA, StatusB, CombinedStatus) then + NewStatus = CombinedStatus else - unexpected($pred, "unexpected status for typeclass definition") - ). -instance_combine_status(instance_status(StatusA), instance_status(StatusB), - instance_status(Status)) :- - ( if old_combine_status(StatusA, StatusB, CombinedStatus) then - Status = CombinedStatus + unexpected($pred, "unexpected status for new typeclass definition") + ), + OldStatusA = new_typeclass_status_to_old(StatusA), + OldStatusB = new_typeclass_status_to_old(StatusB), + OldNewStatus = new_typeclass_status_to_old(NewStatus), + ( if old_combine_status(OldStatusA, OldStatusB, OldCombinedStatus) then + OldStatus = OldCombinedStatus else - unexpected($pred, "unexpected status for instance definition") + unexpected($pred, "unexpected status for old typeclass definition") + ), + ( if OldStatus = OldNewStatus then + Status = NewStatus + else + unexpected($pred, "disagreement") ). +instance_combine_status(StatusA, StatusB, Status) :- + ( if new_instance_combine_status(StatusA, StatusB, CombinedStatus) then + NewStatus = CombinedStatus + else + unexpected($pred, "unexpected status for new instance definition") + ), + OldStatusA = new_instance_status_to_old(StatusA), + OldStatusB = new_instance_status_to_old(StatusB), + OldNewStatus = new_instance_status_to_old(NewStatus), + ( if old_combine_status(OldStatusA, OldStatusB, OldCombinedStatus) then + OldStatus = OldCombinedStatus + else + unexpected($pred, "unexpected status for old instance definition") + ), + ( if OldStatus = OldNewStatus then + Status = NewStatus + else + unexpected($pred, "disagreement") + ). + +%---------------------% + +:- pred new_typeclass_combine_status(new_typeclass_status::in, + new_typeclass_status::in, new_typeclass_status::out) is semidet. + +new_typeclass_combine_status(StatusA, StatusB, Status) :- + require_complete_switch [StatusA] + ( + StatusA = typeclass_defined_in_other_module(ImportA), + StatusB = typeclass_defined_in_other_module(ImportB), + require_complete_switch [ImportA] + ( + ( ImportA = typeclass_import_full_own_int + ; ImportA = typeclass_import_full_own_imp + ; ImportA = typeclass_import_full_by_ancestor + ), + ( + ( ImportB = typeclass_import_full_own_int + ; ImportB = typeclass_import_full_own_imp + ; ImportB = typeclass_import_full_int0_int + ; ImportB = typeclass_import_full_int0_imp + ; ImportB = typeclass_import_full_by_ancestor + ), + Import = ImportB + ; + ImportB = typeclass_import_abstract, + % XXX TYPECLASS_STATUS I (zs) think this should be ImportA, + % but it does not seem to matter. + Import = typeclass_import_full_own_imp + ) + ; + ( ImportA = typeclass_import_full_int0_int + ; ImportA = typeclass_import_full_int0_imp + ; ImportA = typeclass_import_full_opt + ), + Import = ImportA + ; + ImportA = typeclass_import_abstract, + require_complete_switch [ImportB] + ( + ( ImportB = typeclass_import_full_own_int + ; ImportB = typeclass_import_full_own_imp + ; ImportB = typeclass_import_full_int0_int + ; ImportB = typeclass_import_full_int0_imp + ; ImportB = typeclass_import_full_by_ancestor + ), + Import = ImportB + ; + ( ImportB = typeclass_import_full_opt + ; ImportB = typeclass_import_abstract + ), + Import = ImportA + ) + ), + Status = typeclass_defined_in_other_module(Import) + ; + StatusA = typeclass_defined_in_other_module(ImportA), + StatusB = typeclass_defined_in_this_module(ExportB), + % XXX TYPECLASS_STATUS This combination should not be allowed. + ( + ( ImportA = typeclass_import_full_own_int + ; ImportA = typeclass_import_full_own_imp + ; ImportA = typeclass_import_full_by_ancestor + ), + ( + ExportB = typeclass_export_gen_none_sub_none, + Import = typeclass_import_full_own_imp, + Status = typeclass_defined_in_other_module(Import) + ; + ExportB = typeclass_export_gen_abs_sub_full, + Export = typeclass_export_gen_abs_sub_full, + Status = typeclass_defined_in_this_module(Export) + ; + ExportB = typeclass_export_gen_full_sub_full, + Export = typeclass_export_gen_full_sub_full, + Status = typeclass_defined_in_this_module(Export) + ) + ) + ; + StatusA = typeclass_defined_in_this_module(ExportA), + StatusB = typeclass_defined_in_this_module(ExportB), + require_complete_switch [ExportA] + ( + ExportA = typeclass_export_gen_none_sub_none, + Export = ExportB + ; + ExportA = typeclass_export_gen_none_sub_full, + ( + ExportB = typeclass_export_gen_none_sub_none, + % XXX TYPECLASS_STATUS This ExportA/ExportB combination + % should never occur. + Export = typeclass_export_gen_none_sub_full + ; + ( ExportB = typeclass_export_gen_none_sub_full + ; ExportB = typeclass_export_gen_abs_sub_full + ; ExportB = typeclass_export_gen_full_sub_full + ), + Export = ExportB + ) + ; + ExportA = typeclass_export_gen_full_sub_full, + Export = typeclass_export_gen_full_sub_full + ; + ExportA = typeclass_export_gen_abs_sub_full, + ( if ExportB = typeclass_export_gen_full_sub_full then + Export = typeclass_export_gen_full_sub_full + else + Export = typeclass_export_gen_abs_sub_full + ) + ), + Status = typeclass_defined_in_this_module(Export) + ; + StatusA = typeclass_defined_in_this_module(ExportA), + StatusB = typeclass_defined_in_other_module(_ImportB), + % XXX TYPECLASS_STATUS This combination should not be allowed. + Status = typeclass_defined_in_this_module(ExportA) + ). + +%---------------------% + +:- pred new_instance_combine_status(new_instance_status::in, + new_instance_status::in, new_instance_status::out) is semidet. + +new_instance_combine_status(StatusA, StatusB, Status) :- + require_complete_switch [StatusA] + ( + StatusA = instance_defined_in_other_module(ImportA), + StatusB = instance_defined_in_other_module(_ImportB), + Status = instance_defined_in_other_module(ImportA) + ; + StatusA = instance_defined_in_this_module(ExportA), + StatusB = instance_defined_in_this_module(ExportB), + require_complete_switch [ExportA] + ( + ExportA = instance_export_gen_none_sub_none, + Export = ExportB + ; + ExportA = instance_export_gen_none_sub_abs, + ( + ExportB = instance_export_gen_none_sub_none, + % XXX INSTANCE_STATUS This ExportA/ExportB combination + % should never occur. + Export = instance_export_gen_none_sub_abs + ; + ( ExportB = instance_export_gen_none_sub_abs + ; ExportB = instance_export_gen_abs_sub_abs + ; ExportB = instance_export_full_opt + ), + Export = ExportB + ) + ; + ExportA = instance_export_gen_abs_sub_abs, + ( if ExportB = instance_export_full_opt then + Export = instance_export_full_opt + else + Export = instance_export_gen_abs_sub_abs + ) + ; + ExportA = instance_export_full_opt, + Export = instance_export_full_opt + ), + Status = instance_defined_in_this_module(Export) + ; + StatusA = instance_defined_in_this_module(ExportA), + StatusB = instance_defined_in_other_module(_ImportB), + % XXX INSTANCE_STATUS This combination should not be allowed. + Status = instance_defined_in_this_module(ExportA) + ). + +%---------------------% + :- pred old_combine_status(old_import_status::in, old_import_status::in, old_import_status::out) is semidet. old_combine_status(StatusA, StatusB, Status) :- - % This switch on StatusA does not cover - % status_external - % status_opt_exported - % status_pseudo_exported - % status_pseudo_imported + require_complete_switch [StatusA] ( - StatusA = status_imported(ImportLocn), - require_complete_switch [ImportLocn] + StatusA = status_imported(ImportLocnA), + require_complete_switch [ImportLocnA] ( - ( ImportLocn = import_locn_implementation - ; ImportLocn = import_locn_interface - ; ImportLocn = import_locn_import_by_ancestor + ( ImportLocnA = import_locn_implementation + ; ImportLocnA = import_locn_interface + ; ImportLocnA = import_locn_import_by_ancestor ), ( - StatusB = status_imported(Section), - Status = status_imported(Section) + StatusB = status_imported(SectionB), + Status = status_imported(SectionB) ; StatusB = status_local, Status = status_imported(import_locn_implementation) @@ -628,10 +1160,10 @@ old_combine_status(StatusA, StatusB, Status) :- Status = status_abstract_exported ) ; - ImportLocn = import_locn_ancestor_int0_interface, + ImportLocnA = import_locn_ancestor_int0_interface, Status = status_imported(import_locn_ancestor_int0_interface) ; - ImportLocn = import_locn_ancestor_int0_implementation, + ImportLocnA = import_locn_ancestor_int0_implementation, Status = status_imported(import_locn_ancestor_int0_implementation) ) ; @@ -665,6 +1197,13 @@ old_combine_status(StatusA, StatusB, Status) :- else Status = status_abstract_exported ) + ; + ( StatusA = status_external(_) + ; StatusA = status_opt_exported + ; StatusA = status_pseudo_exported + ; StatusA = status_pseudo_imported + ), + fail ). :- pred old_combine_status_local(old_import_status::in, old_import_status::out) @@ -679,7 +1218,7 @@ old_combine_status_local(status_opt_imported, status_local). old_combine_status_local(status_abstract_imported, status_local). old_combine_status_local(status_abstract_exported, status_abstract_exported). -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% item_mercury_status_to_type_status(ItemMercuryStatus, TypeStatus) :- item_mercury_status_to_old_import_status(ItemMercuryStatus, @@ -695,20 +1234,31 @@ item_mercury_status_to_mode_status(ItemMercuryStatus, ModeStatus) :- ModeStatus = mode_status(InstModeStatus). item_mercury_status_to_typeclass_status(ItemMercuryStatus, TypeClassStatus) :- + item_mercury_status_to_new_typeclass_status(ItemMercuryStatus, + NewTypeClassStatus), item_mercury_status_to_old_import_status(ItemMercuryStatus, OldImportStatus), - TypeClassStatus = typeclass_status(OldImportStatus). + OldNewTypeClassStatus = new_typeclass_status_to_old(NewTypeClassStatus), + ( if OldNewTypeClassStatus = OldImportStatus then + TypeClassStatus = NewTypeClassStatus + else + unexpected($pred, "disagreement") + ). item_mercury_status_to_instance_status(ItemMercuryStatus, InstanceStatus) :- - item_mercury_status_to_old_import_status(ItemMercuryStatus, - OldImportStatus), - InstanceStatus = instance_status(OldImportStatus). + % We cannot do the same sanity check for instances as for typeclasses, + % because the relationship between the values of the instance_import type + % and of the item_import type is one-to-many, not one-to-one. + item_mercury_status_to_new_instance_status(ItemMercuryStatus, + InstanceStatus). item_mercury_status_to_pred_status(ItemMercuryStatus, PredStatus) :- item_mercury_status_to_old_import_status(ItemMercuryStatus, OldImportStatus), PredStatus = pred_status(OldImportStatus). +%---------------------% + :- pred item_mercury_status_to_instmode_status(item_mercury_status::in, new_instmode_status::out) is det. @@ -741,6 +1291,97 @@ item_mercury_status_to_instmode_status(ItemMercuryStatus, InstModeStatus) :- InstModeStatus = instmode_defined_in_other_module(InstImport) ). +%---------------------% + +:- pred item_mercury_status_to_new_typeclass_status(item_mercury_status::in, + new_typeclass_status::out) is det. + +item_mercury_status_to_new_typeclass_status(ItemMercuryStatus, + TypeClassStatus) :- + ( + ItemMercuryStatus = item_defined_in_this_module(ItemExport), + ( + ItemExport = item_export_nowhere, + TypeClassExport = typeclass_export_gen_none_sub_none + ; + ItemExport = item_export_only_submodules, + TypeClassExport = typeclass_export_gen_none_sub_full + ; + ItemExport = item_export_anywhere, + TypeClassExport = typeclass_export_gen_full_sub_full + ), + TypeClassStatus = typeclass_defined_in_this_module(TypeClassExport) + ; + ItemMercuryStatus = item_defined_in_other_module(ItemImport), + ( + ItemImport = item_import_int_concrete(ImportLocn), + require_complete_switch [ImportLocn] + ( + ImportLocn = import_locn_interface, + TypeClassImport = typeclass_import_full_own_int + ; + ImportLocn = import_locn_implementation, + TypeClassImport = typeclass_import_full_own_imp + ; + ImportLocn = import_locn_ancestor_int0_interface, + TypeClassImport = typeclass_import_full_int0_int + ; + ImportLocn = import_locn_ancestor_int0_implementation, + TypeClassImport = typeclass_import_full_int0_imp + ; + ImportLocn = import_locn_import_by_ancestor, + TypeClassImport = typeclass_import_full_by_ancestor + ) + ; + ItemImport = item_import_int_abstract, + TypeClassImport = typeclass_import_abstract + ; + ItemImport = item_import_opt_int, + TypeClassImport = typeclass_import_full_opt + ), + TypeClassStatus = typeclass_defined_in_other_module(TypeClassImport) + ). + +%---------------------% + +:- pred item_mercury_status_to_new_instance_status(item_mercury_status::in, + new_instance_status::out) is det. + +item_mercury_status_to_new_instance_status(ItemMercuryStatus, + InstanceStatus) :- + ( + ItemMercuryStatus = item_defined_in_this_module(ItemExport), + ( + ItemExport = item_export_nowhere, + InstanceExport = instance_export_gen_none_sub_none + ; + ItemExport = item_export_only_submodules, + InstanceExport = instance_export_gen_none_sub_abs + ; + ItemExport = item_export_anywhere, + InstanceExport = instance_export_gen_abs_sub_abs + ), + InstanceStatus = instance_defined_in_this_module(InstanceExport) + ; + ItemMercuryStatus = item_defined_in_other_module(ItemImport), + ( + ( ItemImport = item_import_int_concrete(_ImportLocn) + ; ItemImport = item_import_int_abstract + ), + % *All* instances we get from interface files are imported + % abstract, even the ones we get from implementation sections. + % The only instances we get in concrete form are ... + InstanceImport = instance_import_abstract + ; + ItemImport = item_import_opt_int, + % ... from .opt files. + InstanceImport = instance_import_full_opt + ), + InstanceStatus = instance_defined_in_other_module(InstanceImport) + ). + +%---------------------% + :- pred item_mercury_status_to_old_import_status(item_mercury_status::in, old_import_status::out) is det. @@ -771,6 +1412,90 @@ item_mercury_status_to_old_import_status(ItemMercuryStatus, OldImportStatus) :- ) ). -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +new_typeclass_status_to_old(New) = Old :- + ( + New = typeclass_defined_in_this_module(Export), + ( + Export = typeclass_export_gen_none_sub_none, + Old = status_local + ; + Export = typeclass_export_gen_none_sub_full, + Old = status_exported_to_submodules + ; + Export = typeclass_export_gen_full_sub_full, + Old = status_exported + ; + Export = typeclass_export_gen_abs_sub_full, + Old = status_abstract_exported + ) + ; + New = typeclass_defined_in_other_module(Import), + ( + Import = typeclass_import_full_own_int, + Old = status_imported(import_locn_interface) + ; + Import = typeclass_import_full_own_imp, + Old = status_imported(import_locn_implementation) + ; + Import = typeclass_import_full_int0_int, + Old = status_imported(import_locn_ancestor_int0_interface) + ; + Import = typeclass_import_full_int0_imp, + Old = status_imported(import_locn_ancestor_int0_implementation) + ; + Import = typeclass_import_full_by_ancestor, + Old = status_imported(import_locn_import_by_ancestor) + ; + Import = typeclass_import_full_opt, + Old = status_opt_imported + ; + Import = typeclass_import_abstract, + Old = status_abstract_imported + ) + ). + +new_instance_status_to_old(New) = Old :- + ( + New = instance_defined_in_this_module(Export), + ( + Export = instance_export_gen_none_sub_none, + Old = status_local + ; + Export = instance_export_gen_none_sub_abs, + Old = status_exported_to_submodules + ; + Export = instance_export_gen_abs_sub_abs, + Old = status_exported + ; + Export = instance_export_full_opt, + Old = status_opt_exported + ) + ; + New = instance_defined_in_other_module(Import), + ( + Import = instance_import_full_opt, + Old = status_opt_imported + ; + Import = instance_import_abstract, + Old = status_abstract_imported + ) + ). + +:- type instance_import + ---> instance_import_full_opt + ; instance_import_abstract. + +:- func return_if_agreed(T, T) = T. + +return_if_agreed(Old, New) = Agreed :- + ( if Old = New then + Agreed = Old + else + unexpected($pred, "disagreement") + ). + +%---------------------------------------------------------------------------% :- end_module hlds.status. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m index d7260ec19..97ad53b97 100644 --- a/compiler/xml_documentation.m +++ b/compiler/xml_documentation.m @@ -915,7 +915,10 @@ mode_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- typeclass_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if typeclass_status_defined_in_impl_section(Status) = yes then - ( if Status = typeclass_status(status_abstract_exported) then + ( if + Status = typeclass_defined_in_this_module(Export), + Export = typeclass_export_gen_abs_sub_full + then Visibility = "abstract" else Visibility = "implementation" @@ -929,7 +932,9 @@ typeclass_visibility_to_xml(Status) = instance_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if instance_status_defined_in_impl_section(Status) = yes then - ( if Status = instance_status(status_abstract_exported) then + ( if Status = + instance_defined_in_this_module(instance_export_gen_abs_sub_abs) + then Visibility = "abstract" else Visibility = "implementation"