[m-rev.] for review: Make subtypes share standard ordering with base type.
Peter Wang
novalazy at gmail.com
Thu Apr 1 17:36:49 AEDT 2021
doc/reference_manual.texi:
Define the standard ordering of a subtype to be the same as that of
its base type.
Suggest that subtype constructors should be declared in the same
order as in the supertype.
compiler/add_type.m:
Warn if a subtype's constructors are declared in a different
relative order to the supertype.
compiler/unify_proc.m
Generate unify/compare procs for subtypes that cast to the base type
then call the unify/compare proc for the base type. This was
previously done only for the high-level data representation.
tests/hard_coded/Mmakefile:
tests/hard_coded/subtype_order.exp:
tests/hard_coded/subtype_order.m:
tests/warnings/Mmakefile:
tests/warnings/subtype_order.exp:
tests/warnings/subtype_order.m:
Add test cases.
diff --git a/compiler/add_type.m b/compiler/add_type.m
index b9c925f48..f2a7d5f47 100644
--- a/compiler/add_type.m
+++ b/compiler/add_type.m
@@ -69,6 +69,7 @@
:- import_module parse_tree.prog_type_subst.
:- import_module bool.
+:- import_module edit_seq.
:- import_module int.
:- import_module map.
:- import_module maybe.
@@ -1493,7 +1494,7 @@ special_type_ctor_not_du(TypeCtor) :-
list(mer_type)::in, found_invalid_type::in, found_invalid_type::out,
list(error_spec)::in, list(error_spec)::out) is det.
-check_subtype_ctors(TypeTable, _TypeCtor, TypeDefn, TypeBody,
+check_subtype_ctors(TypeTable, TypeCtor, TypeDefn, TypeBody,
SuperTypeCtor, SuperTypeDefn, SuperTypeBody, SuperTypeArgs,
!FoundInvalidType, !Specs) :-
hlds_data.get_type_defn_tvarset(TypeDefn, TVarSet0),
@@ -1523,7 +1524,12 @@ check_subtype_ctors(TypeTable, _TypeCtor, TypeDefn, TypeBody,
foldl2(
check_subtype_ctor(TypeTable, NewTVarSet, TypeStatus,
SuperTypeCtor, SuperCtors),
- Ctors, !FoundInvalidType, !Specs).
+ Ctors, !FoundInvalidType, !Specs),
+
+ % Check order of subtype constructors relative to supertype constructors.
+ hlds_data.get_type_defn_context(TypeDefn, Context),
+ check_subtype_ctors_order(TypeCtor, Ctors, SuperTypeCtor, SuperCtors,
+ Context, !Specs).
:- pred check_subtype_ctor(type_table::in, tvarset::in, type_status::in,
type_ctor::in, list(constructor)::in, constructor::in,
@@ -1877,6 +1883,76 @@ check_subtype_ctor_exist_constraints(CtorSymNameArity,
%---------------------%
+:- pred check_subtype_ctors_order(type_ctor::in, list(constructor)::in,
+ type_ctor::in, list(constructor)::in, prog_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+check_subtype_ctors_order(TypeCtor, Ctors, SuperTypeCtor, SuperCtors, Context,
+ !Specs) :-
+ compute_subtype_ctors_out_of_order(Ctors, SuperCtors, CtorsOutOfOrder),
+ (
+ CtorsOutOfOrder = []
+ ;
+ CtorsOutOfOrder = [_ | _],
+ CtorsOutOfOrderPieces =
+ list.map(func(SNA) = [unqual_sym_name_arity(SNA)],
+ CtorsOutOfOrder),
+ Pieces = [words("Warning:"), unqual_type_ctor(TypeCtor),
+ words("declares the following constructors in a"),
+ words("different order to the supertype"),
+ unqual_type_ctor(SuperTypeCtor), suffix(":"),
+ nl_indent_delta(1)] ++
+ component_list_to_line_pieces(CtorsOutOfOrderPieces, []) ++
+ [nl_indent_delta(-1)],
+ Spec = simplest_spec($pred, severity_warning,
+ phase_parse_tree_to_hlds, Context, Pieces),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+:- pred compute_subtype_ctors_out_of_order(list(constructor)::in,
+ list(constructor)::in, list(sym_name_arity)::out) is det.
+
+compute_subtype_ctors_out_of_order(Ctors, SuperCtors, CtorsOutOfOrder) :-
+ (
+ Ctors = [],
+ CtorsOutOfOrder = []
+ ;
+ Ctors = [_],
+ CtorsOutOfOrder = []
+ ;
+ Ctors = [_, _ | _],
+ list.map(ctor_to_unqual_sym_name_arity, Ctors, CtorNames0),
+ list.map(ctor_to_unqual_sym_name_arity, SuperCtors, SuperCtorNames),
+ list.filter(list.contains(SuperCtorNames), CtorNames0, CtorNames),
+ EditParams = edit_params(1, 1, 1),
+ find_shortest_edit_seq(EditParams, SuperCtorNames, CtorNames, EditSeq),
+ list.filter_map(edit_to_ctor_out_of_order, EditSeq, CtorsOutOfOrder)
+ ).
+
+:- pred ctor_to_unqual_sym_name_arity(constructor::in, sym_name_arity::out)
+ is det.
+
+ctor_to_unqual_sym_name_arity(Ctor, UnqualNameArity) :-
+ Ctor = ctor(_, _, SymName, _, Arity, _),
+ UnqualName = unqualify_name(SymName),
+ UnqualNameArity = sym_name_arity(unqualified(UnqualName), Arity).
+
+:- pred edit_to_ctor_out_of_order(edit(sym_name_arity)::in,
+ sym_name_arity::out) is semidet.
+
+edit_to_ctor_out_of_order(Edit, CtorName) :-
+ require_complete_switch [Edit]
+ (
+ Edit = delete(_),
+ fail
+ ;
+ Edit = insert(_, CtorName)
+ ;
+ Edit = replace(_, CtorName)
+ ).
+
+%---------------------%
+
:- pred rename_and_rec_subst_in_constructor(tvar_renaming::in, tsubst::in,
constructor::in, constructor::out) is det.
diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m
index 9bda36ddd..bbcb09da2 100644
--- a/compiler/unify_proc.m
+++ b/compiler/unify_proc.m
@@ -242,12 +242,12 @@ generate_unify_proc_body(SpecDefnInfo, X, Y, Clauses, !Info) :-
),
( if
MaybeSuperType = yes(SuperType),
- compilation_target_uses_high_level_data(ModuleInfo),
TVarSet = SpecDefnInfo ^ spdi_tvarset,
get_du_base_type(ModuleInfo, TVarSet, SuperType, BaseType)
then
- % In high-level data grades, subtypes use the same class
- % as their base type constructor.
+ % Unify after casting to base type.
+ % This is necessary in high-level data grades,
+ % and saves some code in low-level data grades.
generate_unify_proc_body_eqv(Context, BaseType, X, Y, Clause,
!Info),
Clauses = [Clause]
@@ -997,19 +997,10 @@ generate_compare_proc_body(SpecDefnInfo, Res, X, Y, Clause, !Info) :-
),
( if
MaybeSuperType = yes(SuperType),
- compilation_target_uses_high_level_data(ModuleInfo),
TVarSet = SpecDefnInfo ^ spdi_tvarset,
get_du_base_type(ModuleInfo, TVarSet, SuperType, BaseType)
then
- % In high-level data grades, subtypes use the same class
- % as their base type constructor.
- %
- % XXX SUBTYPE This produces the wrong ordering for subtypes
- % whose functors are declared in a different order from their
- % base types. However, it is probably better to define the
- % standard ordering on subtypes to be the same as their base
- % types, and report a warning if the functor order in a
- % subtype definition differs.
+ % Compare after casting to base type.
generate_compare_proc_body_eqv(Context, BaseType, Res, X, Y,
Clause, !Info)
else
@@ -2564,13 +2555,6 @@ generate_index_du_case(SpecDefnInfo, X, Index, CtorRepn, Goal, !N, !Info) :-
% Utility predicates.
%
-:- pred compilation_target_uses_high_level_data(module_info::in) is semidet.
-
-compilation_target_uses_high_level_data(ModuleInfo) :-
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- compilation_target_high_level_data(Target) = yes.
-
:- pred get_du_base_type(module_info::in, tvarset::in, mer_type::in,
mer_type::out) is det.
diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi
index bf3717947..7c7497d7e 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -2551,7 +2551,8 @@ Any universally quantified type variable that occurs in @var{body}
must occur in @var{subtype}.
The constructor definitions must be a
-subset of the constructors of the supertype.
+subset of the constructors of the supertype;
+they should appear in the same relative order as in the supertype definition.
If the supertype @samp{t} has constructor @samp{f(T1, ..., Tn)} then
a subtype @samp{s =< t} may have a constructor @samp{f(S1, ..., Sn)}.
For each @var{Si}, it must be that @samp{Si =< Ti}.
@@ -3055,7 +3056,7 @@ For tuple types, corresponding arguments are compared,
with the first argument being the most significant,
then the second, and so on.
-For discriminated union types,
+For discriminated union types (other than subtypes),
if both values have the same principal constructor
then corresponding arguments are compared in order,
with the first argument being the most significant,
@@ -3070,6 +3071,11 @@ the outcomes of comparisons are decided
by user's chosen foreign language representations,
using the rules of the foreign language.
+For subtypes, the two values compare as though
+converted to the base type.
+The ordering of constructors in a subtype definition
+does not affect the standard ordering.
+
@node Modes
@chapter Modes
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 23ed2129e..a925da9d3 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -393,6 +393,7 @@ ORDINARY_PROGS = \
string_well_formed \
string_well_formed_utf8 \
subtype_abstract \
+ subtype_order \
subtype_pack \
subtype_rtti \
sv_nested_closures \
diff --git a/tests/hard_coded/subtype_order.exp b/tests/hard_coded/subtype_order.exp
new file mode 100644
index 000000000..867d1576c
--- /dev/null
+++ b/tests/hard_coded/subtype_order.exp
@@ -0,0 +1,2 @@
+[lemon, lime, orange(123), pomelo, tangelo]
+[lemon, lime, orange(123), pomelo, tangelo]
diff --git a/tests/hard_coded/subtype_order.m b/tests/hard_coded/subtype_order.m
new file mode 100644
index 000000000..51633ed37
--- /dev/null
+++ b/tests/hard_coded/subtype_order.m
@@ -0,0 +1,43 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module subtype_order.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type fruit
+ ---> apple(int)
+ ; banana
+ ; lemon
+ ; lime
+ ; orange(int)
+ ; peach
+ ; pear
+ ; pomelo
+ ; tangelo
+ ; tomato.
+
+:- type citrus =< fruit
+ ---> pomelo
+ ; lime
+ ; tangelo
+ ; orange(int)
+ ; lemon.
+
+main(!IO) :-
+ L1 = [orange(123), lime, tangelo, pomelo, lemon] : list(fruit),
+ L2 = [orange(123), lime, tangelo, pomelo, lemon] : list(citrus),
+ list.sort(L1, S1),
+ list.sort(L2, S2),
+ io.print_line(S1, !IO),
+ io.print_line(S2, !IO).
diff --git a/tests/warnings/Mmakefile b/tests/warnings/Mmakefile
index c68aa1f54..31b075054 100644
--- a/tests/warnings/Mmakefile
+++ b/tests/warnings/Mmakefile
@@ -14,6 +14,7 @@ COMPILE_PROGS = \
non_term_user_special \
pragma_term_conflict \
term_indirect_warning \
+ subtype_order \
warn_dead_procs \
warn_dead_procs_trace
diff --git a/tests/warnings/subtype_order.exp b/tests/warnings/subtype_order.exp
new file mode 100644
index 000000000..68788f5c7
--- /dev/null
+++ b/tests/warnings/subtype_order.exp
@@ -0,0 +1,5 @@
+subtype_order.m:030: Warning: `citrus'/0 declares the following constructors in
+subtype_order.m:030: a different order to the supertype `fruit'/0:
+subtype_order.m:030: `pomelo'/0,
+subtype_order.m:030: `orange'/1,
+subtype_order.m:030: `lemon'/0
diff --git a/tests/warnings/subtype_order.m b/tests/warnings/subtype_order.m
new file mode 100644
index 000000000..51633ed37
--- /dev/null
+++ b/tests/warnings/subtype_order.m
@@ -0,0 +1,43 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module subtype_order.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type fruit
+ ---> apple(int)
+ ; banana
+ ; lemon
+ ; lime
+ ; orange(int)
+ ; peach
+ ; pear
+ ; pomelo
+ ; tangelo
+ ; tomato.
+
+:- type citrus =< fruit
+ ---> pomelo
+ ; lime
+ ; tangelo
+ ; orange(int)
+ ; lemon.
+
+main(!IO) :-
+ L1 = [orange(123), lime, tangelo, pomelo, lemon] : list(fruit),
+ L2 = [orange(123), lime, tangelo, pomelo, lemon] : list(citrus),
+ list.sort(L1, S1),
+ list.sort(L2, S2),
+ io.print_line(S1, !IO),
+ io.print_line(S2, !IO).
--
2.30.0
More information about the reviews
mailing list