diff --git a/compiler/type_assign.m b/compiler/type_assign.m index 7f66845ae..04c4e1e36 100644 --- a/compiler/type_assign.m +++ b/compiler/type_assign.m @@ -130,20 +130,19 @@ it_from_type :: mer_type, it_to_type :: mer_type ) - ; cannot_coerce_type_vars( - % At least one of these must be a type_var. - cctv_from_type :: mer_type, - cctv_to_type :: mer_type - ) ; cannot_unify_type_vars( cutv_from_type :: mer_type, cutv_to_type :: mer_type ) ; non_du_type_ctor( - % The from-type and the to-type have the same base type_ctor, - % but this base type_ctor is not a du type. + % At least one of these types is not a du type. + % For any non-du type, the description will state + % what kind of non-du type it is, such as "builtin type". + % For any du type, the description will be the empty string. ndtc_from_type :: mer_type, - ndtc_to_type :: mer_type + ndtc_from_type_desc :: string, + ndtc_to_type :: mer_type, + ndtc_to_type_desc :: string ) ; should_be_invariant_arg( % The from-type and to-type are different, even though diff --git a/compiler/typecheck_coerce.m b/compiler/typecheck_coerce.m index 06d8052c7..90decbc01 100644 --- a/compiler/typecheck_coerce.m +++ b/compiler/typecheck_coerce.m @@ -199,60 +199,172 @@ add_coerce_constraint(Coercion, !TypeAssign) :- typecheck_coerce_between_types(TypeTable, TVarSet, FromType, ToType, !TypeAssign, CoerceFails) :- % Type bindings must have been applied to FromType and ToType already. - compute_base_type(TypeTable, TVarSet, FromType, FromBaseType), - compute_base_type(TypeTable, TVarSet, ToType, ToBaseType), - ( if - type_to_ctor_and_args(FromBaseType, - FromBaseTypeCtor, FromBaseTypeArgTypes), - type_to_ctor_and_args(ToBaseType, - ToBaseTypeCtor, ToBaseTypeArgTypes) - then + classify_is_du_type(TypeTable, FromType, FromMaybeDuType), + classify_is_du_type(TypeTable, ToType, ToMaybeDuType), + ( + FromMaybeDuType = is_not_du_type(FromTypeDesc), + ToMaybeDuType = is_not_du_type(ToTypeDesc), + CoerceFail = non_du_type_ctor(FromType, FromTypeDesc, + ToType, ToTypeDesc), + CoerceFails = [CoerceFail] + ; + FromMaybeDuType = is_not_du_type(FromTypeDesc), + ToMaybeDuType = is_du_type(_), + CoerceFail = non_du_type_ctor(FromType, FromTypeDesc, + ToType, ""), + CoerceFails = [CoerceFail] + ; + FromMaybeDuType = is_du_type(_), + ToMaybeDuType = is_not_du_type(ToTypeDesc), + CoerceFail = non_du_type_ctor(FromType, "", + ToType, ToTypeDesc), + CoerceFails = [CoerceFail] + ; + FromMaybeDuType = is_du_type(FromDuTypeInfo), + ToMaybeDuType = is_du_type(ToDuTypeInfo), + compute_base_type_if_du_type(TypeTable, TVarSet, + FromDuTypeInfo, FromBaseTypeInfo), + compute_base_type_if_du_type(TypeTable, TVarSet, + ToDuTypeInfo, ToBaseTypeInfo), + FromBaseTypeInfo = du_type_info(FromBaseTypeCtor, FromBaseTypeArgTypes, + FromBaseTypeDefn, FromBaseTypeBodyDu), + ToBaseTypeInfo = du_type_info(ToBaseTypeCtor, ToBaseTypeArgTypes, + _ToBaseTypeDefn, _ToBaseTypeBodyDu), ( if % The input type and result type must have % the same base type constructor. BaseTypeCtor = FromBaseTypeCtor, BaseTypeCtor = ToBaseTypeCtor then + % Since FromBaseTypeCtor = ToBaseTypeCtor, the two type + % definitions and their bodies must be the same as well. + BaseTypeDefn = FromBaseTypeDefn, + BaseTypeBodyDu = FromBaseTypeBodyDu, % Check the variance of type arguments. - ( if - hlds_data.search_type_ctor_defn(TypeTable, BaseTypeCtor, - BaseTypeDefn), - hlds_data.get_type_defn_body(BaseTypeDefn, BaseTypeBody), - BaseTypeBody = hlds_du_type(BaseTypeBodyDu) - then - hlds_data.get_type_defn_tparams(BaseTypeDefn, BaseTypeParams), - compute_which_type_params_must_be_invariant(TypeTable, - BaseTypeCtor, BaseTypeBodyDu, BaseTypeParams, - InvariantTVars), - are_type_params_as_related_as_needed(TypeTable, TVarSet, - InvariantTVars, BaseTypeParams, - FromBaseTypeArgTypes, ToBaseTypeArgTypes, - !TypeAssign, [], CoerceFails) - else - CoerceFail = non_du_type_ctor(FromBaseType, ToBaseType), - CoerceFails = [CoerceFail] - ) + hlds_data.get_type_defn_tparams(BaseTypeDefn, BaseTypeParams), + compute_which_type_params_must_be_invariant(TypeTable, + BaseTypeCtor, BaseTypeBodyDu, BaseTypeParams, InvariantTVars), + are_type_params_as_related_as_needed(TypeTable, TVarSet, + InvariantTVars, BaseTypeParams, + FromBaseTypeArgTypes, ToBaseTypeArgTypes, + !TypeAssign, [], CoerceFails) else CoerceFail = different_base_types(FromType, FromBaseTypeCtor, ToType, ToBaseTypeCtor), CoerceFails = [CoerceFail] ) - else - CoerceFail = cannot_coerce_type_vars(FromType, ToType), - CoerceFails = [CoerceFail] ). -:- pred compute_base_type(type_table::in, tvarset::in, - mer_type::in, mer_type::out) is det. +%---------------------% -compute_base_type(TypeTable, TVarSet, Type, BaseType) :- - ( if - type_to_ctor_and_args(Type, TypeCtor, ArgTypes), - get_supertype(TypeTable, TVarSet, TypeCtor, ArgTypes, SuperType) - then - compute_base_type(TypeTable, TVarSet, SuperType, BaseType) - else - BaseType = Type +:- type maybe_du_type + ---> is_du_type(du_type_info) + % The type is a du type, with the given info. + ; is_not_du_type(string). + % The type is not a du type. The string describes + % what kind of type it is. The description allows code + % that generates diagnostics to add the article "a" in front + % of these pieces, and the plural suffix "s" after them. + +:- type du_type_info + ---> du_type_info(type_ctor, list(mer_type), + hlds_type_defn, type_body_du). + % This du type has the given type_ctor and argument types. + % The last two arguments give the whole, and the du body part, + % of the definition of the type_ctor. + + % If the given type is du type, return the empty list. Otherwise, + % return a description of what kind of non-du type it is. + % +:- pred classify_is_du_type(type_table::in, mer_type::in, + maybe_du_type::out) is det. + +classify_is_du_type(TypeTable, Type, MaybeDuType) :- + ( + Type = type_variable(_, _), + MaybeDuType = is_not_du_type("type variable") + ; + Type = defined_type(SymName, ArgTypes, _Kind), + list.length(ArgTypes, Arity), + TypeCtor = type_ctor(SymName, Arity), + ( if search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) then + get_type_defn_body(TypeDefn, TypeBody), + ( + TypeBody = hlds_du_type(TypeBodyDu), + DuType = du_type_info(TypeCtor, ArgTypes, + TypeDefn, TypeBodyDu), + MaybeDuType = is_du_type(DuType) + ; + TypeBody = hlds_eqv_type(_), + MaybeDuType = is_not_du_type("equivalence type") + ; + TypeBody = hlds_foreign_type(_), + MaybeDuType = is_not_du_type("foreign type") + ; + TypeBody = hlds_solver_type(_), + MaybeDuType = is_not_du_type("solver type") + ; + TypeBody = hlds_abstract_type(_), + MaybeDuType = is_not_du_type("abstract type") + ) + else + MaybeDuType = is_not_du_type("unknown type") + ) + ; + Type = builtin_type(_), + MaybeDuType = is_not_du_type("builtin type") + ; + Type = tuple_type(_, _), + % XXX This code preserves old behavior, but it prevents programs + % from coercing one tuple type to another, even if the tuple's + % argument types are coerceable. + MaybeDuType = is_not_du_type("tuple type") + ; + Type = higher_order_type(PorF, _, _, _), + ( + PorF = pf_function, + MaybeDuType = is_not_du_type("function type") + ; + PorF = pf_predicate, + MaybeDuType = is_not_du_type("predicate type") + ) + ; + Type = apply_n_type(_, _, _), + MaybeDuType = is_not_du_type("function type") + ; + Type = kinded_type(SubType, _), + classify_is_du_type(TypeTable, SubType, MaybeDuType) + ). + +%---------------------% + +:- pred compute_base_type_if_du_type(type_table::in, tvarset::in, + du_type_info::in, du_type_info::out) is det. + +compute_base_type_if_du_type(TypeTable, TVarSet, DuTypeInfo, BaseTypeInfo) :- + DuTypeInfo = du_type_info(TypeCtor, ArgTypes, TypeDefn, TypeBodyDu), + MaybeSuperType = TypeBodyDu ^ du_type_supertype, + ( + MaybeSuperType = not_a_subtype, + BaseTypeInfo = DuTypeInfo + ; + MaybeSuperType = subtype_of(SuperType0), + get_supertype_of_subtype(TVarSet, TypeCtor, ArgTypes, + TypeDefn, SuperType0, SuperType), + classify_is_du_type(TypeTable, SuperType, MaybeSuperDuType), + % The invocations of add_du_ctors_check_subtype_check_foreign_type + % in make_hlds_passes.m should have already checked that + % each declared supertype is in fact a du type, and if any + % of those checks failed, execution should not have been allowed + % to proceed to the typechecking pass. + ( + MaybeSuperDuType = is_du_type(SuperDuTypeInfo) + ; + MaybeSuperDuType = is_not_du_type(_), + unexpected($pred, "MaybeSuperDuType != is_du_type") + ), + compute_base_type_if_du_type(TypeTable, TVarSet, + SuperDuTypeInfo, BaseTypeInfo) ). %---------------------% diff --git a/compiler/typecheck_errors.m b/compiler/typecheck_errors.m index 23aa6558b..7a577ccc3 100644 --- a/compiler/typecheck_errors.m +++ b/compiler/typecheck_errors.m @@ -51,9 +51,6 @@ :- import_module hlds.hlds_pred. :- import_module libs. :- import_module libs.options. -:- import_module mdbcomp. -:- import_module mdbcomp.prim_data. -:- import_module mdbcomp.sym_name. :- import_module parse_tree.parse_tree_out_term. :- import_module parse_tree.parse_tree_out_type. :- import_module parse_tree.prog_type_subst. @@ -220,31 +217,29 @@ describe_coerce_fail(TVarSet, Fail) = Pieces :- ; Fail = incompatible_types(_, _), Pieces = [] - ; - Fail = cannot_coerce_type_vars(_, _), - Pieces = [] ; Fail = cannot_unify_type_vars(_, _), Pieces = [] ; - Fail = non_du_type_ctor(FromType, ToType), + Fail = non_du_type_ctor(FromType, FromTypeDesc, ToType, ToTypeDesc), Pieces = describe_coerce_fail_non_du_type_ctor(TVarSet, - FromType, ToType) + FromType, FromTypeDesc, ToType, ToTypeDesc) ; Fail = should_be_invariant_arg(_, _), Pieces = [] ). -:- func describe_coerce_fail_non_du_type_ctor(tvarset, mer_type, mer_type) - = list(format_piece). +:- func describe_coerce_fail_non_du_type_ctor(tvarset, + mer_type, string, mer_type, string) = list(format_piece). -describe_coerce_fail_non_du_type_ctor(TVarSet, FromType, ToType) = Pieces :- +describe_coerce_fail_non_du_type_ctor(TVarSet, FromType, FromTypeDesc, + ToType, ToTypeDesc) = Pieces :- FromTypeStr = mercury_type_to_string(TVarSet, print_num_only, FromType), ToTypeStr = mercury_type_to_string(TVarSet, print_num_only, ToType), OnlyDuPieces = [words("You can only coerce"), words("from one discriminated union type to another, and")], - describe_if_non_du_type(FromType, FromTypeNonDuPieces), - describe_if_non_du_type(ToType, ToTypeNonDuPieces), + describe_if_non_du_type(FromTypeDesc, FromTypeNonDuPieces), + describe_if_non_du_type(ToTypeDesc, ToTypeNonDuPieces), ( FromTypeNonDuPieces = [], ( @@ -292,6 +287,15 @@ describe_coerce_fail_non_du_type_ctor(TVarSet, FromType, ToType) = Pieces :- ) ). +:- pred describe_if_non_du_type(string::in, list(format_piece)::out) is det. + +describe_if_non_du_type(NonDuDesc, DescPieces) :- + ( if NonDuDesc = "" then + DescPieces = [] + else + DescPieces = [words(NonDuDesc)] + ). + %---------------------------------------------------------------------------% report_unresolved_coerce_from_to(ClauseContext, Context, FromVar, TVarSet, @@ -325,43 +329,6 @@ report_redundant_coerce(ClauseContext, Context, FromVar, TVarSet, FromType) = Spec = spec($pred, Severity, phase_type_check, Context, InClauseForPieces ++ ErrorPieces). - % If the given type is du type, return the empty list. Otherwise, - % return a description of what kind of non-du type it is. - % -:- pred describe_if_non_du_type(mer_type::in, list(format_piece)::out) is det. - -describe_if_non_du_type(Type, DescPieces) :- - % Our caller can the article "a" in front of the text we return, - % and the plural suffix "s" after the text. - ( - Type = type_variable(_, _), - DescPieces = [words("type variable")] - ; - Type = defined_type(_, _, _), - DescPieces = [] - ; - Type = builtin_type(_), - DescPieces = [words("builtin type")] - ; - Type = tuple_type(_, _), - DescPieces = [words("tuple type")] - ; - Type = higher_order_type(PorF, _, _, _), - ( - PorF = pf_function, - DescPieces = [words("function type")] - ; - PorF = pf_predicate, - DescPieces = [words("predicate type")] - ) - ; - Type = apply_n_type(_, _, _), - DescPieces = [words("function type")] - ; - Type = kinded_type(SubType, _), - describe_if_non_du_type(SubType, DescPieces) - ). - %---------------------------------------------------------------------------% :- end_module check_hlds.typecheck_errors. %---------------------------------------------------------------------------%