diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m index c83337149..71db18ae7 100644 --- a/compiler/add_pragma.m +++ b/compiler/add_pragma.m @@ -21,7 +21,13 @@ %---------------------------------------------------------------------------% -:- pred add_decl_pragmas(ims_list(item_decl_pragma_info)::in, +:- pred add_decl_pragmas(io.text_output_stream::in, + ims_list(item_decl_pragma_info)::in, + module_info::in, module_info::out, qual_info::in, qual_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +:- pred add_decl_pragmas_type_spec_constr(io.text_output_stream::in, + list(decl_pragma_type_spec_constr_info)::in, module_info::in, module_info::out, qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out) is det. @@ -151,12 +157,21 @@ % Adding decl pragmas to the HLDS. % -add_decl_pragmas([], !ModuleInfo, !QualInfo, !Specs). -add_decl_pragmas([ImsList | ImsLists], !ModuleInfo, !QualInfo, !Specs) :- +add_decl_pragmas(_, [], !ModuleInfo, !QualInfo, !Specs). +add_decl_pragmas(ProgressStream, [ImsList | ImsLists], + !ModuleInfo, !QualInfo, !Specs) :- ImsList = ims_sub_list(ItemMercuryStatus, Items), - list.foldl3(add_decl_pragma(ItemMercuryStatus), Items, + list.foldl3(add_decl_pragma(ProgressStream, ItemMercuryStatus), Items, !ModuleInfo, !QualInfo, !Specs), - add_decl_pragmas(ImsLists, !ModuleInfo, !QualInfo, !Specs). + add_decl_pragmas(ProgressStream, ImsLists, !ModuleInfo, !QualInfo, !Specs). + +add_decl_pragmas_type_spec_constr(_, [], !ModuleInfo, !QualInfo, !Specs). +add_decl_pragmas_type_spec_constr(ProgressStream, [Pragma | Pragmas], + !ModuleInfo, !QualInfo, !Specs) :- + add_pragma_type_spec_constr(ProgressStream, Pragma, + !ModuleInfo, !QualInfo, !Specs), + add_decl_pragmas_type_spec_constr(ProgressStream, Pragmas, + !ModuleInfo, !QualInfo, !Specs). add_decl_pragmas_type_spec([], !ModuleInfo, !QualInfo, !Specs). add_decl_pragmas_type_spec([Pragma | Pragmas], @@ -186,11 +201,13 @@ add_decl_pragmas_reuse([Pragma | Pragmas], !ModuleInfo, !Specs) :- %---------------------% -:- pred add_decl_pragma(item_mercury_status::in, item_decl_pragma_info::in, +:- pred add_decl_pragma(io.text_output_stream::in, item_mercury_status::in, + item_decl_pragma_info::in, module_info::in, module_info::out, qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out) is det. -add_decl_pragma(ItemMercuryStatus, Pragma, !ModuleInfo, !QualInfo, !Specs) :- +add_decl_pragma(ProgressStream, ItemMercuryStatus, Pragma, + !ModuleInfo, !QualInfo, !Specs) :- ( Pragma = decl_pragma_obsolete_pred(ObsoletePredInfo), mark_pred_as_obsolete(ObsoletePredInfo, ItemMercuryStatus, @@ -203,6 +220,10 @@ add_decl_pragma(ItemMercuryStatus, Pragma, !ModuleInfo, !QualInfo, !Specs) :- Pragma = decl_pragma_format_call(FormatCallInfo), mark_pred_as_format_call(FormatCallInfo, ItemMercuryStatus, !ModuleInfo, !Specs) + ; + Pragma = decl_pragma_type_spec_constr(TypeSpecConstrInfo), + add_pragma_type_spec_constr(ProgressStream, TypeSpecConstrInfo, + !ModuleInfo, !QualInfo, !Specs) ; Pragma = decl_pragma_type_spec(TypeSpecInfo), add_pragma_type_spec(TypeSpecInfo, !ModuleInfo, !QualInfo, !Specs) diff --git a/compiler/add_pragma_type_spec.m b/compiler/add_pragma_type_spec.m index 1e1ac5bd8..fe0d2d7fd 100644 --- a/compiler/add_pragma_type_spec.m +++ b/compiler/add_pragma_type_spec.m @@ -1,10 +1,10 @@ -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et -%-----------------------------------------------------------------------------% -% Copyright (C) 2015 The Mercury team. +%---------------------------------------------------------------------------% +% Copyright (C) 2015,2024 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. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- module hlds.make_hlds.add_pragma.add_pragma_type_spec. :- interface. @@ -16,15 +16,21 @@ :- import_module list. +:- pred add_pragma_type_spec_constr(io.text_output_stream::in, + decl_pragma_type_spec_constr_info::in, + module_info::in, module_info::out, qual_info::in, qual_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + :- pred add_pragma_type_spec(decl_pragma_type_spec_info::in, module_info::in, module_info::out, qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out) is det. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- implementation. :- import_module hlds.hlds_args. +:- import_module hlds.hlds_class. :- import_module hlds.hlds_code_util. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_rtti. @@ -36,9 +42,14 @@ :- import_module libs.options. :- import_module mdbcomp. :- import_module mdbcomp.sym_name. +:- import_module parse_tree.parse_tree_out_info. +:- import_module parse_tree.parse_tree_out_pragma. +:- import_module parse_tree.parse_tree_out_sym_name. :- import_module parse_tree.parse_tree_out_term. +:- import_module parse_tree.parse_tree_out_type. :- import_module parse_tree.prog_type_scan. :- import_module parse_tree.prog_type_subst. +:- import_module parse_tree.prog_type_test. :- import_module parse_tree.prog_util. :- import_module parse_tree.set_of_var. :- import_module parse_tree.var_table. @@ -50,11 +61,1193 @@ :- import_module maybe. :- import_module multi_map. :- import_module one_or_more. +:- import_module one_or_more_map. :- import_module pair. :- import_module set. +:- import_module string. +:- import_module term. +:- import_module term_context. :- import_module varset. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +add_pragma_type_spec_constr(ProgressStream, TypeSpecConstr, + !ModuleInfo, !QualInfo, !Specs) :- + % The general approach we use to implement type_spec_constrained_preds + % pragmas is to compute the set of ordinary type_spec pragmas they + % correspond to, and add *those* to !ModuleInfo. + TypeSpecConstr = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints, ApplyToSupers, OoMTypeSubsts, PragmaTVarSet, _, + Context, _), + module_info_get_class_table(!.ModuleInfo, ClassTable), + % Start by finding out which typeclass constraints we should look for + % in the predicates in the predicate table. This includes checking + % whether all the type classes named in OoMConstraints actually exist. + Constraints = one_or_more_to_list(OoMConstraints), + list.foldl2( + build_class_constraint_map(ClassTable, ApplyToSupers, PragmaTVarSet), + Constraints, map.init, ClassConstraintMap, [], ClassSpecs), + ( + ClassSpecs = [], + % All the typeclass constraints in OoMConstraints exist. + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + io.output_stream(Stream, !IO), + ClassConstraintMapAL = + one_or_more_map.to_flat_assoc_list(ClassConstraintMap), + io.nl(Stream, !IO), + list.foldl(write_class_constraint_map_entry(Stream, PragmaTVarSet), + ClassConstraintMapAL, !IO) + ), + % Check all predicates defined in either ModuleName or its submodules + % to see whether they include one or more of the typeclass constraints + % we are looking out for, and when we find one, generate type_spec + % pragmas for that predicate for all the substitutions in + % OoMTypeSubsts. + module_info_get_predicate_table(!.ModuleInfo, PredTable), + predicate_table_get_pred_id_table(PredTable, PredIdTable), + map.foldl_values( + maybe_generate_pragma_type_specs_for_pred(ModuleName, + ClassConstraintMap, PragmaTVarSet, OoMTypeSubsts), + PredIdTable, [], Pragmas), + % For one reason for why Pragmas may contain duplicates, + % see the comment about this in build_class_constraint_map. + % That one is about different but equivalent instances of + % the same type class. Another reason is that instances of + % different type classes may result in the same specialization + % request. + list.sort_and_remove_dups(Pragmas, SortedPragmas), + module_info_get_globals(!.ModuleInfo, Globals), + globals.lookup_bool_option(Globals, + inform_generated_type_spec_pragmas, Inform), + ( + Inform = no + ; + Inform = yes, + trace [io(!IO)] ( + Context = context(FileName, LineNumber), + io.format(ProgressStream, + "%% For the type_spec_constrained_preds pragma" ++ + " at %s:%d,\n", + [s(FileName), i(LineNumber)], !IO), + io.write_string(ProgressStream, + "% the compiler generated ", !IO), + ( + SortedPragmas = [], + io.write_string(ProgressStream, + "no type_spec pragmas.\n", !IO) + ; + SortedPragmas = [_ | _], + io.write_string(ProgressStream, + "these type_spec pragmas:\n", !IO), + list.foldl(report_generated_pragma(ProgressStream), + SortedPragmas, !IO) + ) + ) + ), + % Actually add the generated type_spec pragmas to !ModuleInfo. + % + % XXX Since Pragmas were generated by the compiler, if adding them + % to !ModuleInfo results in any errors, they are the compiler's fault, + % not the user's. But for now, we want to report them, because if + % we ignored them, we would never be alerted to their existence. + list.foldl3(add_pragma_type_spec, SortedPragmas, + !ModuleInfo, !QualInfo, !Specs) + ; + ClassSpecs = [_ | _], + !:Specs = ClassSpecs ++ !.Specs + ). + +%---------------------% + + % Values of this type represent the set of typeclass constraints + % we want to specialize. Each class_id in here will correspond + % either to a constraint in a type_spec_constrained_preds pragma, + % one its superclasses, or one of *their* superclasses, and so on. + % + % We may be on the lookout for more than one instance of a given class, + % since the constraints in the pragma may refer to multiple instances + % of that class, either directly, or indirectly through superclasses. + % + % All type variables in values of these types come from the pragma. +:- type type_spec_constraint_map == one_or_more_map(class_id, arg_vector). +:- type arg_vector + ---> arg_vector(list(var_or_ground_type)). + + % Build the set of typeclass instances we need to look for to handle + % a given type_spec_constrained_preds pragma. This will include the + % constraints in the first argument of the type_spec_constrained_preds + % pragma, but may include their projections to their superclasses as well. + % +:- pred build_class_constraint_map(class_table::in, maybe_apply_to_supers::in, + tvarset::in, var_or_ground_constraint::in, + type_spec_constraint_map::in, type_spec_constraint_map::out, + list(error_spec)::in, list(error_spec)::out) is det. + +build_class_constraint_map(ClassTable, ApplyToSupers, PragmaTVarSet, + Constraint, !ClassConstraintMap, !Specs) :- + Constraint = + var_or_ground_constraint(ClassSymName, VarOrGroundTypes, Context), + list.length(VarOrGroundTypes, NumTypes), + ClassId = class_id(ClassSymName, NumTypes), + ( if map.search(ClassTable, ClassId, ClassDefn) then + ArgVector = arg_vector(VarOrGroundTypes), + ( if map.search(!.ClassConstraintMap, ClassId, ArgVectors0) then + ( if one_or_more.member(ArgVector, ArgVectors0) then + OldOrNew = "main old" + else + OldOrNew = "main nw+", + % It is possible for ArgVector to differ from an entry already + % in ArgVectors0 *only* in the number and/or the name of a type + % variable. If this is the case, then adding ArgVector + % to the map will cause our caller to generate duplicate + % type_spec pragmas. We handle this by having our caller + % remove duplicates while sorting those pragmas. This requires + % less code than checking for such differences here, while + % causing duplicate work to be done only in a situation + % that is extremely unlikely to arise in practice. + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ) + else + OldOrNew = "main new", + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ), + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + EntryStr = class_constraint_map_entry_to_string(PragmaTVarSet, + OldOrNew, ClassId, ArgVector), + io.output_stream(Stream, !IO), + io.nl(Stream, !IO), + io.write_string(Stream, EntryStr, !IO) + ), + ( + ApplyToSupers = do_not_apply_to_supers + ; + ApplyToSupers = apply_to_supers, + ClassTVars = ClassDefn ^ classdefn_vars, + map.from_corresponding_lists(ClassTVars, VarOrGroundTypes, Subst0), + Supers = ClassDefn ^ classdefn_supers, + list.foldl( + build_superclass_constraint_map(ClassTable, PragmaTVarSet, + Context, Subst0), + Supers, !ClassConstraintMap) + ) + else + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl, + words("error: the constraint list references"), + words("a type class named"), qual_class_id(ClassId), suffix(","), + words("but there is no visible type class"), + words("with this name and arity."), nl], + % XXX TSCP Warn about other arities, and "did you mean" close enough + % class names + % XXX Make any code for doing that general enough to handle + % all other error messages about references to unknown classes. + Spec = simplest_spec($pred, severity_error, phase_parse_tree_to_hlds, + Context, Pieces), + !:Specs = [Spec | !.Specs] + ). + + % This predicate does the same job as build_class_constraint_map above, + % but specialized to the situation where Constraint comes *not* from + % the original pragma, but from being the Nth level superclass of + % one of those constraints. This requires different handling, because + % any errors we find here are caused by typeclass declarations elsewhere, + % *not* by the pragma we are processing. + % +:- pred build_superclass_constraint_map(class_table::in, tvarset::in, + prog_context::in, map(tvar, var_or_ground_type)::in, prog_constraint::in, + type_spec_constraint_map::in, type_spec_constraint_map::out) is det. + +build_superclass_constraint_map(ClassTable, PragmaTVarSet, Context, + Subst0, Constraint, !ClassConstraintMap) :- + constraint_get_class_id_and_types(Constraint, ClassId, Types), + ( if map.search(ClassTable, ClassId, ClassDefn) then + compute_superclass_arg_types(Subst0, Types, VarOrGroundTypes), + ArgVector = arg_vector(VarOrGroundTypes), + ( if map.search(!.ClassConstraintMap, ClassId, ArgVectors0) then + ( if one_or_more.member(ArgVector, ArgVectors0) then + OldOrNew = "super old" + else + OldOrNew = "super nw+", + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ) + else + OldOrNew = "super new", + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ), + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + EntryStr = class_constraint_map_entry_to_string(PragmaTVarSet, + OldOrNew, ClassId, ArgVector), + io.output_stream(Stream, !IO), + io.write_string(Stream, EntryStr, !IO) + ), + + ClassTVars = ClassDefn ^ classdefn_vars, + map.from_corresponding_lists(ClassTVars, VarOrGroundTypes, Subst), + Supers = ClassDefn ^ classdefn_supers, + list.foldl( + build_superclass_constraint_map(ClassTable, PragmaTVarSet, + Context, Subst), + Supers, !ClassConstraintMap) + else + % The non-existence of the superclass is an error, but it is an error + % in the declaration of the subclass, not an error in the pragma + % we are processing. The error will reported when we process the + % declaration of the subclass; reporting it here also would not + % help the user. + true + ). + +%---------------------% + +:- pred compute_superclass_arg_types(map(tvar, var_or_ground_type)::in, + list(mer_type)::in, list(var_or_ground_type)::out) is det. + +compute_superclass_arg_types(_, [], []). +compute_superclass_arg_types(Subst, [Type | Types], + [VarOrGroundType | VarOrGroundTypes]) :- + ( if Type = type_variable(Var, _) then + map.lookup(Subst, Var, VarOrGroundType) + else if type_is_ground(Type, GroundType) then + VarOrGroundType = ground_type(GroundType) + else + unexpected($pred, "type is not var or ground") + ), + compute_superclass_arg_types(Subst, Types, VarOrGroundTypes). + +%---------------------------------------------------------------------------% + +:- pred maybe_generate_pragma_type_specs_for_pred(module_name::in, + type_spec_constraint_map::in, tvarset::in, one_or_more(type_subst)::in, + pred_info::in, + list(decl_pragma_type_spec_info)::in, + list(decl_pragma_type_spec_info)::out) is det. + +maybe_generate_pragma_type_specs_for_pred(PragmaModuleName, ClassConstraintMap, + PragmaTVarSet, OoMTypeSubsts, PredInfo, !Pragmas) :- + pred_info_get_module_name(PredInfo, PredModuleName), + ( if + is_same_module_or_submodule(PredModuleName, PragmaModuleName), + pred_info_get_class_context(PredInfo, ClassContext), + ClassContext = + univ_exist_constraints(UnivConstraints, _ExistConstraints), + UnivConstraints = [_ | _], + % We don't want to type-specialize predicates create by + % other type_spec pragmas, either user-provided or compiler-generated, + % for two reasons. + % + % First, it does not work; it seems that the way we set up + % the predicates created by type specialization differs from + % how we set up ordinary class-constrained predicates, in way + % that causes compiler errors on a *second* application of type + % specialization. (I -zs- don't know what the difference is exactly, + % but you could delete this test and find out. The test data for it + % was juliensf's csv parser, as it was on 2024 feb 1.) + % + % Second, even if type-specializing a type-specialized predicate + % worked, the result would depend on the *order* in which we processed + % type_spec pragmas, which is not a good idea. + pred_info_get_origin(PredInfo, Origin), + is_pred_origin_type_spec(Origin) = origin_is_not_type_spec + then + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + pred_info_get_name(PredInfo, PredName), + pred_info_get_context(PredInfo, PredContext), + PredContext = context(File, Line), + io.output_stream(Stream, !IO), + io.format(Stream, + "\nProcessing %s at %s:%d\n", + [s(PredName), s(File), i(Line)], !IO) + ), + generate_type_spec_solns_for_pred(ClassConstraintMap, PragmaTVarSet, + PredInfo, UnivConstraints, Solns), + list.foldl( + generate_pragma_type_specs_for_pred_soln(PragmaModuleName, + PragmaTVarSet, PredInfo, OoMTypeSubsts), + Solns, !Pragmas) + else + true + ). + +:- type is_origin_type_spec + ---> origin_is_not_type_spec + ; origin_is_type_spec. + +:- func is_pred_origin_type_spec(pred_origin) = is_origin_type_spec. + +is_pred_origin_type_spec(Origin) = IsTypeSpec :- + ( + ( Origin = origin_user(_) + ; Origin = origin_compiler(_) + ), + IsTypeSpec = origin_is_not_type_spec + ; + Origin = origin_proc_transform(_, BeforeTransformOrigin, _, _), + IsTypeSpec = is_pred_origin_type_spec(BeforeTransformOrigin) + ; + Origin = origin_pred_transform(PredTransform, + BeforeTransformOrigin, _), + ( + PredTransform = pred_transform_pragma_type_spec(_), + IsTypeSpec = origin_is_type_spec + ; + ( PredTransform = pred_transform_distance_granularity(_) + ; PredTransform = pred_transform_table_generator + ; PredTransform = pred_transform_ssdebug(_) + ; PredTransform = pred_transform_structure_reuse + ), + IsTypeSpec = is_pred_origin_type_spec(BeforeTransformOrigin) + ) + ). + +%---------------------% + + % Figure out which type vars in the given predicate's signature + % should be specialized to which types specified in the the + % type_spec_constrained_preds pragma we are processing. + % +:- pred generate_type_spec_solns_for_pred(type_spec_constraint_map::in, + tvarset::in, pred_info::in, list(prog_constraint)::in, + list(subst_soln)::out) is det. + +generate_type_spec_solns_for_pred(ClassConstraintMap, PragmaTVarSet, PredInfo, + UnivConstraints, Solns) :- + pred_info_get_typevarset(PredInfo, PredTVarSet), + % Find out the substitutions implied by each constraint that occurs + % in both the predicate's class context and in the first argument + % of the type_spec_constrained_preds pragma. This code calls these + % substitutions "solutions". + % + % If the predicate's class context contains two or more constraints + % for the same typeclass, record all of the resulting solutions + % as alternatives for that class. + list.foldl( + acc_class_ground_substs(PragmaTVarSet, PredTVarSet, + ClassConstraintMap), + UnivConstraints, map.init, ClassSolnsMap), + map.to_sorted_assoc_list(ClassSolnsMap, ClassSolnsMapAL), + ( + ClassSolnsMapAL = [], + Solns = [] + ; + ClassSolnsMapAL = [HeadClassSoln | TailClassSolns], + % There is at least one typeclass that occurs in both the predicate's + % class context and in the first argument of the pragma. + % If there are two or more, each of which may have more than one + % solution (though almost all will have just one), then consider + % all possible combinations that take one solution from each typeclass, + % and see whether they are compatible. Return, as SolnSetSet, + % the resulting combined solutions. + find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + HeadClassSoln, TailClassSolns, SolnSet), + set.to_sorted_list(SolnSet, Solns) + ), + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + SolnsStr = dump_subst_soln_list(PragmaTVarSet, PredTVarSet, "\n", + 1, Solns), + io.output_stream(Stream, !IO), + io.write_string(Stream, "Solns:\n", !IO), + io.write_string(Stream, SolnsStr, !IO), + io.write_string(Stream, "end Solns\n", !IO) + ). + +%---------------------% + + % This maps each class_id that has a constraint in the first argument + % of the type_spec_constrained_preds pragma we are processing, either + % directly or (if allowed) indirectly as a superclass, to the set of + % substitutions specified by those constraints. + % + % It is this type that requires subst_soln to be a type that has + % a canonical representation. + % +:- type class_solns_map == map(class_id, set(subst_soln)). + + % Values of this type represent either + % + % - the substitutions in a class_solns_map (in which case they are + % implicitly for the class whose class_id is the corresponding key), or + % + % - the result of unifying one ore more of those class-specific solutions. + % + % The latter are both the intermediate data structures, and the final + % result, of find_all_ground_subst_combinations. + % +:- type subst_soln + ---> subst_soln( + % This is a map from the predicate's type vars to the types + % in the pragma's first argument, but in a form which has + % a canonical representation, which allows us to construct + % a set of ground_substs without worrying that the set + % contains two (or more) elements that are syntactically + % different but semantically identical. + set(ground_or_tvar_subst), + + % For the subset of the entries in the previous field + % where the type in the pragma's first arg is a variable, + % a map from the pragma's tvar back to the predicate's tvar, + % again in a form with a canonical representation. + set(pragma_to_pred_tvar) + ). + +:- type ground_or_tvar_subst + ---> ground_or_tvar_subst(tvar, var_or_ground_type). + % Map from the predicate's type vars to the types + % in the pragma's first argument. + +:- type pragma_to_pred_tvar + ---> pragma_to_pred_tvar(tvar, tvar). + % The first tvar is from the pragma's tvarset, the second + % is from the predicate's tvarset. + +%---------------------% + + % Accumulate in !SolnsMap the set of solutions for the given typeclass. + % +:- pred acc_class_ground_substs(tvarset::in, tvarset::in, + type_spec_constraint_map::in, prog_constraint::in, + class_solns_map::in, class_solns_map::out) is det. + +acc_class_ground_substs(PragmaTVarSet, PredTVarSet, ClassConstraintMap, + Constraint, !SolnsMap) :- + constraint_get_class_id_and_types(Constraint, ClassId, Types), + ( if map.search(ClassConstraintMap, ClassId, OoMClassArgVectors) then + ClassArgVectors = one_or_more_to_list(OoMClassArgVectors), + acc_matching_arg_vectors(PragmaTVarSet, PredTVarSet, ClassId, Types, + ClassArgVectors, !SolnsMap) + else + true + ). + +:- pred acc_matching_arg_vectors(tvarset::in, tvarset::in, + class_id::in, list(mer_type)::in, list(arg_vector)::in, + class_solns_map::in, class_solns_map::out) is det. + +acc_matching_arg_vectors(_, _, _, _Types, [], !SolnsMap). +acc_matching_arg_vectors(PragmaTVarSet, PredTVarSet, ClassId, Types, + [ArgVector | ArgVectors], !SolnsMap) :- + % Types come from PredTVarSet, ArgVectors come from PragmaTVarSet. + ArgVector = arg_vector(VarOrGroundTypes), + ( if + is_matching_arg_vector(Types, VarOrGroundTypes, + map.init, Subst, map.init, RevTVarMap) + then + map.to_sorted_assoc_list(Subst, SubstAL), + PairToGroundOrTVarSubst = + (func(TV - VoG) = ground_or_tvar_subst(TV, VoG)), + GroundOrTVarSubsts = list.map(PairToGroundOrTVarSubst, SubstAL), + GroundOrTVarSubstSet = set.sorted_list_to_set(GroundOrTVarSubsts), + + map.to_sorted_assoc_list(RevTVarMap, RevTVarMapAL), + PairToPragmaToPred = + (func(Prag - Pred) = pragma_to_pred_tvar(Prag, Pred)), + PragmaToPreds = list.map(PairToPragmaToPred, RevTVarMapAL), + PragmaToPredsSet = set.sorted_list_to_set(PragmaToPreds), + + SubstSoln = subst_soln(GroundOrTVarSubstSet, PragmaToPredsSet), + ( if map.search(!.SolnsMap, ClassId, SubstSolns0) then + set.insert(SubstSoln, SubstSolns0, SubstSolns), + map.det_update(ClassId, SubstSolns, !SolnsMap) + else + SubstSolns = set.make_singleton_set(SubstSoln), + map.det_insert(ClassId, SubstSolns, !SolnsMap) + ), + + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + TypesStr = mercury_types_to_string(PredTVarSet, print_name_and_num, + Types), + ArgVectorStr = arg_vector_to_string(PragmaTVarSet, ArgVector), + SolnStr = + dump_subst_soln(PragmaTVarSet, PredTVarSet, "", SubstSoln), + io.output_stream(Stream, !IO), + io.format(Stream, "\nacc_matching_arg_vector for %s\n", + [s(class_id_to_string(ClassId))], !IO), + io.format(Stream, "types: %s\n", [s(TypesStr)], !IO), + io.format(Stream, "arg_vector: %s\n", [s(ArgVectorStr)], !IO), + io.format(Stream, "subst_soln: %s\n", [s(SolnStr)], !IO) + ) + else + true + ), + acc_matching_arg_vectors(PragmaTVarSet, PredTVarSet, ClassId, Types, + ArgVectors, !SolnsMap). + +%---------------------% + + % The first argument is the list of the argument types of a typeclass + % from the class context of the predicate we are processing. + % The second argument is either the list of argument types of a constraint + % in the first argument of the type_spec_constrained_preds pragma + % we are also processing, or is the list of corresponding argument types + % of its superclass, or *its* superclass, and so on. + % + % The first arg may contain arbitrary type variables anywhere. + % The types in the second arg will be either variables or ground terms, + % with nothing in between. Any type variables in it should also be + % distinct (XXX is this guaranteed to be true?) but we can't express + % that invariant in the type system, and we don't (yet) check that + % it actually holds. + % + % This predicate tests whether the constraint from the predicate + % has the constraint from the pragma as an instance. If it does, + % we succeed, and return + % + % - the substitution from predicate tvars to pragma types specifying + % that instance, as !:Subst, and + % - the tvar-to-tvar part of that substitution in reverse form, i.e. + % as a renaming from pragma tvars to predicate tvars, as !:RevTVarMap. + % +:- pred is_matching_arg_vector(list(mer_type)::in, + list(var_or_ground_type)::in, + map(tvar, var_or_ground_type)::in, map(tvar, var_or_ground_type)::out, + map(tvar, tvar)::in, map(tvar, tvar)::out) is semidet. + +is_matching_arg_vector([], [], !Subst, !RevTVarMap). +is_matching_arg_vector([Type | Types], [VarOrGroundType | VarOrGroundTypes], + !Subst, !RevTVarMap) :- + is_matching_arg_type(Type, VarOrGroundType, !Subst, !RevTVarMap), + is_matching_arg_vector(Types, VarOrGroundTypes, !Subst, !RevTVarMap). + +:- pred is_matching_arg_type(mer_type::in, var_or_ground_type::in, + map(tvar, var_or_ground_type)::in, map(tvar, var_or_ground_type)::out, + map(tvar, tvar)::in, map(tvar, tvar)::out) is semidet. + +is_matching_arg_type(Type, VarOrGroundType, !Subst, !RevTVarMap) :- + % There should not be any tvar-to-tvar-to-tvar bindings, because + % any tvars in Type can be mapped only to things in VarOrGroundType, + % which then cannot be mapped any further. + ( if Type = type_variable(TVar, kind_star) then + ( if map.search(!.Subst, TVar, OldBinding) then + ( + VarOrGroundType = ground_type(_GroundType), + % Since VarOrGroundType is ground_type, we *require* this + % argument type to be ground. Therefore we cannot allow + % a type variable to match a ground type. + fail + ; + VarOrGroundType = type_var_name(_VoGTypeVar, _VoGTypeName), + % tVar cannot be allowed to simultaneously match + % both VoGTypeVar and either + % - a different VoGTypeVar, or + % - any ground type. + ( if OldBinding = VarOrGroundType then + true + else + fail + ) + ) + else + map.det_insert(TVar, VarOrGroundType, !Subst), + ( + VarOrGroundType = ground_type(_) + ; + VarOrGroundType = type_var_name(VoGTypeVar, _), + ( if map.insert(VoGTypeVar, TVar, !RevTVarMap) then + true + else + fail + ) + ) + ) + else + ( + VarOrGroundType = ground_type(GroundType), + % Since VarOrGroundType is ground_type, we *require* this + % argument type to be ground. Therefore we cannot allow + % a non-ground Type such as map(K, string) to match + % a GroundType such as map(int, string). + ( if Type = coerce(GroundType) then + true + else + fail + ) + ; + VarOrGroundType = type_var_name(_VoGTypeVar, _VoGTypeName), + % VarOrGroundType makes no demands on Type. + true + ) + ). + +%---------------------% + + % find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + % HeadClassId - HeadSubstSolnSet, TailClassIdsSubstSolns, + % FinalSubstSet): + % + % Unify all the class-specific solutions in HeadSubstSolnSet with + % all the class-specific solutions in TailClassIdsSubstSolns, + % considering all possible combinations that take one solution + % from each class-specific solution set. + % + % While a combinatorial blowup is *theoretically* possible, + % it will almost certainly be vanishingly rare in practice, + % both because the class contexts of most predicates contain + % only very small number of constraints, and because it is very rare + % for two or more of those constraints to involved the same typeclass. + % +:- pred find_all_ground_subst_combinations(tvarset::in, tvarset::in, + pair(class_id, set(subst_soln))::in, + assoc_list(class_id, set(subst_soln))::in, set(subst_soln)::out) is det. + +find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + HeadClassId - HeadSubstSolnSet, TailClassIdsSubstSolns, + FinalSubstSet) :- + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + io.output_stream(Stream, !IO), + io.write_string(Stream, "\nfind_all_ground_subst_combinations\n", !IO), + % Printing HeadClassId here can be slightly misleading, as + % HeadSubstSolnSet will corresponding to HeadClassId only for the + % top-level invocation of find_all_ground_subst_combinations. + % For all later invocations, it will correspond to the + % result of unifying all the solution sets for the class_ids + % we have already processed. Since this output is only for debugging, + % there is no point in creating a more exact description. + HeadStr = dump_class_id_subst_soln(PragmaTVarSet, PredTVarSet, + "head ", "\n", HeadClassId - HeadSubstSolnSet), + io.write_string(Stream, HeadStr, !IO) + ), + ( + TailClassIdsSubstSolns = [], + FinalSubstSet = HeadSubstSolnSet, + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + io.output_stream(Stream, !IO), + io.write_string(Stream, "DONE\n\n", !IO) + ) + ; + TailClassIdsSubstSolns = + [HeadTailClassIdSubstSoln | TailTailClassIdsSubstSolns], + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + HeadTailStr = + dump_class_id_subst_soln(PragmaTVarSet, PredTVarSet, + "head_tail ", "\n", HeadTailClassIdSubstSoln), + io.output_stream(Stream, !IO), + io.write_string(Stream, HeadTailStr, !IO) + ), + HeadTailClassIdSubstSoln = HeadTailClassId - HeadTailSubstSolnSet, + set.to_sorted_list(HeadSubstSolnSet, HeadSubstSolns), + set.to_sorted_list(HeadTailSubstSolnSet, HeadTailSubstSolns), + unify_two_soln_lists_outer_loop(HeadSubstSolns, + HeadTailSubstSolns, set.init, NextSubstSolnSet), + find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + HeadTailClassId - NextSubstSolnSet, + TailTailClassIdsSubstSolns, FinalSubstSet) + ). + +%---------------------% + +:- pred unify_two_soln_lists_outer_loop( + list(subst_soln)::in, list(subst_soln)::in, + set(subst_soln)::in, set(subst_soln)::out) is det. + +unify_two_soln_lists_outer_loop([], _SolnsB, !UnifiedSolns). +unify_two_soln_lists_outer_loop([SubstA | SolnsA], SolnsB, + !UnifiedSolns) :- + unify_two_soln_lists_inner_loop(SubstA, SolnsB, + !UnifiedSolns), + unify_two_soln_lists_outer_loop(SolnsA, SolnsB, + !UnifiedSolns). + +:- pred unify_two_soln_lists_inner_loop( + subst_soln::in, list(subst_soln)::in, + set(subst_soln)::in, set(subst_soln)::out) is det. + +unify_two_soln_lists_inner_loop(_SolnA, [], !UnifiedSolns). +unify_two_soln_lists_inner_loop(SolnA, [SolnB | SolnsB], + !UnifiedSolns) :- + ( if unify_two_solns(SolnA, SolnB, UnifiedSoln) then + set.insert(UnifiedSoln, !UnifiedSolns) + else + true + ), + unify_two_soln_lists_inner_loop(SolnA, SolnsB, !UnifiedSolns). + +:- pred unify_two_solns(subst_soln::in, subst_soln::in, + subst_soln::out) is semidet. + +unify_two_solns(SolnA, SolnB, UnifiedSoln) :- + SolnA = subst_soln(TVarSubstSetA, PragmaToPredSetA), + SolnB = subst_soln(TVarSubstSetB, PragmaToPredSetB), + set.to_sorted_list(TVarSubstSetA, TVarSubstsA), + set.to_sorted_list(TVarSubstSetB, TVarSubstsB), + unify_two_subst_lists_loop(TVarSubstsA, TVarSubstsB, UnifiedSubsts), + set.sorted_list_to_set(UnifiedSubsts, UnifiedSubstsSet), + + unify_pragma_to_pred_sets(PragmaToPredSetA, PragmaToPredSetB, + PragmaToPredSet), + UnifiedSoln = subst_soln(UnifiedSubstsSet, PragmaToPredSet). + +:- pred unify_two_subst_lists_loop(list(ground_or_tvar_subst)::in, + list(ground_or_tvar_subst)::in, list(ground_or_tvar_subst)::out) + is semidet. + +unify_two_subst_lists_loop(TVarSubstsA, TVarSubstsB, UnifiedSubst) :- + ( + TVarSubstsA = [], + TVarSubstsB = [], + UnifiedSubst = [] + ; + TVarSubstsA = [], + TVarSubstsB = [_ | _], + UnifiedSubst = TVarSubstsB + ; + TVarSubstsA = [_ | _], + TVarSubstsB = [], + UnifiedSubst = TVarSubstsA + ; + TVarSubstsA = [HeadTVarSubstA | TailTVarSubstsA], + TVarSubstsB = [HeadTVarSubstB | TailTVarSubstsB], + HeadTVarSubstA = ground_or_tvar_subst(TVarA, VoGTypeA), + HeadTVarSubstB = ground_or_tvar_subst(TVarB, VoGTypeB), + compare(Cmp, TVarA, TVarB), + ( + Cmp = (=), + VoGTypeA = VoGTypeB, + unify_two_subst_lists_loop(TailTVarSubstsA, TailTVarSubstsB, + TailUnifiedSubst), + % HeadTVarSubstA and HeadTVarSubstB are identical. + UnifiedSubst = [HeadTVarSubstA | TailUnifiedSubst] + ; + Cmp = (<), + % TVarA < TVarB + unify_two_subst_lists_loop(TailTVarSubstsA, TVarSubstsB, + TailUnifiedSubst), + UnifiedSubst = [HeadTVarSubstA | TailUnifiedSubst] + ; + Cmp = (>), + % TVarA > TVarB + unify_two_subst_lists_loop(TVarSubstsA, TailTVarSubstsB, + TailUnifiedSubst), + UnifiedSubst = [HeadTVarSubstB | TailUnifiedSubst] + ) + ). + + % unify_pragma_to_pred_sets(PragmaToPredSetA, PragmaToPredSetB, + % PragmaToPredSet): + % + % PragmaToPredSetA and PragmaToPredSetB each should describe a map + % from pragma tvars to pred tvars. Return the union of the two maps + % (in set form), provided that the two are compatible, in the sense that + % for any pragma tvars that occur in both, they both map it to the same + % pred tvar. + % +:- pred unify_pragma_to_pred_sets(set(pragma_to_pred_tvar)::in, + set(pragma_to_pred_tvar)::in, set(pragma_to_pred_tvar)::out) is semidet. + +unify_pragma_to_pred_sets(PragmaToPredSetA, PragmaToPredSetB, + PragmaToPredSet) :- + set.union(PragmaToPredSetA, PragmaToPredSetB, PragmaToPredSetAB), + set.to_sorted_list(PragmaToPredSetAB, PragmaToPredListAB), + ( + PragmaToPredListAB = [] + ; + PragmaToPredListAB = [HeadPragmaToPredAB | TailPragmaToPredAB], + no_pragma_tvar_is_double_mapped(HeadPragmaToPredAB, TailPragmaToPredAB) + ), + PragmaToPredSet = PragmaToPredSetAB. + +:- pred no_pragma_tvar_is_double_mapped(pragma_to_pred_tvar::in, + list(pragma_to_pred_tvar)::in) is semidet. + +no_pragma_tvar_is_double_mapped(Head, Tail) :- + ( + Tail = [] + ; + Tail = [HeadTail | TailTail], + Head = pragma_to_pred_tvar(HeadPragmaTVar, _), + HeadTail = pragma_to_pred_tvar(HeadTailPragmaTVar, _), + % If HeadPragmaTVar = HeadTailPragmaTVar, then this pragma tvar + % is mapped to two different pred tvars by the two input args + % of unify_pragma_to_pred_sets. + HeadPragmaTVar \= HeadTailPragmaTVar, + no_pragma_tvar_is_double_mapped(HeadTail, TailTail) + ). + +%---------------------------------------------------------------------------% + + % Given some solutions we have computed for a type_spec_constrained_preds + % pragma, generate an actual type_spec pragma for each. + % +:- pred generate_pragma_type_specs_for_pred_soln(module_name::in, tvarset::in, + pred_info::in, one_or_more(type_subst)::in, subst_soln::in, + list(decl_pragma_type_spec_info)::in, + list(decl_pragma_type_spec_info)::out) is det. + +generate_pragma_type_specs_for_pred_soln(PragmaModuleName, PragmaTVarSet, + PredInfo, OoMTypeSubsts, Soln, !Pragmas) :- + OoMTypeSubsts = one_or_more(HeadTypeSubst, TailTypeSubts), + generate_pragma_type_spec(PragmaModuleName, PragmaTVarSet, PredInfo, + Soln, HeadTypeSubst, !Pragmas), + list.foldl( + generate_pragma_type_spec(PragmaModuleName, PragmaTVarSet, PredInfo, + Soln), + TailTypeSubts, !Pragmas). + +:- pred generate_pragma_type_spec(module_name::in, tvarset::in, pred_info::in, + subst_soln::in, type_subst::in, + list(decl_pragma_type_spec_info)::in, + list(decl_pragma_type_spec_info)::out) is det. + +generate_pragma_type_spec(PragmaModuleName, PragmaTVarSet, PredInfo, + Soln, TypeSubst, !Pragmas) :- + UserArity = pred_info_user_arity(PredInfo), + MoA = moa_arity(UserArity), + pred_info_get_is_pred_or_func(PredInfo, PredOrFunc), + ( + PredOrFunc = pf_predicate, + PFUMM = pfumm_predicate(MoA) + ; + PredOrFunc = pf_function, + PFUMM = pfumm_function(MoA) + ), + pred_info_get_sym_name(PredInfo, PredSymName), + set.init(RecompItems), + + Soln = subst_soln(_Subst, PragmaToPredSet), + PragmaToPreds = set.to_sorted_list(PragmaToPredSet), + list.foldl(build_pragma_to_pred_tvar_map, PragmaToPreds, + map.init, PragmaToPredMap), + + TypeSubst = one_or_more(HeadTVarSubst, TailTVarSubsts), + TVarSubsts = [HeadTVarSubst | TailTVarSubsts], + find_type_vars_in_tvar_substs(PragmaToPredMap, TVarSubsts, EffTVarSubsts, + set.init, EffTypeSubstTVars), + one_or_more.det_list_to_one_or_more(EffTVarSubsts, EffTypeSubst), + pred_info_get_typevarset(PredInfo, PredTVarSet), + construct_pragma_tvarset_components(PredTVarSet, PragmaToPredMap, + set.to_sorted_list(EffTypeSubstTVars), + 1, NewPragmaNumTVars, map.init, NewPragmaTVarNames, + map.init, Renaming), + list.map(construct_pragma_tvar_subst(Renaming), + EffTVarSubsts, NewPragmaTVarSubsts), + one_or_more.det_list_to_one_or_more(NewPragmaTVarSubsts, + NewPragmaTypeSubst), + varset.construct_varset(NewPragmaNumTVars, NewPragmaTVarNames, + NewPragmaTVarSet), + + Pragma = decl_pragma_type_spec_info(PFUMM, PredSymName, PragmaModuleName, + NewPragmaTypeSubst, NewPragmaTVarSet, RecompItems, + dummy_context, item_no_seq_num), + !:Pragmas = [Pragma | !.Pragmas], + + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + PragmaTVarSetStr = dump_tvarset(PragmaTVarSet), + PredTVarSetStr = dump_tvarset(PredTVarSet), + SolnStr = dump_subst_soln(PragmaTVarSet, PredTVarSet, "\n", Soln), + EffTypeSubstStr = dump_type_subst(PragmaTVarSet, "\n", EffTypeSubst), + NewPragmaTypeSubstStr = dump_type_subst(PragmaTVarSet, "\n", + NewPragmaTypeSubst), + io.output_stream(Stream, !IO), + io.write_string(Stream, "\ngenerate_pragma_type_spec:\n", !IO), + io.write_string(Stream, "PragmaTVarSet:\n", !IO), + io.write_string(Stream, PragmaTVarSetStr, !IO), + io.write_string(Stream, "PredTVarSet:\n", !IO), + io.write_string(Stream, PredTVarSetStr, !IO), + io.write_string(Stream, "Soln:\n", !IO), + io.write_string(Stream, SolnStr, !IO), + io.write_string(Stream, "EffTypeSubst:\n", !IO), + io.write_string(Stream, EffTypeSubstStr, !IO), + io.write_string(Stream, "NewPragmaTypeSubst:\n", !IO), + io.write_string(Stream, NewPragmaTypeSubstStr, !IO), + io.write_string(Stream, "Pragma:\n", !IO), + report_generated_pragma(Stream, Pragma, !IO) + ). + +:- pred build_pragma_to_pred_tvar_map(pragma_to_pred_tvar::in, + map(tvar, tvar)::in, map(tvar, tvar)::out) is det. + +build_pragma_to_pred_tvar_map(PragmaToPred, !PragmaToPredMap) :- + PragmaToPred = pragma_to_pred_tvar(PragmaTVar, PredTVar), + map.det_insert(PragmaTVar, PredTVar, !PragmaToPredMap). + +:- pred find_type_vars_in_tvar_substs(map(tvar, tvar)::in, + list(tvar_subst)::in, list(tvar_subst)::out, + set(tvar)::in, set(tvar)::out) is det. + +find_type_vars_in_tvar_substs(_, [], [], !TVars). +find_type_vars_in_tvar_substs(PragmaToPredMap, + [HeadTVarSubst | TailTVarSubsts], EffTVarSubsts, !TVars) :- + HeadTVarSubst = tvar_subst(HeadTVar, HeadType), + ( if map.search(PragmaToPredMap, HeadTVar, _) then + set.insert(HeadTVar, !TVars), + set_of_type_vars_in_type(HeadType, HeadTypeTVars), + set.union(HeadTypeTVars, !TVars), + find_type_vars_in_tvar_substs(PragmaToPredMap, + TailTVarSubsts, TailEffTVarSubsts, !TVars), + EffTVarSubsts = [HeadTVarSubst | TailEffTVarSubsts] + else + find_type_vars_in_tvar_substs(PragmaToPredMap, + TailTVarSubsts, EffTVarSubsts, !TVars) + ). + +:- pred construct_pragma_tvarset_components(tvarset::in, map(tvar, tvar)::in, + list(tvar)::in, int::in, int::out, + map(tvar, string)::in, map(tvar, string)::out, + map(tvar, tvar)::in, map(tvar, tvar)::out) is det. + +construct_pragma_tvarset_components(_, _, [], + !PragmaNumTVars, !PragmaTVarNames, !Renaming). +construct_pragma_tvarset_components(PredTVarSet, RevTVarMap, + [VoGTVar | VoGTVars], !PragmaNumTVars, !PragmaTVarNames, !Renaming) :- + Var = force_construct_var(!.PragmaNumTVars), + map.det_insert(VoGTVar, Var, !Renaming), + ( if + map.search(RevTVarMap, VoGTVar, PredTVar), + varset.lookup_name(PredTVarSet, PredTVar, PredTVarName) + then + map.det_insert(Var, PredTVarName, !PragmaTVarNames) + else + true + ), + !:PragmaNumTVars = !.PragmaNumTVars + 1, + construct_pragma_tvarset_components(PredTVarSet, RevTVarMap, + VoGTVars, !PragmaNumTVars, !PragmaTVarNames, !Renaming). + +:- pred construct_pragma_tvar_subst(map(tvar, tvar)::in, + tvar_subst::in, tvar_subst::out) is det. + +construct_pragma_tvar_subst(Renaming, VoGTVarSubst, PragmaTVarSubst) :- + VoGTVarSubst = tvar_subst(VoGTVar, VoGType), + apply_variable_renaming_to_tvar(Renaming, VoGTVar, PragmaTVar), + apply_variable_renaming_to_type(Renaming, VoGType, PragmaType), + PragmaTVarSubst = tvar_subst(PragmaTVar, PragmaType). + +%---------------------------------------------------------------------------% +% +% Auxiliary routines for add_pragma_type_spec_constr. Most of them +% are intended to be used in trace goals to help debug the code. +% + +:- pred constraint_get_class_id_and_types(prog_constraint::in, class_id::out, + list(mer_type)::out) is det. + +constraint_get_class_id_and_types(Constraint, ClassId, Types) :- + Constraint = constraint(ClassSymName, Types), + list.length(Types, NumTypes), + ClassId = class_id(ClassSymName, NumTypes). + +%---------------------% + +:- pred report_generated_pragma(io.text_output_stream::in, + decl_pragma_type_spec_info::in, io::di, io::uo) is det. + +report_generated_pragma(Stream, Pragma, !IO) :- + io.write_string(Stream, "% ", !IO), + mercury_format_pragma_type_spec(Stream, output_mercury, Pragma, !IO). + +%---------------------% + +:- pred write_class_constraint_map_entry(io.text_output_stream::in, + tvarset::in, pair(class_id, arg_vector)::in, io::di, io::uo) is det. + +write_class_constraint_map_entry(Stream, TVarSet, ClassId - ArgVector, !IO) :- + EntryStr = class_constraint_map_entry_to_string(TVarSet, "table", + ClassId, ArgVector), + io.write_string(Stream, EntryStr, !IO). + +:- func class_constraint_map_entry_to_string(tvarset, string, + class_id, arg_vector) = string. + +class_constraint_map_entry_to_string(TVarSet, Prefix, ClassId, ArgVector) + = Str :- + ClassId = class_id(ClassSymName, _ClassArity), + ClassNameStr = mercury_sym_name_to_string(ClassSymName), + ArgVectorStr = arg_vector_to_string(TVarSet, ArgVector), + string.format("%s %s(%s)\n", + [s(Prefix), s(ClassNameStr), s(ArgVectorStr)], Str). + +:- func arg_vector_to_string(tvarset, arg_vector) = string. + +arg_vector_to_string(TVarSet, ArgVector) = Str :- + ArgVector = arg_vector(VarOrGroundTypes), + ( + VarOrGroundTypes = [], + Str = "" + ; + VarOrGroundTypes = [HeadVoGType | TailVoGTypes], + Str = var_or_ground_types_to_string(TVarSet, HeadVoGType, TailVoGTypes) + ). + +:- func var_or_ground_types_to_string(tvarset, var_or_ground_type, + list(var_or_ground_type)) = string. + +var_or_ground_types_to_string(TVarSet, HeadVoGType, TailVoGTypes) = Str :- + HeadStr = var_or_ground_type_to_string(TVarSet, HeadVoGType), + ( + TailVoGTypes = [], + Str = HeadStr + ; + TailVoGTypes = [HeadTailVoGType | TailTailVoGTypes], + Str = HeadStr ++ ", " ++ var_or_ground_types_to_string(TVarSet, + HeadTailVoGType, TailTailVoGTypes) + ). + +:- func var_or_ground_type_to_string(tvarset, var_or_ground_type) = string. + +var_or_ground_type_to_string(TVarSet, VoGType) = Str :- + ( + VoGType = type_var_name(TVar, TVarName), + Type = type_variable(TVar, kind_star), + TypeStr = mercury_type_to_string(TVarSet, print_name_and_num, Type), + string.format("tvar %s %s", [s(TVarName), s(TypeStr)], Str) + ; + VoGType = ground_type(GroundType), + Type = coerce(GroundType), + Str = mercury_type_to_string(varset.init, print_name_and_num, Type) + ). + +%---------------------% + +:- func dump_tvarset(tvarset) = string. + +dump_tvarset(TVarSet) = Str :- + NumAllocated = varset.num_allocated(TVarSet), + varset.var_name_list(TVarSet, VarNames), + VarNameStrs = list.map(dump_tvarset_entry, VarNames), + VarNamesStr = string.join_list(", ", VarNameStrs), + string.format("tvarset(%d, [%s])\n", + [i(NumAllocated), s(VarNamesStr)], Str). + +:- func dump_tvarset_entry(pair(tvar, string)) = string. + +dump_tvarset_entry(TVar - Name) = Str :- + string.format("%d -> %s", [i(var_to_int(TVar)), s(Name)], Str). + +:- func dump_class_id_subst_soln(tvarset, tvarset, string, string, + pair(class_id, set(subst_soln))) = string. + +dump_class_id_subst_soln(PragmaTVarSet, PredTVarSet, Prefix, Suffix, + ClassId - SubstSolnSet) = Str :- + ClassId = class_id(ClassSymName, ClassArity), + string.format("%sclass_id %s/%d\n", + [s(Prefix), s(sym_name_to_string(ClassSymName)), i(ClassArity)], + ClassStr), + SolnStrs = dump_subst_soln_list(PragmaTVarSet, PredTVarSet, Suffix, + 1, set.to_sorted_list(SubstSolnSet)), + Str = ClassStr ++ SolnStrs. + +:- func dump_subst_soln_list(tvarset, tvarset, string, int, list(subst_soln)) + = string. + +dump_subst_soln_list(_, _, _, _, []) = "". +dump_subst_soln_list(PragmaTVarSet, PredTVarSet, Suffix, CurSolnNum, + [HeadSoln | TailSolns]) = Str :- + HeadStr0 = dump_subst_soln(PragmaTVarSet, PredTVarSet, Suffix, HeadSoln), + string.format("%d: %s", [i(CurSolnNum), s(HeadStr0)], HeadStr), + TailStr = dump_subst_soln_list(PragmaTVarSet, PredTVarSet, Suffix, + CurSolnNum + 1, TailSolns), + Str = HeadStr ++ TailStr. + +:- func dump_subst_soln(tvarset, tvarset, string, subst_soln) = string. + +dump_subst_soln(PragmaTVarSet, PredTVarSet, Suffix, SubstSoln) = Str :- + SubstSoln = subst_soln(GroundOrTVarSubstSet, PragmaToPredTVarMap), + set.to_sorted_list(GroundOrTVarSubstSet, GroundOrTVarSubsts), + GroundOrTVarSubstStrs = list.map( + dump_ground_or_tvar_subst(PragmaTVarSet, PredTVarSet, " "), + GroundOrTVarSubsts), + GroundOrTVarSubstsStr = string.append_list(GroundOrTVarSubstStrs), + set.to_sorted_list(PragmaToPredTVarMap, PragmaToPredTVarMapAL), + RenameStrs = list.map(dump_tvar_rename(PragmaTVarSet, PredTVarSet, " "), + PragmaToPredTVarMapAL), + RenamesStr = string.append_list(RenameStrs), + string.format("subst_soln(\n%s\n%s)%s", + [s(GroundOrTVarSubstsStr), s(RenamesStr), s(Suffix)], Str). + +:- func dump_ground_or_tvar_subst(tvarset, tvarset, string, + ground_or_tvar_subst) = string. + +dump_ground_or_tvar_subst(PragmaTVarSet, PredTVarSet, Prefix, GroundTVarSubst) + = Str :- + GroundTVarSubst = ground_or_tvar_subst(PredTVar, VoG), + PredTVarStr = + mercury_var_to_string_vs(PredTVarSet, print_name_and_num, PredTVar), + ( + VoG = type_var_name(PragmaTVar, VoGStr0), + VoGKindStr = "tvar", + PragmaTVarStr = mercury_var_to_string_vs(PragmaTVarSet, + print_name_and_num, PragmaTVar), + string.format("%s %s", [s(VoGStr0), s(PragmaTVarStr)], VoGStr) + ; + VoG = ground_type(GroundType), + VoGKindStr = "grnd", + Type = coerce(GroundType), + % There should be no type variables in Type. + VoGStr = mercury_type_to_string(varset.init, print_num_only, Type) + ), + string.format("%sground_or_tvar_subst(pred %-10s -> pragma %s %s)\n", + [s(Prefix), s(PredTVarStr), s(VoGKindStr), s(VoGStr)], Str). + +:- func dump_type_subst(tvarset, string, type_subst) = string. + +dump_type_subst(TVarSet, Suffix, Subst) = Str :- + Subst = one_or_more(HeadTVarSubst, TailTVarSubsts), + TVarSubstStrs = list.map(dump_tvar_subst(TVarSet, " "), + [HeadTVarSubst | TailTVarSubsts]), + string.format("type_subst(\n%s)%s", + [s(string.append_list(TVarSubstStrs)), s(Suffix)], Str). + +:- func dump_tvar_subst(tvarset, string, tvar_subst) = string. + +dump_tvar_subst(TVarSet, Prefix, TVarSubst) = Str :- + TVarSubst = tvar_subst(TVar, Type), + TVarStr = mercury_var_to_string_vs(TVarSet, print_name_and_num, TVar), + TypeStr = mercury_type_to_string(TVarSet, print_name_and_num, Type), + string.format("%stvar_subst(%-10s -> %s)\n", + [s(Prefix), s(TVarStr), s(TypeStr)], Str). + +:- func dump_tvar_rename(tvarset, tvarset, string, pragma_to_pred_tvar) + = string. + +dump_tvar_rename(PragmaTVarSet, PredTVarSet, Prefix, PragmaToPredTVar) = Str :- + PragmaToPredTVar = pragma_to_pred_tvar(PragmaTVar, PredTVar), + Print = print_name_and_num, + PragmaTVarStr = mercury_var_to_string_vs(PragmaTVarSet, Print, PragmaTVar), + PredTVarStr = mercury_var_to_string_vs(PredTVarSet, Print, PredTVar), + string.format("%spragma_to_pred_tvar_rename(%-10s -> %s)\n", + [s(Prefix), s(PragmaTVarStr), s(PredTVarStr)], Str). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% add_pragma_type_spec(TypeSpec, !ModuleInfo, !QualInfo, !Specs) :- TypeSpec = decl_pragma_type_spec_info(PFUMM, SymName, _, _, _, _, @@ -129,7 +1322,7 @@ add_pragma_type_spec_for_pred(TypeSpec, PredId, globals.lookup_bool_option(Globals, smart_recompilation, Smart), % XXX Should check whether smart recompilation has been disabled? ( if - MaybeSpecProcs = ok5(SpecProcTable0, SpecProcIds, + MaybeSpecProcs = ok6(SpecProcTable0, ApplicableModes, SpecProcIds, UserArity, PredFormArity, PFUMM), % Even if we aren't doing type specialization, we need to create % the interface procedures for local predicates to check the @@ -147,7 +1340,7 @@ add_pragma_type_spec_for_pred(TypeSpec, PredId, then add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TypeSpec, TVarSet, Types, ExistQVars, ClassContext, - SpecProcTable0, SpecProcIds, + SpecProcTable0, ApplicableModes, SpecPredId, SpecPredStatus, !ModuleInfo), record_type_specialization(TypeSpec, PredId, SpecPredId, SpecPredStatus, SpecProcIds, RenamedSubst, TVarSet, PFUMM, @@ -156,28 +1349,28 @@ add_pragma_type_spec_for_pred(TypeSpec, PredId, maybe_record_type_spec_in_qual_info(PredOrFunc, SymName, UserArity, SpecPredStatus, TypeSpec, !QualInfo) else - !:Specs = get_any_errors5(MaybeSpecProcs) ++ !.Specs + !:Specs = get_any_errors6(MaybeSpecProcs) ++ !.Specs ) ; MaybeSubstResult = error5(SubstSpecs), !:Specs = SubstSpecs ++ !.Specs ). -:- func subst_desc(pair(tvar, mer_type)) = pair(int, mer_type). +:- func tvar_subst_desc(tvar_subst) = pair(int, mer_type). -subst_desc(TVar - Type) = var_to_int(TVar) - Type. +tvar_subst_desc(tvar_subst(TVar, Type)) = var_to_int(TVar) - Type. :- pred add_type_spec_version_of_pred(pred_id::in, pred_info::in, pred_form_arity::in, decl_pragma_type_spec_info::in, tvarset::in, list(mer_type)::in, existq_tvars::in, - univ_exist_constraints::in, proc_table::in, list(proc_id)::in, + univ_exist_constraints::in, proc_table::in, clause_applicable_modes::in, pred_id::out, pred_status::out, module_info::in, module_info::out) is det. add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, - TVarSet, Types, ExistQVars, ClassContext, SpecProcTable0, SpecProcIds, - SpecPredId, SpecPredStatus, !ModuleInfo) :- + TVarSet, Types, ExistQVars, Constraints, SpecProcTable0, + ApplicableModes, SpecPredId, SpecPredStatus, !ModuleInfo) :- TSInfo0 = decl_pragma_type_spec_info(PFUMM0, SymName, SpecModuleName, - Subst, TVarSet0, _ExpandedItems, Context, _SeqNum), + Subst, TVarSet0, _ExpandedItems, _PragmaContext, _SeqNum), % Remove any imported structure sharing and reuse information % for the original procedure as they won't be (directly) @@ -193,10 +1386,11 @@ add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, make_n_fresh_vars("HeadVar__", PredFormArityInt, ArgVars, ArgVarSet0, ArgVarSet), + pred_info_get_context(PredInfo0, PredContext), goal_info_init(GoalInfo0), set_of_var.list_to_set(ArgVars, NonLocals), goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1), - goal_info_set_context(Context, GoalInfo1, GoalInfo), + goal_info_set_context(PredContext, GoalInfo1, GoalInfo), % We don't record the called predicate as used -- it is only used % if there is some other call. This call is only used to make @@ -206,8 +1400,7 @@ add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, PredOrFunc = pred_info_is_pred_or_func(PredInfo0), construct_pred_or_func_call(PredId, PredOrFunc, SymName, ArgVars, GoalInfo, Goal), - Clause = clause(selected_modes(SpecProcIds), Goal, - impl_lang_mercury, Context, []), + Clause = clause(ApplicableModes, Goal, impl_lang_mercury, PredContext, []), % XXX We could use explicit type qualifications here for the % argument types, but explicit type qualification doesn't work % correctly with type inference due to a bug somewhere in @@ -242,15 +1435,15 @@ add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, Transform = tn_pragma_type_spec(MaybePredOrFunc0, TVarSet0, Subst), make_transformed_pred_name(UnqualName, Transform, SpecName), pred_info_get_origin(PredInfo0, OrigOrigin), - SubstDesc = one_or_more.map(subst_desc, Subst), + SubstDesc = one_or_more.map(tvar_subst_desc, Subst), PredTransform = pred_transform_pragma_type_spec(SubstDesc), Origin = origin_pred_transform(PredTransform, OrigOrigin, PredId), MaybeCurUserDecl = maybe.no, GoalType = goal_not_for_promise(np_goal_type_none), pred_info_get_var_name_remap(PredInfo0, VarNameRemap), pred_info_init(PredOrFunc, SpecModuleName, SpecName, PredFormArity, - Context, Origin, SpecPredStatus, MaybeCurUserDecl, GoalType, - Markers, Types, TVarSet, ExistQVars, ClassContext, Proofs, + PredContext, Origin, SpecPredStatus, MaybeCurUserDecl, GoalType, + Markers, Types, TVarSet, ExistQVars, Constraints, Proofs, ConstraintMap, Clauses, VarNameRemap, SpecPredInfo0), pred_info_set_proc_table(SpecProcTable, SpecPredInfo0, SpecPredInfo), module_info_get_predicate_table(!.ModuleInfo, PredTable0), @@ -266,8 +1459,8 @@ record_type_specialization(TSInfo0, PredId, SpecPredId, SpecPredStatus, SpecProcIds, RenamedSubst, TVarSet, PFUMM, !ModuleInfo) :- % Record the type specialisation in the module_info. module_info_get_type_spec_info(!.ModuleInfo, TypeSpecInfo0), - TypeSpecInfo0 = type_spec_info(ProcsToSpec0, ForceVersions0, - SpecMap0, PragmaMap0), + TypeSpecInfo0 = type_spec_info(ProcsToSpec0, ForceVersions0, SpecMap0, + PragmaMap0), list.map( ( pred(ProcId::in, PredProcId::out) is det :- PredProcId = proc(PredId, ProcId) @@ -287,7 +1480,7 @@ record_type_specialization(TSInfo0, PredId, SpecPredId, SpecPredStatus, ^ tspec_pfumm := PFUMM) ^ tspec_tsubst := RenamedSubst) ^ tspec_tvarset := TVarSet), - multi_map.set(PredId, TSInfo, PragmaMap0, PragmaMap), + one_or_more_map.add(PredId, TSInfo, PragmaMap0, PragmaMap), TypeSpecInfo = type_spec_info(ProcsToSpec, ForceVersions, SpecMap, PragmaMap), module_info_set_type_spec_info(TypeSpecInfo, !ModuleInfo). @@ -330,7 +1523,9 @@ maybe_record_type_spec_in_qual_info(PredOrFunc, SymName, UserArity, PredStatus, handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, MaybeSubstResult) :- SubstList = one_or_more_to_list(Subst), - assoc_list.keys(SubstList, VarsToSub), + GetTVarType = + ( pred(tvar_subst(TVar, Type)::in, TVar::out, Type::out) is det ), + list.map2(GetTVarType, SubstList, VarsToSub, SubstTypes0), find_duplicate_list_elements(VarsToSub, MultiSubstVars0), ( MultiSubstVars0 = [_ | _], @@ -352,7 +1547,6 @@ handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, % Check that the substitution is not recursive. set.list_to_set(VarsToSub, VarsToSubSet), - assoc_list.values(SubstList, SubstTypes0), type_vars_in_types(SubstTypes0, TVarsInSubstTypes0), set.list_to_set(TVarsInSubstTypes0, TVarsInSubstTypes), @@ -389,9 +1583,12 @@ handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, apply_rec_subst_to_type_list(TypeSubst, Types0, Types), apply_rec_subst_to_univ_exist_constraints(TypeSubst, ClassContext0, ClassContext), - det_list_to_one_or_more(SubAL, RenamedSubst), + PairToTVarSubst = + ( func(TVar - Type) = tvar_subst(TVar, Type) ), + RenamedSubsts = list.map(PairToTVarSubst, SubAL), + det_list_to_one_or_more(RenamedSubsts, OoMRenamedSubsts), MaybeSubstResult = ok5(TVarSet, Types, ExistQVars, - ClassContext, RenamedSubst) + ClassContext, OoMRenamedSubsts) ; SubExistQVars = [_ | _], report_subst_existq_tvars(PredInfo0, Context, @@ -412,6 +1609,8 @@ handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, ) ). +%---------------------% + :- pred find_duplicate_list_elements(list(T)::in, list(T)::out) is det. find_duplicate_list_elements([], []). @@ -423,6 +1622,8 @@ find_duplicate_list_elements([H | T], DupVars) :- DupVars = DupVars0 ). +%---------------------------------------------------------------------------% + :- pred report_subst_existq_tvars(pred_info::in, prog_context::in, list(tvar)::in, error_spec::out) is det. @@ -495,14 +1696,16 @@ report_variables(SubExistQVars, VarSet) = [words(choose_number(SubExistQVars, "variable", "variables")), quote(mercury_vars_to_name_only_vs(VarSet, SubExistQVars))]. +%---------------------------------------------------------------------------% + % Check that the mode list for a `:- pragma type_spec' declaration % specifies a known procedure. % :- pred handle_pragma_type_spec_modes(module_info::in, pred_id::in, pred_info::in, proc_table::in, tvarset::in, prog_context::in, pred_func_or_unknown_maybe_modes::in, - maybe5(proc_table, list(proc_id), user_arity, pred_form_arity, - pred_func_or_unknown_maybe_modes)::out) + maybe6(proc_table, clause_applicable_modes, list(proc_id), user_arity, + pred_form_arity, pred_func_or_unknown_maybe_modes)::out) is det. handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, @@ -528,14 +1731,14 @@ handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, SpecProcTable = map.singleton(ProcId, ProcInfo), user_arity_pred_form_arity(PredOrFunc, UserArity, PredFormArity), - MaybeSpecProcs = ok5(SpecProcTable, [ProcId], - UserArity, PredFormArity, PFUMM) + MaybeSpecProcs = ok6(SpecProcTable, selected_modes([ProcId]), + [ProcId], UserArity, PredFormArity, PFUMM) else varset.coerce(TVarSet, VarSet), DescPieces = [pragma_decl("type_spec"), words("declaration")], report_undeclared_mode_error(ModuleInfo, PredId, PredInfo, VarSet, ArgModes, DescPieces, Context, [], Specs), - MaybeSpecProcs = error5(Specs) + MaybeSpecProcs = error6(Specs) ) ; ModesOrArity = moa_arity(UserArity), @@ -543,8 +1746,8 @@ handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, % is to be type specialized. map.keys(ProcTable, ProcIds), user_arity_pred_form_arity(PredOrFunc, UserArity, PredFormArity), - MaybeSpecProcs = ok5(ProcTable, ProcIds, UserArity, PredFormArity, - PFUMM) + MaybeSpecProcs = ok6(ProcTable, all_modes, ProcIds, + UserArity, PredFormArity, PFUMM) ) ; PFUMM0 = pfumm_unknown(UserArity), @@ -559,8 +1762,8 @@ handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, PFUMM = pfumm_function(moa_arity(UserArity)) ), user_arity_pred_form_arity(PredOrFunc, UserArity, PredFormArity), - MaybeSpecProcs = ok5(ProcTable, ProcIds, UserArity, PredFormArity, - PFUMM) + MaybeSpecProcs = ok6(ProcTable, all_modes, ProcIds, + UserArity, PredFormArity, PFUMM) ). :- pred reset_imported_structure_sharing_reuse( @@ -570,6 +1773,6 @@ reset_imported_structure_sharing_reuse(!ProcInfo) :- proc_info_reset_imported_structure_sharing(!ProcInfo), proc_info_reset_imported_structure_reuse(!ProcInfo). -%----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- end_module hlds.make_hlds.add_pragma.add_pragma_type_spec. -%----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% diff --git a/compiler/check_import_accessibility.m b/compiler/check_import_accessibility.m index 3418cb6d3..60097f141 100644 --- a/compiler/check_import_accessibility.m +++ b/compiler/check_import_accessibility.m @@ -767,7 +767,7 @@ find_any_missing_ancestor_imports(CurrentModule, ParentOrAncestor, % Is ParentModule the same as CurrentModule, or a parent % or an ancestor of CurrentModule? If yes, then CurrentModule % imports it implicitly. - is_submodule(CurrentModule, ParentModule) + is_same_module_or_submodule(CurrentModule, ParentModule) ) then true diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 5466eb110..15e6c8e99 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -2347,7 +2347,7 @@ report_abstract_instance_without_concrete(ClassId, InstanceDefn, !Specs) :- ClassNameString = sym_name_to_string(ClassName), Types = InstanceDefn ^ instdefn_types, TVarSet = InstanceDefn ^ instdefn_tvarset, - TypesStr = mercury_type_list_to_string(TVarSet, Types), + TypesStr = mercury_types_to_string(TVarSet, print_name_only, Types), string.format("%s(%s)", [s(ClassNameString), s(TypesStr)], InstanceName), Pieces = [words("Error: this abstract instance declaration"), words("for"), quote(InstanceName), @@ -2724,7 +2724,7 @@ instance_name(WhichTypes, Limit, Quals, ClassId, InstanceDefn) Types0, Types) ), TVarSet = InstanceDefn ^ instdefn_tvarset, - TypesStr = mercury_type_list_to_string(TVarSet, Types), + TypesStr = mercury_types_to_string(TVarSet, print_name_only, Types), string.format("%s(%s)", [s(ClassNameStr), s(TypesStr)], InstanceName) ). diff --git a/compiler/convert_parse_tree.m b/compiler/convert_parse_tree.m index eb81e5ff0..40e518bf3 100644 --- a/compiler/convert_parse_tree.m +++ b/compiler/convert_parse_tree.m @@ -1161,6 +1161,7 @@ classify_plain_opt_items([Item | Items], !TypeDefns, !ForeignEnums, ( DeclPragma = decl_pragma_obsolete_pred(_) ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_format_call(_) + ; DeclPragma = decl_pragma_type_spec_constr(_) ; DeclPragma = decl_pragma_oisu(_) ), Pieces = [words("A .opt file may not contain")] ++ @@ -1400,6 +1401,7 @@ classify_trans_opt_items([Item | Items], !TermInfos, !Term2Infos, ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_format_call(_) ; DeclPragma = decl_pragma_type_spec(_) + ; DeclPragma = decl_pragma_type_spec_constr(_) ; DeclPragma = decl_pragma_oisu(_) ), Pieces = [words("A .trans_opt file may not contain")] ++ diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index aade7e2b9..797809e6b 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -1513,6 +1513,12 @@ replace_in_abstract_instance_info(ModuleName, MaybeRecord, TypeEqvMap, _, replace_in_decl_pragma_info(ModuleName, MaybeRecord, TypeEqvMap, InstEqvMap, DeclPragma0, DeclPragma, !RecompInfo, !UsedModules, Specs) :- ( + DeclPragma0 = decl_pragma_type_spec_constr(TypeSpecConstr0), + replace_in_decl_pragma_type_spec_constr(ModuleName, MaybeRecord, + TypeEqvMap, InstEqvMap, TypeSpecConstr0, TypeSpecConstr, + !RecompInfo, !UsedModules, Specs), + DeclPragma = decl_pragma_type_spec_constr(TypeSpecConstr) + ; DeclPragma0 = decl_pragma_type_spec(TypeSpec0), replace_in_decl_pragma_type_spec(ModuleName, MaybeRecord, TypeEqvMap, InstEqvMap, TypeSpec0, TypeSpec, @@ -1532,6 +1538,55 @@ replace_in_decl_pragma_info(ModuleName, MaybeRecord, TypeEqvMap, InstEqvMap, Specs = [] ). +:- pred replace_in_decl_pragma_type_spec_constr(module_name::in, + maybe_record_sym_name_use::in, type_eqv_map::in, inst_eqv_map::in, + decl_pragma_type_spec_constr_info::in, + decl_pragma_type_spec_constr_info::out, + maybe(recompilation_info)::in, maybe(recompilation_info)::out, + used_modules::in, used_modules::out, list(error_spec)::out) is det. + +replace_in_decl_pragma_type_spec_constr(ModuleName, MaybeRecord, + TypeEqvMap, _InstEqvMap, TypeSpecInfoConstr0, TypeSpecInfoConstr, + !RecompInfo, !UsedModules, []) :- + TypeSpecInfoConstr0 = decl_pragma_type_spec_constr_info(PragmaModuleName, + OoMConstraints0, ApplyToSupers, OoMSubsts0, TVarSet0, ItemIds0, + Context, SeqNum), + % XXX I (zs) don't understand the purpose of the test in the code that + % sets ExpandedItems0 in replace_in_decl_pragma_type_spec below. + % The commit that added that code (the commit by Simon that added + % the initial implementation of smart recompilation) does not mention + % any rationale either. I cannot copy that test since there is no PredName + % here. So this setting of ExpandedItems0 here is just a guess. Whether + % it is a correct guess or not will matter only once smart recompilation + % is completed, in the fullness of time. + OoMConstraints0 = one_or_more(HeadConstraint0, TailConstraints0), + ExpandedItems0 = eqv_expand_info(ModuleName, ItemIds0), + replace_in_var_or_ground_constraint_location(MaybeRecord, TypeEqvMap, + HeadConstraint0, HeadConstraint, TVarSet0, TVarSet1, + ExpandedItems0, ExpandedItems1, !UsedModules), + list.map_foldl3( + replace_in_var_or_ground_constraint_location(MaybeRecord, TypeEqvMap), + TailConstraints0, TailConstraints, TVarSet1, TVarSet2, + ExpandedItems1, ExpandedItems2, !UsedModules), + OoMConstraints = one_or_more(HeadConstraint, TailConstraints), + OoMSubsts0 = one_or_more(HeadSubst0, TailSubsts0), + replace_in_subst(MaybeRecord, TypeEqvMap, + HeadSubst0, HeadSubst, TVarSet2, TVarSet3, + ExpandedItems2, ExpandedItems3, !UsedModules), + list.map_foldl3(replace_in_subst(MaybeRecord, TypeEqvMap), + TailSubsts0, TailSubsts, TVarSet3, TVarSet, + ExpandedItems3, ExpandedItems, !UsedModules), + OoMSubsts = one_or_more(HeadSubst, TailSubsts), + ( + ExpandedItems = no_eqv_expand_info, + ItemIds = ItemIds0 + ; + ExpandedItems = eqv_expand_info(_, ItemIds) + ), + TypeSpecInfoConstr = decl_pragma_type_spec_constr_info(PragmaModuleName, + OoMConstraints, ApplyToSupers, OoMSubsts, TVarSet, ItemIds, + Context, SeqNum). + :- pred replace_in_decl_pragma_type_spec(module_name::in, maybe_record_sym_name_use::in, type_eqv_map::in, inst_eqv_map::in, decl_pragma_type_spec_info::in, decl_pragma_type_spec_info::out, @@ -1552,11 +1607,8 @@ replace_in_decl_pragma_type_spec(ModuleName, MaybeRecord, else ExpandedItems0 = eqv_expand_info(ModuleName, ItemIds0) ), - Subst0 = one_or_more(HeadSubst0, TailSubsts0), - replace_in_subst(MaybeRecord, TypeEqvMap, - HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, + replace_in_subst(MaybeRecord, TypeEqvMap, Subst0, Subst, TVarSet0, TVarSet, ExpandedItems0, ExpandedItems, !UsedModules), - Subst = one_or_more(HeadSubst, TailSubsts), ( ExpandedItems = no_eqv_expand_info, ItemIds = ItemIds0 @@ -2093,14 +2145,14 @@ replace_in_type_list_location_circ_2(_MaybeRecord, _TypeEqvMap, _Seen, [], [], unchanged, !ContainsCirc, !TVarSet, !EquivTypeInfo, !UsedModules). replace_in_type_list_location_circ_2(MaybeRecord, TypeEqvMap, Seen, - List0 @ [Type0 | Types0], List, Changed, !Circ, !TVarSet, + Types0 @ [HeadType0 | TailTypes0], Types, Changed, !Circ, !TVarSet, !EquivTypeInfo, !UsedModules) :- replace_in_type_maybe_record_use_2(MaybeRecord, TypeEqvMap, Seen, - Type0, Type, HeadChanged, HeadCirc, !TVarSet, + HeadType0, HeadType, HeadChanged, HeadCirc, !TVarSet, !EquivTypeInfo, !UsedModules), set.union(HeadCirc, !Circ), replace_in_type_list_location_circ_2(MaybeRecord, TypeEqvMap, Seen, - Types0, Types, TailChanged, !Circ, !TVarSet, + TailTypes0, TailTypes, TailChanged, !Circ, !TVarSet, !EquivTypeInfo, !UsedModules), ( if ( HeadChanged = changed @@ -2108,10 +2160,10 @@ replace_in_type_list_location_circ_2(MaybeRecord, TypeEqvMap, Seen, ) then Changed = changed, - List = [Type | Types] + Types = [HeadType | TailTypes] else Changed = unchanged, - List = List0 + Types = Types0 ). %---------------------------------------------------------------------------% @@ -2215,6 +2267,44 @@ replace_in_prog_constraint_location(MaybeRecord, TypeEqvMap, ArgTypes0, ArgTypes, _, _, !TVarSet, !EquivTypeInfo, !UsedModules), Constraint = constraint(ClassName, ArgTypes). +%---------------------% + +:- pred replace_in_var_or_ground_constraint_location( + maybe_record_sym_name_use::in, type_eqv_map::in, + var_or_ground_constraint::in, var_or_ground_constraint::out, + tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, + used_modules::in, used_modules::out) is det. + +replace_in_var_or_ground_constraint_location(MaybeRecord, TypeEqvMap, + Constraint0, Constraint, !TVarSet, !EquivTypeInfo, !UsedModules) :- + Constraint0 = var_or_ground_constraint(ClassName, Args0, Context), + list.map_foldl3( + replace_in_var_or_ground_type_location(MaybeRecord, TypeEqvMap), + Args0, Args, !TVarSet, !EquivTypeInfo, !UsedModules), + Constraint = var_or_ground_constraint(ClassName, Args, Context). + +:- pred replace_in_var_or_ground_type_location(maybe_record_sym_name_use::in, + type_eqv_map::in, var_or_ground_type::in, var_or_ground_type::out, + tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, + used_modules::in, used_modules::out) is det. + +replace_in_var_or_ground_type_location(MaybeRecord, TypeEqvMap, + Arg0, Arg, !TVarSet, !EquivTypeInfo, !UsedModules) :- + ( + Arg0 = type_var_name(_, _), + Arg = Arg0 + ; + Arg0 = ground_type(GroundType0), + Type0 = coerce(GroundType0), + replace_in_type_maybe_record_use(MaybeRecord, TypeEqvMap, + Type0, Type, _, !TVarSet, !EquivTypeInfo, !UsedModules), + ( if type_is_ground(Type, GroundType) then + Arg = ground_type(GroundType) + else + unexpected($pred, "expanded ground type is not ground") + ) + ). + %---------------------------------------------------------------------------% :- pred replace_in_class_interface(maybe_record_sym_name_use::in, @@ -2281,26 +2371,39 @@ replace_in_class_decl(MaybeRecord, TypeEqvMap, InstEqvMap, Decl0, Decl, %---------------------------------------------------------------------------% :- pred replace_in_subst(maybe_record_sym_name_use::in, type_eqv_map::in, - pair(tvar, mer_type)::in, pair(tvar, mer_type)::out, - assoc_list(tvar, mer_type)::in, assoc_list(tvar, mer_type)::out, + type_subst::in, type_subst::out, tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, used_modules::in, used_modules::out) is det. -replace_in_subst(MaybeRecord, TypeEqvMap, - HeadVar - HeadType0, HeadVar - HeadType, +replace_in_subst(MaybeRecord, TypeEqvMap, Subst0, Subst, + !TVarSet, !ExpandedItems, !UsedModules) :- + Subst0 = one_or_more(HeadSubst0, TailSubsts0), + replace_in_tvar_substs(MaybeRecord, TypeEqvMap, + HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, + !TVarSet, !ExpandedItems, !UsedModules), + Subst = one_or_more(HeadSubst, TailSubsts). + +:- pred replace_in_tvar_substs(maybe_record_sym_name_use::in, type_eqv_map::in, + tvar_subst::in, tvar_subst::out, + list(tvar_subst)::in, list(tvar_subst)::out, + tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, + used_modules::in, used_modules::out) is det. + +replace_in_tvar_substs(MaybeRecord, TypeEqvMap, + tvar_subst(HeadVar, HeadType0), tvar_subst(HeadVar, HeadType), TailVarsTypes0, TailVarsTypes, - !TVarSet, !EquivTypeInfo, !UsedModules) :- + !TVarSet, !ExpandedItems, !UsedModules) :- replace_in_type_maybe_record_use(MaybeRecord, TypeEqvMap, - HeadType0, HeadType, _, !TVarSet, !EquivTypeInfo, !UsedModules), + HeadType0, HeadType, _, !TVarSet, !ExpandedItems, !UsedModules), ( TailVarsTypes0 = [], TailVarsTypes = [] ; TailVarsTypes0 = [HeadTailVarType0 | TailTailVarsTypes0], - replace_in_subst(MaybeRecord, TypeEqvMap, + replace_in_tvar_substs(MaybeRecord, TypeEqvMap, HeadTailVarType0, HeadTailVarType, TailTailVarsTypes0, TailTailVarsTypes, - !TVarSet, !EquivTypeInfo, !UsedModules), + !TVarSet, !ExpandedItems, !UsedModules), TailVarsTypes = [HeadTailVarType | TailTailVarsTypes] ). diff --git a/compiler/handle_options.m b/compiler/handle_options.m index 7b802bfd3..bc41849a9 100644 --- a/compiler/handle_options.m +++ b/compiler/handle_options.m @@ -2297,6 +2297,7 @@ handle_stack_layout_options(!Globals, OT_OptDups0, OT_OptDups, % transitive_optimization % warn_wrong_module_name % warn_unused_interface_imports + % inform_generated_type_spec_pragmas % :- pred handle_opmode_implications(op_mode::in, globals::in, globals::out) is det. @@ -2304,6 +2305,8 @@ handle_stack_layout_options(!Globals, OT_OptDups0, OT_OptDups, handle_opmode_implications(OpMode, !Globals) :- % Disable `--smart-recompilation' unless we are generating target code. globals.lookup_bool_option(!.Globals, smart_recompilation, Smart0), + globals.lookup_bool_option(!.Globals, inform_generated_type_spec_pragmas, + Inform0), ( OpMode = opm_top_args(OpModeArgs, _), % Disable --line-numbers when building the `.int', `.opt', etc. files, @@ -2334,7 +2337,8 @@ handle_opmode_implications(OpMode, !Globals) :- globals.set_option(generate_item_version_numbers, bool(no), !Globals) ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; OpModeArgs = opma_augment(OpModeAugment), ( @@ -2343,7 +2347,8 @@ handle_opmode_implications(OpMode, !Globals) :- globals.lookup_bool_option(!.Globals, halt_at_warn_make_opt, HaltAtWarn), globals.set_option(halt_at_warn, bool(HaltAtWarn), !Globals), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; OpModeAugment = opmau_make_trans_opt, globals.set_option(transitive_optimization, bool(yes), @@ -2352,39 +2357,65 @@ handle_opmode_implications(OpMode, !Globals) :- globals.lookup_bool_option(!.Globals, halt_at_warn_make_opt, HaltAtWarn), globals.set_option(halt_at_warn, bool(HaltAtWarn), !Globals), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; ( OpModeAugment = opmau_make_analysis_registry ; OpModeAugment = opmau_make_xml_documentation ; OpModeAugment = opmau_typecheck_only - ; OpModeAugment = opmau_errorcheck_only ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no + ; + OpModeAugment = opmau_errorcheck_only, + Smart = bool.no, + % We execute all the tests in tests/warnings with + % --errorcheck-only. + Inform = Inform0 ; OpModeAugment = opmau_generate_code(_), - Smart = Smart0 + Smart = Smart0, + Inform = Inform0 ) ; ( OpModeArgs = opma_generate_dependencies(_) ; OpModeArgs = opma_generate_dependency_file ; OpModeArgs = opma_convert_to_mercury ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ) ; OpMode = opm_top_generate_source_file_mapping, % Without an existing source file mapping, there is no "right" % module name. globals.set_option(warn_wrong_module_name, bool(no), !Globals), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; ( OpMode = opm_top_generate_standalone_interface(_) ; OpMode = opm_top_query(_) ; OpMode = opm_top_make ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ), - globals.set_option(smart_recompilation, bool(Smart), !Globals). + % We do this here instead of replacing all the "Smart = bool.no"s above + % with a call to globals.set_option, because this way, we would get an + % error message from the compiler if we added a new op_mode and failed to + % explicitly consider what the value of Smart should be in its switch arm. + ( if Smart = Smart0 then + true + else + globals.set_option(smart_recompilation, bool(Smart), !Globals) + ), + % Thet consideration applies here as well. + ( if Inform = Inform0 then + true + else + globals.set_option(inform_generated_type_spec_pragmas, bool(Inform), + !Globals) + ). %---------------------% diff --git a/compiler/hlds_class.m b/compiler/hlds_class.m index 6209d1e33..5aed0d9fb 100644 --- a/compiler/hlds_class.m +++ b/compiler/hlds_class.m @@ -62,6 +62,12 @@ classdefn_vars :: list(tvar), % SuperClasses. + % + % Every type appearing in every superclass constraint must be + % either a type variable, or a ground type; types containing + % both type variables and type constructors are not allowed. + % This is enforced by parse_superclass_constraints in + % parse_class.m. classdefn_supers :: list(prog_constraint), % Functional dependencies. diff --git a/compiler/hlds_module.m b/compiler/hlds_module.m index 1e7f87834..d0c9dabc9 100644 --- a/compiler/hlds_module.m +++ b/compiler/hlds_module.m @@ -53,6 +53,7 @@ :- import_module maybe. :- import_module multi_map. :- import_module one_or_more. +:- import_module one_or_more_map. :- import_module pair. :- import_module set. :- import_module set_tree234. @@ -106,6 +107,9 @@ table_struct_attrs :: table_attributes ). +:- type type_spec_pragma_map == + one_or_more_map(pred_id, decl_pragma_type_spec_info). + % List of procedures for which there are user-requested type % specializations, and a list of predicates which should be processed % by higher_order.m to ensure the production of those versions. @@ -117,7 +121,7 @@ % Set of predicates which need to be processed by % higher_order.m to produce those specialized versions. - must_process_preds :: set(pred_id), + must_process_preds :: set(pred_id), % Map from predicates for which the user requested a type % specialization to the list of predicates which must be @@ -128,8 +132,7 @@ % Type spec pragmas to be placed in the `.opt' file if a % predicate becomes exported. - pragma_map :: multi_map(pred_id, - decl_pragma_type_spec_info) + pragma_map :: type_spec_pragma_map ). % Once filled in by simplify_proc.m (for all non-lambda procedures) diff --git a/compiler/hlds_out_typeclass_table.m b/compiler/hlds_out_typeclass_table.m index 5567669c5..68200ce3d 100644 --- a/compiler/hlds_out_typeclass_table.m +++ b/compiler/hlds_out_typeclass_table.m @@ -65,8 +65,8 @@ write_classes(Info, Stream, ClassTable, !IO) :- pair(class_id, hlds_class_defn)::in, io::di, io::uo) is det. write_class_defn(Info, Stream, ClassId - ClassDefn, !IO) :- - ClassDefn = hlds_class_defn(_, TVarSet, _, Vars, Constraints, FunDeps, - _, _, MethodInfos, Context, _), + ClassDefn = hlds_class_defn(_, TVarSet, _, Vars, SuperClassConstraints, + FunDeps, _, _, MethodInfos, Context, _), io.format(Stream, "\n%% %s:\n", [s(class_id_to_string(ClassId))], !IO), maybe_output_context_comment(Stream, 0u, "", Context, !IO), @@ -84,12 +84,12 @@ write_class_defn(Info, Stream, ClassId - ClassDefn, !IO) :- io.write_string(Stream, "% Functional dependencies:\n", !IO), list.foldl(hlds_output_fundep(Stream, IndentStr), FunDeps, !IO), - io.write_string(Stream, "% Constraints:\n", !IO), + io.write_string(Stream, "% Superclass constraints:\n", !IO), list.foldl( hlds_output_constraint(Stream, IndentStr, TVarSet, VarNamePrint), - Constraints, !IO), + SuperClassConstraints, !IO), - io.write_string(Stream, "% Class Methods:\n", !IO), + io.write_string(Stream, "% Class methods:\n", !IO), list.foldl(write_method_info(Stream, IndentStr), MethodInfos, !IO). :- pred hlds_output_fundep(io.text_output_stream::in, string::in, diff --git a/compiler/intermod.m b/compiler/intermod.m index 0d538e5ae..27a83a844 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -110,7 +110,6 @@ :- import_module list. :- import_module map. :- import_module maybe. -:- import_module multi_map. :- import_module one_or_more. :- import_module one_or_more_map. :- import_module pair. @@ -857,8 +856,8 @@ intermod_gather_pred_marker_pragmas_loop(PredOrFunc, PredSymName, UserArity, intermod_gather_pred_type_spec_pragmas(ModuleInfo, PredId, TypeSpecs) :- module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo), PragmaMap = TypeSpecInfo ^ pragma_map, - ( if multi_map.search(PragmaMap, PredId, TypeSpecsPrime) then - TypeSpecs = TypeSpecsPrime + ( if one_or_more_map.search(PragmaMap, PredId, OoMTypeSpecs) then + TypeSpecs = one_or_more_to_list(OoMTypeSpecs) else TypeSpecs = [] ). diff --git a/compiler/item_util.m b/compiler/item_util.m index f83a95548..ee131cfb4 100644 --- a/compiler/item_util.m +++ b/compiler/item_util.m @@ -1572,6 +1572,10 @@ decl_pragma_desc_pieces(Pragma) = Pieces :- ; Pragma = decl_pragma_format_call(_), Pieces = [pragma_decl("format_call"), words("declaration")] + ; + Pragma = decl_pragma_type_spec_constr(_), + Pieces = [pragma_decl("type_spec_constrained_preds"), + words("declaration")] ; Pragma = decl_pragma_type_spec(_), Pieces = [pragma_decl("type_spec"), words("declaration")] diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m index 3341e82a4..129e74b43 100644 --- a/compiler/make_hlds_passes.m +++ b/compiler/make_hlds_passes.m @@ -200,7 +200,7 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, InstDefns, ModeDefns, PredDecls, ModeDecls, Promises, Typeclasses, Instances, Initialises, Finalises, Mutables, TypeRepnMap, ForeignEnums, ForeignExportEnums, - DeclPragmas, DeclMarkers, DeclTypeSpec, + DeclPragmas, DeclMarkers, DeclTypeSpecConstr, DeclTypeSpec, DeclTermination, DeclTermination2, DeclSharing, DeclReuse, ImplPragmas, ImplMarkers, GenUnusedArgs, GenExceptions, GenTrailing, GenMMTabling, @@ -529,7 +529,9 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, % This times does have to be after we have processed all predicate % and mode declarations, since several pragmas do refer to predicates % or to modes of predicates. - add_decl_pragmas(DeclPragmas, + add_decl_pragmas(ProgressStream, DeclPragmas, + !ModuleInfo, !QualInfo, !Specs), + add_decl_pragmas_type_spec_constr(ProgressStream, DeclTypeSpecConstr, !ModuleInfo, !QualInfo, !Specs), add_decl_pragmas_type_spec(DeclTypeSpec, !ModuleInfo, !QualInfo, !Specs), diff --git a/compiler/make_hlds_separate_items.m b/compiler/make_hlds_separate_items.m index 2bfd5d0c0..3224cd586 100644 --- a/compiler/make_hlds_separate_items.m +++ b/compiler/make_hlds_separate_items.m @@ -81,6 +81,7 @@ list(item_foreign_export_enum_info)::out, ims_list(item_decl_pragma_info)::out, ims_list(item_decl_marker_info)::out, + list(decl_pragma_type_spec_constr_info)::out, list(decl_pragma_type_spec_info)::out, list(decl_pragma_termination_info)::out, list(decl_pragma_termination2_info)::out, @@ -137,6 +138,8 @@ ia_fees :: cord(item_foreign_export_enum_info), ia_decl_pragmas :: ims_cord(item_decl_pragma_info), ia_decl_marker :: ims_cord(item_decl_marker_info), + ia_decl_type_spec_constr + :: cord(decl_pragma_type_spec_constr_info), ia_decl_type_spec :: cord(decl_pragma_type_spec_info), ia_decl_term :: cord(decl_pragma_termination_info), ia_decl_term2 :: cord(decl_pragma_termination2_info), @@ -161,7 +164,8 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, Promises, TypeClasses, Instances, Initialises, Finalises, Mutables, TypeRepnMap, ForeignEnums, ForeignExportEnums, - DeclPragmas, DeclMarkers, DeclPragmasTypeSpec, + DeclPragmas, DeclMarkers, + DeclPragmasTypeSpecConstr, DeclPragmasTypeSpec, DeclPragmasTermInfo, DeclPragmasTerm2Info, DeclPragmasSharing, DeclPragmasReuse, ImplPragmas, ImplMarkers, GenPragmasUnusedArgs, GenPragmasExceptions, @@ -184,7 +188,8 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, - cord.init, cord.init, cord.init, + cord.init, cord.init, + cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, @@ -230,7 +235,8 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, PredDeclsCord, ModeDeclsCord, ClausesCord, ForeignProcsCord, ForeignEnumsCord, ForeignExportEnumsCord, - DeclPragmasCord, DeclMarkersCord, DeclPragmasTypeSpecCord, + DeclPragmasCord, DeclMarkersCord, + DeclPragmasTypeSpecConstrCord, DeclPragmasTypeSpecCord, DeclPragmasTermInfoCord, DeclPragmasTerm2InfoCord, DeclPragmasSharingCord, DeclPragmasReuseCord, ImplPragmasCord, ImplMarkersCord, @@ -258,6 +264,7 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, ForeignExportEnums = cord.list(ForeignExportEnumsCord), DeclPragmas = cord.list(DeclPragmasCord), DeclMarkers = cord.list(DeclMarkersCord), + DeclPragmasTypeSpecConstr = cord.list(DeclPragmasTypeSpecConstrCord), DeclPragmasTypeSpec = cord.list(DeclPragmasTypeSpecCord), DeclPragmasTermInfo = cord.list(DeclPragmasTermInfoCord), DeclPragmasTerm2Info = cord.list(DeclPragmasTerm2InfoCord), @@ -426,7 +433,8 @@ acc_parse_tree_module_src(ParseTreeModuleSrc, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -521,7 +529,8 @@ acc_parse_tree_module_src(ParseTreeModuleSrc, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses, AccForeignProcs, AccForeignEnums, AccForeignExportEnums, - AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpec0, + AccDeclPragmas, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas, AccImplMarkers, @@ -569,7 +578,8 @@ acc_parse_tree_int0(ParseTreeInt0, ReadWhy0, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -649,7 +659,8 @@ acc_parse_tree_int0(ParseTreeInt0, ReadWhy0, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses0, AccForeignProcs0, AccForeignEnums, AccForeignExportEnums0, - AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpec0, + AccDeclPragmas, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -722,7 +733,8 @@ acc_parse_tree_int1(ParseTreeInt1, ReadWhy1, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -787,7 +799,8 @@ acc_parse_tree_int1(ParseTreeInt1, ReadWhy1, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses0, AccForeignProcs0, AccForeignEnums, AccForeignExportEnums0, - AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpec0, + AccDeclPragmas, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -838,7 +851,8 @@ acc_parse_tree_int2(ParseTreeInt2, ReadWhy2, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -891,7 +905,8 @@ acc_parse_tree_int2(ParseTreeInt2, ReadWhy2, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -921,7 +936,8 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -982,7 +998,8 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses, AccForeignProcs, AccForeignEnums, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers, AccDeclPragmasTypeSpec, + AccDeclPragmas0, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec, AccDeclPragmasTermInfo, AccDeclPragmasTerm2Info, AccDeclPragmasSharing, AccDeclPragmasReuse, AccImplPragmas0, AccImplMarkers, @@ -1006,7 +1023,8 @@ acc_parse_tree_trans_opt(ParseTreeTransOpt, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -1035,7 +1053,8 @@ acc_parse_tree_trans_opt(ParseTreeTransOpt, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo, AccDeclPragmasTerm2Info, AccDeclPragmasSharing, AccDeclPragmasReuse, AccImplPragmas0, AccImplMarkers0, diff --git a/compiler/maybe_error.m b/compiler/maybe_error.m index af7d132d8..c0902781c 100644 --- a/compiler/maybe_error.m +++ b/compiler/maybe_error.m @@ -41,6 +41,10 @@ ---> error5(E) ; ok5(T1, T2, T3, T4, T5). +:- type maybe6(T1, T2, T3, T4, T5, T6, E) + ---> error6(E) + ; ok6(T1, T2, T3, T4, T5, T6). + :- type maybe1(T1) == maybe1(T1, list(error_spec)). :- type maybe2(T1, T2) == @@ -51,6 +55,8 @@ maybe4(T1, T2, T3, T4, list(error_spec)). :- type maybe5(T1, T2, T3, T4, T5) == maybe5(T1, T2, T3, T4, T5, list(error_spec)). +:- type maybe6(T1, T2, T3, T4, T5, T6) == + maybe6(T1, T2, T3, T4, T5, T6, list(error_spec)). %---------------------% @@ -74,6 +80,10 @@ ---> error5(ground) ; ok5(I1, I2, I3, I4, I5). +:- inst maybe6(I1, I2, I3, I4, I5, I6) for maybe6/7 + ---> error6(ground) + ; ok6(I1, I2, I3, I4, I5, I6). + %---------------------% :- func get_any_errors1(maybe1(T1)) = list(error_spec). @@ -81,6 +91,7 @@ :- func get_any_errors3(maybe3(T1, T2, T3)) = list(error_spec). :- func get_any_errors4(maybe4(T1, T2, T3, T4)) = list(error_spec). :- func get_any_errors5(maybe5(T1, T2, T3, T4, T5)) = list(error_spec). +:- func get_any_errors6(maybe6(T1, T2, T3, T4, T5, T6)) = list(error_spec). :- func get_any_errors_warnings2(maybe2(T1, list(warning_spec))) = list(error_spec). @@ -90,6 +101,8 @@ list(error_spec). :- func get_any_errors_warnings5(maybe5(T1, T2, T3, T4, list(warning_spec))) = list(error_spec). +:- func get_any_errors_warnings6(maybe6(T1, T2, T3, T4, T5, + list(warning_spec))) = list(error_spec). :- pred project_ok1(maybe1(T1)::in, T1::out) is semidet. :- pred det_project_ok1(maybe1(T1)::in, T1::out) is det. @@ -121,6 +134,9 @@ get_any_errors4(error4(Specs)) = Specs. get_any_errors5(ok5(_, _, _, _, _)) = []. get_any_errors5(error5(Specs)) = Specs. +get_any_errors6(ok6(_, _, _, _, _, _)) = []. +get_any_errors6(error6(Specs)) = Specs. + %---------------------% get_any_errors_warnings2(ok2(_, Specs)) = Specs. @@ -135,6 +151,9 @@ get_any_errors_warnings4(error4(Specs)) = Specs. get_any_errors_warnings5(ok5(_, _, _, _, Specs)) = Specs. get_any_errors_warnings5(error5(Specs)) = Specs. +get_any_errors_warnings6(ok6(_, _, _, _, _, Specs)) = Specs. +get_any_errors_warnings6(error6(Specs)) = Specs. + %---------------------% project_ok1(Maybe1, Item) :- diff --git a/compiler/module_qual.qual_errors.m b/compiler/module_qual.qual_errors.m index 85190046f..10f9d8567 100644 --- a/compiler/module_qual.qual_errors.m +++ b/compiler/module_qual.qual_errors.m @@ -54,6 +54,13 @@ % The identity of the entity the constraint is on: % whether it is predicate or function, its name, and its arity. pf_sym_name_arity + ) + ; mqcec_type_spec_constr(prog_context, + % The constraint occurs in a type_spec_constraint pragma + % at the given location. The pragma has nothing that can serve + % as its "name" that is more useful than the id of the module + % to which it applies. + module_name ). :- type mq_error_context @@ -461,6 +468,10 @@ mq_constraint_error_context_to_pieces(ConstraintErrorContext, Start = "on", Pieces = [words("declaration of"), unqual_pf_sym_name_pred_form_arity(PFSymNameArity)] + ; + ConstraintErrorContext = mqcec_type_spec_constr(Context, _ModuleName), + Start = "in", + Pieces = [pragma_decl("type_spec_constrained_preds")] ). :- pred mq_error_context_to_pieces(mq_error_context::in, diff --git a/compiler/module_qual.qualify_items.m b/compiler/module_qual.qualify_items.m index 9f3a763f2..124b77d6c 100644 --- a/compiler/module_qual.qualify_items.m +++ b/compiler/module_qual.qualify_items.m @@ -70,6 +70,7 @@ :- import_module parse_tree.module_qual.qual_errors. :- import_module parse_tree.prog_data_foreign. :- import_module parse_tree.prog_data_pragma. +:- import_module parse_tree.prog_type_test. :- import_module int. :- import_module one_or_more. @@ -1415,6 +1416,8 @@ qualify_prog_constraints(InInt, ConstraintErrorContext, ExistCs0, ExistCs, !Info, !Specs), Constraints = univ_exist_constraints(UnivCs, ExistCs). +%---------------------% + :- pred qualify_prog_constraint_list(mq_in_interface::in, mq_constraint_error_context::in, list(prog_constraint)::in, list(prog_constraint)::out, @@ -1448,6 +1451,70 @@ qualify_prog_constraint(InInt, ContainingErrorContext, qualify_type_list(InInt, ErrorContext, Types0, Types, !Info, !Specs), Constraint = constraint(ClassName, Types). +%---------------------% + +:- pred qualify_var_or_ground_constraint_list(mq_in_interface::in, + mq_constraint_error_context::in, + list(var_or_ground_constraint)::in, list(var_or_ground_constraint)::out, + mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_var_or_ground_constraint_list(_InInt, _ConstraintErrorContext, + [], [], !Info, !Specs). +qualify_var_or_ground_constraint_list(InInt, ConstraintErrorContext, + [Constraint0 | Constraints0], [Constraint | Constraints], + !Info, !Specs) :- + qualify_var_or_ground_constraint(InInt, ConstraintErrorContext, + Constraint0, Constraint, !Info, !Specs), + qualify_var_or_ground_constraint_list(InInt, ConstraintErrorContext, + Constraints0, Constraints, !Info, !Specs). + +:- pred qualify_var_or_ground_constraint(mq_in_interface::in, + mq_constraint_error_context::in, + var_or_ground_constraint::in, var_or_ground_constraint::out, + mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_var_or_ground_constraint(InInt, ContainingErrorContext, + Constraint0, Constraint, !Info, !Specs) :- + Constraint0 = var_or_ground_constraint(ClassName0, Types0, Context), + list.length(Types0, Arity), + OutsideContext = mqec_typeclass_constraint_name(ContainingErrorContext), + qualify_class_name(InInt, OutsideContext, + mq_id(ClassName0, Arity), ClassName, !Info, !Specs), + ErrorContext = mqec_typeclass_constraint(ClassName0, Arity, + ContainingErrorContext), + qualify_var_or_ground_type_list(InInt, ErrorContext, Types0, Types, + !Info, !Specs), + Constraint = var_or_ground_constraint(ClassName, Types, Context). + +:- pred qualify_var_or_ground_type_list(mq_in_interface::in, + mq_error_context::in, + list(var_or_ground_type)::in, list(var_or_ground_type)::out, + mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_var_or_ground_type_list(_, _, [], [], !Info, !Specs). +qualify_var_or_ground_type_list(InInt, ErrorContext, + [Arg0 | Args0], [Arg | Args], !Info, !Specs) :- + ( + Arg0 = type_var_name(_, _), + Arg = Arg0 + ; + Arg0 = ground_type(GroundType0), + Type0 = coerce(GroundType0), + qualify_type(InInt, ErrorContext, Type0, Type, !Info, !Specs), + ( if type_is_ground(Type, GroundType) then + Arg = ground_type(GroundType) + else + unexpected($pred, "qualified ground type is not ground") + ) + ), + qualify_var_or_ground_type_list(InInt, ErrorContext, + Args0, Args, !Info, !Specs). + +%---------------------% + :- pred qualify_class_name(mq_in_interface::in, mq_error_context::in, mq_id::in, sym_name::out, mq_info::in, mq_info::out, list(error_spec)::in, list(error_spec)::out) is det. @@ -1613,6 +1680,29 @@ qualify_instance_method(DefaultModuleName, InstanceMethod0, InstanceMethod) :- module_qualify_item_decl_pragma(InInt, Pragma0, Pragma, !Info, !Specs) :- ( + Pragma0 = decl_pragma_type_spec_constr(TypeSpecConstrInfo0), + TypeSpecConstrInfo0 = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints0, ApplyToSupers, OoMSubsts0, TVarSet, Items, + Context, SeqNum), + ConstraintErrorContext = mqcec_type_spec_constr(Context, ModuleName), + OoMConstraints0 = one_or_more(HeadConstraint0, TailConstraints0), + qualify_var_or_ground_constraint(InInt, ConstraintErrorContext, + HeadConstraint0, HeadConstraint, !Info, !Specs), + qualify_var_or_ground_constraint_list(InInt, ConstraintErrorContext, + TailConstraints0, TailConstraints, !Info, !Specs), + OoMConstraints = one_or_more(HeadConstraint, TailConstraints), + ErrorContext = mqec_pragma_decl(Context, Pragma0), + OoMSubsts0 = one_or_more(HeadSubst0, TailSubsts0), + qualify_type_subst(InInt, ErrorContext, + HeadSubst0, HeadSubst, !Info, !Specs), + list.map_foldl2(qualify_type_subst(InInt, ErrorContext), + TailSubsts0, TailSubsts, !Info, !Specs), + OoMSubsts = one_or_more(HeadSubst, TailSubsts), + TypeSpecConstrInfo = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints, ApplyToSupers, OoMSubsts, TVarSet, Items, + Context, SeqNum), + Pragma = decl_pragma_type_spec_constr(TypeSpecConstrInfo) + ; Pragma0 = decl_pragma_type_spec(TypeSpecInfo0), TypeSpecInfo0 = decl_pragma_type_spec_info(PFUMM0, PredName, SpecPredName, Subst0, TVarSet, Items, Context, SeqNum), @@ -1645,10 +1735,7 @@ module_qualify_item_decl_pragma(InInt, Pragma0, Pragma, !Info, !Specs) :- PFUMM0 = pfumm_unknown(_Arity), PFUMM = PFUMM0 ), - Subst0 = one_or_more(HeadSubst0, TailSubsts0), - qualify_type_spec_subst(InInt, ErrorContext, - HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, !Info, !Specs), - Subst = one_or_more(HeadSubst, TailSubsts), + qualify_type_subst(InInt, ErrorContext, Subst0, Subst, !Info, !Specs), TypeSpecInfo = decl_pragma_type_spec_info(PFUMM, PredName, SpecPredName, Subst, TVarSet, Items, Context, SeqNum), Pragma = decl_pragma_type_spec(TypeSpecInfo) @@ -1812,24 +1899,33 @@ qualify_pragma_var(InInt, ErrorContext, PragmaVar0, PragmaVar, qualify_mode(InInt, ErrorContext, Mode0, Mode, !Info, !Specs), PragmaVar = pragma_var(Var, Name, Mode, Box). -:- pred qualify_type_spec_subst(mq_in_interface::in, mq_error_context::in, - pair(tvar, mer_type)::in, pair(tvar, mer_type)::out, - assoc_list(tvar, mer_type)::in, assoc_list(tvar, mer_type)::out, - mq_info::in, mq_info::out, +:- pred qualify_type_subst(mq_in_interface::in, mq_error_context::in, + type_subst::in, type_subst::out, mq_info::in, mq_info::out, list(error_spec)::in, list(error_spec)::out) is det. -qualify_type_spec_subst(InInt, ErrorContext, +qualify_type_subst(InInt, ErrorContext, Subst0, Subst, !Info, !Specs) :- + Subst0 = one_or_more(HeadSubst0, TailSubsts0), + qualify_tvar_substs(InInt, ErrorContext, + HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, !Info, !Specs), + Subst = one_or_more(HeadSubst, TailSubsts). + +:- pred qualify_tvar_substs(mq_in_interface::in, mq_error_context::in, + tvar_subst::in, tvar_subst::out, + list(tvar_subst)::in, list(tvar_subst)::out, mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_tvar_substs(InInt, ErrorContext, HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, !Info, !Specs) :- - HeadSubst0 = Var - Type0, + HeadSubst0 = tvar_subst(Var, Type0), % XXX We could pass a more specific error context. qualify_type(InInt, ErrorContext, Type0, Type, !Info, !Specs), - HeadSubst = Var - Type, + HeadSubst = tvar_subst(Var, Type), ( TailSubsts0 = [], TailSubsts = [] ; TailSubsts0 = [HeadTailSubst0 | TailTailSubsts0], - qualify_type_spec_subst(InInt, ErrorContext, + qualify_tvar_substs(InInt, ErrorContext, HeadTailSubst0, HeadTailSubst, TailTailSubsts0, TailTailSubsts, !Info, !Specs), TailSubsts = [HeadTailSubst | TailTailSubsts] diff --git a/compiler/options.m b/compiler/options.m index 9463fcbec..2e9e0da1e 100644 --- a/compiler/options.m +++ b/compiler/options.m @@ -241,6 +241,7 @@ ; inform_suboptimal_packing ; print_error_spec_id ; inform_ignored_pragma_errors + ; inform_generated_type_spec_pragmas % Verbosity options ; verbose @@ -1321,6 +1322,7 @@ optdef(oc_warn, inform_inferred_modes, bool(yes)). optdef(oc_warn, inform_suboptimal_packing, bool(no)). optdef(oc_warn, print_error_spec_id, bool(no)). optdef(oc_warn, inform_ignored_pragma_errors, bool(no)). +optdef(oc_warn, inform_generated_type_spec_pragmas, bool(no)). % Verbosity options. @@ -2244,6 +2246,8 @@ long_option("inform-inferred-modes", inform_inferred_modes). long_option("inform-suboptimal-packing", inform_suboptimal_packing). long_option("print-error-spec-id", print_error_spec_id). long_option("inform-ignored-pragma-errors", inform_ignored_pragma_errors). +long_option("inform-generated-type-spec-pragmas", + inform_generated_type_spec_pragmas). % verbosity options long_option("verbose", verbose). @@ -3245,6 +3249,8 @@ long_option("warn-obsolete-transform-2023-07-03", compiler_sufficiently_recent). long_option("gen-dep-ints-2023-10-15", compiler_sufficiently_recent). +long_option("tscp-2024-02-07", + compiler_sufficiently_recent). long_option("experiment", experiment). long_option("experiment1", experiment1). long_option("experiment2", experiment2). @@ -4448,6 +4454,10 @@ options_help_warning(Stream, !IO) :- % "\tPrint an informational message for each otherwise-ignored error", % "\tthat reports an inability to find the procedure that a pragma", % "\trefers to." +% "--inform-generated-type-spec-pragmas", +% "\tPrint an informational message for each type_spec pragma that" +% "\tthe compiler generates to implement a type_spec_constrained_pred" +% "\tpragma.", ], !IO). :- pred options_help_verbosity(io.text_output_stream::in, diff --git a/compiler/parse_class.m b/compiler/parse_class.m index ccffd83f0..d728dcb44 100644 --- a/compiler/parse_class.m +++ b/compiler/parse_class.m @@ -65,7 +65,10 @@ :- import_module parse_tree.parse_inst_mode_name. :- import_module parse_tree.parse_item. :- import_module parse_tree.parse_sym_name. +:- import_module parse_tree.parse_tree_out_info. +:- import_module parse_tree.parse_tree_out_inst. :- import_module parse_tree.parse_tree_out_term. +:- import_module parse_tree.parse_tree_out_type. :- import_module parse_tree.parse_type_name. :- import_module parse_tree.parse_util. :- import_module parse_tree.prog_item. @@ -290,46 +293,77 @@ parse_superclass_constraints(_ModuleName, VarSet, ConstraintsTerm, Result) :- ( Result0 = ok1(one_or_more(HeadArbConstraint, TailArbConstraints)), ArbitraryConstraints = [HeadArbConstraint | TailArbConstraints], - collect_simple_and_fundep_constraints(ArbitraryConstraints, - SimpleConstraints, FunDeps, BadConstraints), + collect_superclass_constraints(VarSet, ArbitraryConstraints, + SimpleConstraints, FunDeps, BadConstraintSpecs), ( - BadConstraints = [], + BadConstraintSpecs = [], Result = ok2(SimpleConstraints, FunDeps) ; - BadConstraints = [_ | _], - Pieces = [words("Error: constraints on class declarations"), - words("may only constrain type variables and ground types."), - nl], - Spec = simplest_spec($pred, severity_error, - phase_term_to_parse_tree, - get_term_context(ConstraintsTerm), Pieces), - Result = error2([Spec]) + BadConstraintSpecs = [_ | _], + Result = error2(BadConstraintSpecs) ) ; Result0 = error1(Specs), Result = error2(Specs) ). -:- pred collect_simple_and_fundep_constraints(list(arbitrary_constraint)::in, +:- pred collect_superclass_constraints(varset::in, + list(arbitrary_constraint)::in, list(prog_constraint)::out, list(prog_fundep)::out, - list(arbitrary_constraint)::out) is det. + list(error_spec)::out) is det. -collect_simple_and_fundep_constraints([], [], [], []). -collect_simple_and_fundep_constraints([Constraint | Constraints], - !:SimpleConstraints, !:FunDeps, !:BadConstraints) :- - collect_simple_and_fundep_constraints(Constraints, - !:SimpleConstraints, !:FunDeps, !:BadConstraints), +collect_superclass_constraints(_, [], [], [], []). +collect_superclass_constraints(VarSet, [Constraint | Constraints], + !:SimpleConstraints, !:FunDeps, !:Specs) :- + collect_superclass_constraints(VarSet, Constraints, + !:SimpleConstraints, !:FunDeps, !:Specs), ( - Constraint = simple(SimpleConstraint), - !:SimpleConstraints = [SimpleConstraint | !.SimpleConstraints] + Constraint = ac_type_constraint(TypeConstraint, + _VoGTypes, NonVarNonGroundTypes, Context), + ( + NonVarNonGroundTypes = [], + !:SimpleConstraints = [TypeConstraint | !.SimpleConstraints] + ; + NonVarNonGroundTypes = [_ | _], + varset.coerce(VarSet, TVarSet), + TypeConstraint = constraint(SuperClassName, _), + BadTypeStrs = list.map( + mercury_type_to_string(TVarSet, print_name_only), + NonVarNonGroundTypes), + BadTypesStr = list_to_quoted_pieces(BadTypeStrs), + ( + NonVarNonGroundTypes = [_], + BadTypePieces = [words("The type")] ++ BadTypesStr ++ + [words("is neither."), nl] + ; + NonVarNonGroundTypes = [_, _ | _], + BadTypePieces = [words("The types")] ++ BadTypesStr ++ + [words("are neither."), nl] + ), + Pieces = [words("Error: in a superclass constraint,"), + words("all the argument types of the superclass,"), + words("which in this case is"), + unqual_sym_name(SuperClassName), suffix(","), + words("must be either type variables or ground types.")] ++ + BadTypePieces, + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, Context, Pieces), + !:Specs = [Spec | !.Specs] + ) ; - Constraint = fundep(FunDep), + Constraint = ac_inst_constraint(InstVar, Inst, Context), + varset.coerce(VarSet, InstVarSet), + InstConstraintStr = mercury_constrained_inst_vars_to_string( + output_mercury, InstVarSet, set.make_singleton_set(InstVar), Inst), + Pieces = [words("Error: a class declaration"), + words("may not contain an inst constraint such as"), + quote(InstConstraintStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, + Context, Pieces), + !:Specs = [Spec | !.Specs] + ; + Constraint = ac_fundep(FunDep, _), !:FunDeps = [FunDep | !.FunDeps] - ; - ( Constraint = non_simple(_) - ; Constraint = inst_constraint(_, _) - ), - !:BadConstraints = [Constraint | !.BadConstraints] ). :- pred parse_unconstrained_class(module_name::in, tvarset::in, term::in, @@ -511,10 +545,10 @@ parse_derived_instance(ModuleName, TVarSet, NameTerm, ConstraintsTerm, maybe1(list(prog_constraint))::out) is det. parse_instance_constraints(ModuleName, VarSet, ConstraintsTerm, Result) :- - Pieces = [words("Error: constraints on instance declarations"), + NonSimplePieces = [words("Error: constraints on instance declarations"), words("may only constrain type variables and ground types."), nl], - parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, Pieces, - Result). + parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, + NonSimplePieces, Result). :- pred parse_underived_instance(module_name::in, tvarset::in, term::in, prog_context::in, item_seq_num::in, maybe1(item_instance_info)::out) @@ -771,17 +805,17 @@ report_unexpected_method_term(VarSet, MethodTerm) = Spec :- % parse_class_constraints(ModuleName, VarSet, ConstraintsTerm, Result) :- - Pieces = [words("Sorry, not implemented:"), + NonSimplePieces = [words("Sorry, not implemented:"), words("constraints may only constrain type variables"), words("and ground types."), nl], - parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, Pieces, - Result). + parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, + NonSimplePieces, Result). :- pred parse_simple_class_constraints(module_name::in, varset::in, term::in, list(format_piece)::in, maybe1(list(prog_constraint))::out) is det. -parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces, - Result) :- +parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, + NonSimplePieces, Result) :- parse_arbitrary_constraints(VarSet, ConstraintsTerm, Result0), ( Result0 = ok1(one_or_more(HeadArbConstraint, TailArbConstraints)), @@ -795,9 +829,9 @@ parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces, % to list allows an empty list. Result = ok1([HeadConstraint | TailConstraints]) else + Context = get_term_context(ConstraintsTerm), Spec = simplest_spec($pred, severity_error, - phase_term_to_parse_tree, - get_term_context(ConstraintsTerm), Pieces), + phase_term_to_parse_tree, Context, NonSimplePieces), Result = error1([Spec]) ) ; @@ -808,7 +842,7 @@ parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces, :- pred get_simple_constraint(arbitrary_constraint::in, prog_constraint::out) is semidet. -get_simple_constraint(simple(Constraint), Constraint). +get_simple_constraint(ac_type_constraint(Constraint, _, [], _), Constraint). parse_class_and_inst_constraints(_ModuleName, VarSet, ConstraintsTerm, Result) :- @@ -845,34 +879,34 @@ collect_class_and_inst_constraints([Constraint | Constraints], collect_class_and_inst_constraints(Constraints, !:ProgConstraints, !:FunDeps, !:InstVarSub), ( - ( Constraint = simple(ProgConstraint) - ; Constraint = non_simple(ProgConstraint) - ), + Constraint = ac_type_constraint(ProgConstraint, _, _, _), !:ProgConstraints = [ProgConstraint | !.ProgConstraints] ; - Constraint = inst_constraint(InstVar, Inst), + Constraint = ac_inst_constraint(InstVar, Inst, _), map.set(InstVar, Inst, !InstVarSub) ; - Constraint = fundep(FunDep), + Constraint = ac_fundep(FunDep, _), !:FunDeps = [FunDep | !.FunDeps] ). :- type arbitrary_constraint - ---> simple(prog_constraint) - % A class constraint whose arguments are either variables - % or ground terms. + ---> ac_type_constraint(prog_constraint, list(var_or_ground_type), + list(mer_type), prog_context) + % A constraint consisting of a typeclass name applied to one + % or more types. The second argument lists the types that are + % either type variables or ground types; the third argument lists + % the types that are neither. (Superclass constraints, and the + % constraints in type_spec_constrained_preds pragmas, may have + % only type variables and ground types as arguments.) - ; non_simple(prog_constraint) - % An arbitrary class constraint not matching the description - % of "simple". + ; ac_inst_constraint(inst_var, mer_inst, prog_context) + % A constraint on an inst variable. Its principal functor is + % '=<'/2. - ; inst_constraint(inst_var, mer_inst) - % A constraint on an inst variable (that is, one whose head - % is '=<'/2). - - ; fundep(prog_fundep). - % A functional dependency (that is, one whose head is '->'/2) - % and whose arguments are comma-separated variables. + ; ac_fundep(prog_fundep, prog_context). + % A functional dependency. Its principal function symbol is '->'/2, + % and both its argument terms contain one or more variables + % separated by commas. :- type arbitrary_constraints == one_or_more(arbitrary_constraint). @@ -919,7 +953,8 @@ parse_arbitrary_constraint_list(VarSet, HeadTerm, TailTerms, Result) :- parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- ( if - ConstraintTerm = term.functor(term.atom("=<"), [LHSTerm, RHSTerm], _) + ConstraintTerm = + term.functor(term.atom("=<"), [LHSTerm, RHSTerm], Context) then ( LHSTerm = term.variable(InstVar0, _), @@ -943,7 +978,7 @@ parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- MaybeInstVar = ok1(InstVar), MaybeInst = ok1(Inst) then - Result = ok1(inst_constraint(InstVar, Inst)) + Result = ok1(ac_inst_constraint(InstVar, Inst, Context)) else Specs = get_any_errors1(MaybeInstVar) ++ get_any_errors1(MaybeInst), @@ -954,20 +989,21 @@ parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- then Result = Result0 else if - try_parse_sym_name_and_args(ConstraintTerm, ClassName, Args0) + try_parse_sym_name_and_args(ConstraintTerm, ClassName, ArgTerms0) then ArgsResultContextPieces = cord.singleton(words("In class constraint:")), parse_types(no_allow_ho_inst_info(wnhii_class_constraint), - VarSet, ArgsResultContextPieces, Args0, ArgsResult), + VarSet, ArgsResultContextPieces, ArgTerms0, ArgsResult), ( - ArgsResult = ok1(Args), - Constraint = constraint(ClassName, Args), - ( if constraint_is_not_simple(Constraint) then - Result = ok1(non_simple(Constraint)) - else - Result = ok1(simple(Constraint)) - ) + ArgsResult = ok1(ArgTypes), + varset.coerce(VarSet, TVarSet), + Constraint = constraint(ClassName, ArgTypes), + classify_types_as_var_ground_or_neither(TVarSet, ArgTypes, + VoGTypes, NonVarNonGroundTypes), + Context = get_term_context(ConstraintTerm), + Result = ok1(ac_type_constraint(Constraint, VoGTypes, + NonVarNonGroundTypes, Context)) ; ArgsResult = error1(Specs), Result = error1(Specs) @@ -983,12 +1019,12 @@ parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- :- pred parse_fundep(term::in, maybe1(arbitrary_constraint)::out) is semidet. parse_fundep(Term, Result) :- - Term = term.functor(term.atom("->"), [DomainTerm, RangeTerm], _), + Term = term.functor(term.atom("->"), [DomainTerm, RangeTerm], Context), ( if - parse_fundep_2(DomainTerm, Domain), - parse_fundep_2(RangeTerm, Range) + parse_fundep_side(DomainTerm, Domain), + parse_fundep_side(RangeTerm, Range) then - Result = ok1(fundep(fundep(Domain, Range))) + Result = ok1(ac_fundep(fundep(Domain, Range), Context)) else Pieces = [words("Error: the domain and range"), words("of a functional dependency"), @@ -1000,20 +1036,32 @@ parse_fundep(Term, Result) :- % XXX ITEM_LIST Should return one_or_more(tvar). % -:- pred parse_fundep_2(term::in, list(tvar)::out) is semidet. +:- pred parse_fundep_side(term::in, list(tvar)::out) is semidet. -parse_fundep_2(TypesTerm0, TypeVars) :- +parse_fundep_side(TypesTerm0, TypeVars) :- TypesTerm = term.coerce(TypesTerm0), conjunction_to_list(TypesTerm, TypeTerms), term_subst.term_list_to_var_list(TypeTerms, TypeVars). -:- pred constraint_is_not_simple(prog_constraint::in) is semidet. +:- pred classify_types_as_var_ground_or_neither(tvarset::in, + list(mer_type)::in, + list(var_or_ground_type)::out, list(mer_type)::out) is det. -constraint_is_not_simple(constraint(_ClassName, ArgTypes)) :- - some [ArgType] ( - list.member(ArgType, ArgTypes), - type_is_nonvar(ArgType), - type_is_nonground(ArgType) +classify_types_as_var_ground_or_neither(_, [], [], []). +classify_types_as_var_ground_or_neither(TVarSet, [Type0 | Types0], + !:VarOrGroundTypes, !:NonVarNonGroundTypes) :- + classify_types_as_var_ground_or_neither(TVarSet, Types0, + !:VarOrGroundTypes, !:NonVarNonGroundTypes), + Type1 = strip_kind_annotation(Type0), + Type = coerce(Type1), + ( if Type = type_variable(TVar, _Context) then + varset.lookup_name(TVarSet, TVar, TVarName), + !:VarOrGroundTypes = + [type_var_name(TVar, TVarName) | !.VarOrGroundTypes] + else if type_is_ground(Type, GroundType) then + !:VarOrGroundTypes = [ground_type(GroundType) | !.VarOrGroundTypes] + else + !:NonVarNonGroundTypes = [Type | !.NonVarNonGroundTypes] ). %---------------------------------------------------------------------------% diff --git a/compiler/parse_item.m b/compiler/parse_item.m index 23682cce5..fc5bc075d 100644 --- a/compiler/parse_item.m +++ b/compiler/parse_item.m @@ -1734,7 +1734,7 @@ get_purity_from_attrs(Context, [PurityAttr | PurityAttrs], MaybePurity) :- get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet, QuantConstrAttrs, ContextPieces, MaybeExistClassInstContext) :- % When we reach here, QuantConstrAttrs contains declaration attributes - % in the outermost to innermost order. + % in outermost to innermost order. % % Constraints and quantifiers should occur in the following order, % outermost to innermost: @@ -1748,14 +1748,14 @@ get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet, % 5. the decl itself pred or func 700 % % [*] Note that the semantic meaning of `=>' is not quite the same - % as implication; logically speaking it's more like conjunction. + % as implication; logically speaking, it is more like conjunction. % Oh well, at least it has the right precedence. % - % In theory it could make sense to allow the order of 2 & 3 to be - % swapped, or (in the case of multiple constraints & multiple - % quantifiers) to allow arbitrary interleaving of 2 & 3, but in - % practice it seems there would be little benefit in allowing that - % flexibility, so we don't. + % In theory, it could make sense to allow the order of 2 & 3 to be + % swapped, or (in the case of multiple constraints and multiple + % quantifiers) to allow arbitrary interleaving of 2 & 3, but in practice + % it seems there would be little benefit in allowing that flexibility, + % so we don't. % % NOTE We do NOT check that the order above is actually followed. % diff --git a/compiler/parse_pragma.m b/compiler/parse_pragma.m index 5058015e0..c6bd9bebc 100644 --- a/compiler/parse_pragma.m +++ b/compiler/parse_pragma.m @@ -54,13 +54,14 @@ :- import_module parse_tree.parse_util. :- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_item. +:- import_module parse_tree.prog_type_scan. +:- import_module parse_tree.prog_type_test. :- import_module cord. :- import_module counter. :- import_module int. :- import_module maybe. :- import_module one_or_more. -:- import_module pair. :- import_module set. :- import_module string. :- import_module term_int. @@ -74,7 +75,7 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeIOM) :- PragmaContext) then ( if - parse_pragma_type(ModuleName, VarSet, PragmaTerm, + parse_named_pragma(ModuleName, VarSet, PragmaTerm, PragmaName, PragmaArgTerms, PragmaContext, SeqNum, MaybeIOMPrime) then @@ -91,12 +92,14 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeIOM) :- MaybeIOM = error1([Spec]) ). -:- pred parse_pragma_type(module_name::in, varset::in, term::in, +:- pred parse_named_pragma(module_name::in, varset::in, term::in, string::in, list(term)::in, prog_context::in, item_seq_num::in, maybe1(item_or_marker)::out) is semidet. -parse_pragma_type(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, +parse_named_pragma(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, Context, SeqNum, MaybeIOM) :- + % XXX The Context argument is redundant, since we can always compute it + % as get_term_context(ErrorTerm). require_switch_arms_det [PragmaName] ( PragmaName = "source_file", @@ -228,6 +231,10 @@ parse_pragma_type(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, PragmaName = "unused_args", parse_pragma_unused_args(ModuleName, VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) + ; + PragmaName = "type_spec_constrained_preds", + parse_pragma_type_spec_constr(ModuleName, VarSet, ErrorTerm, + PragmaTerms, SeqNum, MaybeIOM) ; PragmaName = "type_spec", parse_pragma_type_spec(ModuleName, VarSet, ErrorTerm, @@ -1237,6 +1244,530 @@ parse_oisu_preds_term(ModuleName, VarSet, ArgNum, ExpectedFunctor, Term, MaybePredSpecs = error1([Spec]) ). +%---------------------------------------------------------------------------% +% +% Parse type_spec_constrained_preds pragmas. +% + +:- pred parse_pragma_type_spec_constr(module_name::in, varset::in, term::in, + list(term)::in, item_seq_num::in, + maybe1(item_or_marker)::out) is det. + +parse_pragma_type_spec_constr(ModuleName, VarSet0, ErrorTerm, PragmaTerms, + SeqNum, MaybeIOM) :- + ( if + PragmaTerms = [ConstraintsTerm, ApplyToSupersTerm, TypeSubstsTerm] + then + acc_var_names_in_term(VarSet0, ConstraintsTerm, + set.init, NamedVarNames1), + acc_var_names_in_term(VarSet0, TypeSubstsTerm, + NamedVarNames1, NamedVarNames), + parse_var_or_ground_constraint_list(NamedVarNames, ConstraintsTerm, + Constraints, ConstraintSpecs, + counter.init(1), Counter1, VarSet0, VarSet1), + parse_apply_to_supers(ApplyToSupersTerm, MaybeApplyToSupers), + parse_type_subst_list(NamedVarNames, TypeSubstsTerm, + TypeSubsts, TypeSubstsSpecs, Counter1, _Counter, VarSet1, VarSet), + varset.coerce(VarSet0, TVarSet0), + list.foldl(var_or_ground_constraint_acc_tvars, Constraints, + set.init, ConstraintTVars), + check_type_substs(TVarSet0, ConstraintTVars, TypeSubstsTerm, 1, + TypeSubsts, [], TypeSubstTVarSpecs), + ( if + ConstraintSpecs = [], + MaybeApplyToSupers = ok1(ApplyToSupers), + TypeSubstsSpecs = [], + TypeSubstTVarSpecs = [] + then + det_list_to_one_or_more(Constraints, OoMConstraints), + det_list_to_one_or_more(TypeSubsts, OoMTypeSubsts), + varset.coerce(VarSet, TVarSet), + TypeSpecConstr = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints, ApplyToSupers, OoMTypeSubsts, TVarSet, + set.init, get_term_context(ErrorTerm), SeqNum), + Pragma = decl_pragma_type_spec_constr(TypeSpecConstr), + Item = item_decl_pragma(Pragma), + MaybeIOM = ok1(iom_item(Item)) + else + Specs = ConstraintSpecs ++ get_any_errors1(MaybeApplyToSupers) ++ + TypeSubstsSpecs ++ TypeSubstTVarSpecs, + MaybeIOM = error1(Specs) + ) + else + Pieces = [words("Error: a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration must have three arguments."), nl], + Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, + get_term_context(ErrorTerm), Pieces), + MaybeIOM = error1([Spec]) + ). + +%---------------------% + +:- pred parse_var_or_ground_constraint_list(set(string)::in, term::in, + list(var_or_ground_constraint)::out, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_var_or_ground_constraint_list(NamedVarNames, Term, Constraints, Specs, + !Counter, !VarSet) :- + ( if list_term_to_term_list(Term, ConstraintTerms) then + ( + ConstraintTerms = [], + Constraints = [], + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: the list of type class constraints"), + words("must not be empty."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ; + ConstraintTerms = [HeadConstraintTerm | TailConstraintTerms], + parse_var_or_ground_constraint_acc(NamedVarNames, + HeadConstraintTerm, cord.init, ConstraintCord1, + [], Specs1, !Counter, !VarSet), + list.foldl4(parse_var_or_ground_constraint_acc(NamedVarNames), + TailConstraintTerms, ConstraintCord1, ConstraintCord, + Specs1, Specs, !Counter, !VarSet), + Constraints = cord.list(ConstraintCord) + ) + else + Constraints = [], + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: expected a list of type class constraints, got"), + quote(describe_error_term(!.VarSet, Term)), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ). + +:- pred parse_var_or_ground_constraint_acc(set(string)::in, term::in, + cord(var_or_ground_constraint)::in, cord(var_or_ground_constraint)::out, + list(error_spec)::in, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_var_or_ground_constraint_acc(NamedVarNames, Term, + !ConstraintCord, !Specs, !Counter, !VarSet) :- + ( if try_parse_sym_name_and_args(Term, ClassSymName, ArgTerms) then + ( + ArgTerms = [], + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: expected a typeclass constraint consisting of"), + words("a class_name applied to one or more argument types,"), + words("got the class name"), + quote(sym_name_to_string(ClassSymName)), + words("without any argument types."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + !:Specs = [Spec | !.Specs] + ; + ArgTerms = [_ | _], + list.foldl2(name_unnamed_vars_in_term(NamedVarNames), + ArgTerms, !Counter, !VarSet), + ContextPieces = cord.from_list( + [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:")]), + AllowHOInstInfo = + no_allow_ho_inst_info(wnhii_pragma_type_spec_constr), + list.length(ArgTerms, NumArgTerms), + ClassId = class_id(ClassSymName, NumArgTerms), + parse_var_or_ground_types(AllowHOInstInfo, !.VarSet, ContextPieces, + ClassId, ArgTerms, MaybeArgs), + ( + MaybeArgs = ok1(Args), + Context = get_term_context(Term), + Constraint = + var_or_ground_constraint(ClassSymName, Args, Context), + cord.snoc(Constraint, !ConstraintCord) + ; + MaybeArgs = error1(ArgSpecs), + !:Specs = ArgSpecs ++ !.Specs + ) + ) + else + Pieces = [words("Error in the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("expected a typeclass constraint of the form"), + quote("class_name(argtype1, argtype2, ...)"), + words("got"), quote(describe_error_term(!.VarSet, Term)), + suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + !:Specs = [Spec | !.Specs] + ). + +:- pred parse_var_or_ground_types(allow_ho_inst_info::in, varset::in, + cord(format_piece)::in, class_id::in, list(term)::in, + maybe1(list(var_or_ground_type))::out) is det. + +parse_var_or_ground_types(_, _, _, _, [], ok1([])). +parse_var_or_ground_types(AllowHOInstInfo, VarSet, ContextPieces, ClassId, + [HeadTerm | TailTerms], Result) :- + parse_var_or_ground_types(AllowHOInstInfo, VarSet, ContextPieces, ClassId, + TailTerms, TailResult), + parse_type(AllowHOInstInfo, VarSet, ContextPieces, HeadTerm, HeadResult0), + ( + HeadResult0 = ok1(HeadType), + ( if HeadType = type_variable(HeadVar, _) then + varset.coerce(VarSet, TVarSet), + varset.lookup_name(TVarSet, HeadVar, HeadVarName), + HeadArg0 = type_var_name(HeadVar, HeadVarName), + HeadResult = ok1(HeadArg0) + else if type_is_ground(HeadType, HeadGroundType) then + HeadArg0 = ground_type(HeadGroundType), + HeadResult = ok1(HeadArg0) + else + Pieces = [words("Error in the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("in the constraint using type class"), + unqual_class_id(ClassId), suffix(","), + quote("expect ground types as arguments,"), + words("got"), quote(describe_error_term(VarSet, HeadTerm)), + suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(HeadTerm), Pieces), + HeadResult = error1([Spec]) + ) + ; + HeadResult0 = error1(HeadSpecs), + HeadResult = error1(HeadSpecs) + ), + ( if + HeadResult = ok1(HeadArg), + TailResult = ok1(TailArgs) + then + Result = ok1([HeadArg | TailArgs]) + else + Specs = get_any_errors1(HeadResult) ++ get_any_errors1(TailResult), + Result = error1(Specs) + ). + +:- pred parse_type_subst_list(set(string)::in, term::in, + list(type_subst)::out, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_type_subst_list(NamedVarNames, Term, TypeSubsts, Specs, + !Counter, !VarSet) :- + ( if list_term_to_term_list(Term, TypeSubstTerms) then + ( + TypeSubstTerms = [], + TypeSubsts = [], + Pieces = [words("In the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: the list of type substitutions"), + words("must not be empty."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ; + TypeSubstTerms = [HeadTypeSubstTerm | TailTypeSubstTerms], + PrefixPieces = [words("In the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl], + WNHII = wnhii_pragma_type_spec_constr, + parse_type_subst_acc(WNHII, PrefixPieces, NamedVarNames, + HeadTypeSubstTerm, cord.init, TypeSubstCord1, + [], Specs1, !Counter, !VarSet), + list.foldl4( + parse_type_subst_acc(WNHII, PrefixPieces, NamedVarNames), + TailTypeSubstTerms, TypeSubstCord1, TypeSubstCord, + Specs1, Specs, !Counter, !VarSet), + TypeSubsts = cord.list(TypeSubstCord) + ) + else + TypeSubsts = [], + Pieces = [words("In the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: expected a list of type substitutions, got"), + quote(describe_error_term(!.VarSet, Term)), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ). + +:- pred parse_type_subst_acc(why_no_ho_inst_info::in, list(format_piece)::in, + set(string)::in, term::in, cord(type_subst)::in, cord(type_subst)::out, + list(error_spec)::in, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_type_subst_acc(WNHII, PrefixPieces, NamedVarNames, Term, + !TypeSubstCord, !Specs, !Counter, !VarSet) :- + parse_type_subst(WNHII, PrefixPieces, NamedVarNames, Term, MaybeTypeSubst, + !Counter, !VarSet), + ( + MaybeTypeSubst = ok1(TypeSubst), + cord.snoc(TypeSubst, !TypeSubstCord) + ; + MaybeTypeSubst = error1(TypeSubstSpecs), + !:Specs = TypeSubstSpecs ++ !.Specs + ). + +:- pred parse_type_subst(why_no_ho_inst_info::in, list(format_piece)::in, + set(string)::in, term::in, maybe1(type_subst)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_type_subst(WNHII, PrefixPieces, NamedVarNames, Term, MaybeTypeSubst, + !Counter, !VarSet) :- + ( if Term = term.functor(atom("subst"), ArgTerms, _) then + ( + ( ArgTerms = [] + ; ArgTerms = [_, _ | _] + ), + Pieces = PrefixPieces ++ + [words("error:"), quote("subst"), + words("must have exactly one argument,"), + words("which should have the form"), nl_indent_delta(1), + quote("[V1 = , ...]"), suffix("."), + nl_indent_delta(-1)], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeTypeSubst = error1([Spec]) + ; + ArgTerms = [ArgTerm], + ( if list_term_to_term_list(ArgTerm, TypeSubstTerms) then + ( + TypeSubstTerms = [], + Pieces = PrefixPieces ++ + [words("error: the list of type variable"), + words("substitutions must not be empty."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), + Pieces), + MaybeTypeSubst = error1([Spec]) + ; + TypeSubstTerms = [HeadTypeSubstTerm | TailTypeSubstTerms], + VarSet0 = !.VarSet, + name_unnamed_vars_in_term(NamedVarNames, + HeadTypeSubstTerm, !Counter, !VarSet), + list.foldl2(name_unnamed_vars_in_term(NamedVarNames), + TailTypeSubstTerms, !Counter, !VarSet), + parse_tvar_subst_acc(WNHII, PrefixPieces, VarSet0, + HeadTypeSubstTerm, cord.init, TVarSubstCord1, + [], TVarSpecs1), + list.foldl2( + parse_tvar_subst_acc(WNHII, PrefixPieces, VarSet0), + TailTypeSubstTerms, TVarSubstCord1, TVarSubstCord, + TVarSpecs1, TVarSpecs), + ( + TVarSpecs = [], + TVarSubsts = cord.list(TVarSubstCord), + det_list_to_one_or_more(TVarSubsts, TypeSubst), + MaybeTypeSubst = ok1(TypeSubst) + ; + TVarSpecs = [_ | _], + MaybeTypeSubst = error1(TVarSpecs) + ) + ) + else + ErrorTermStr = describe_error_term(!.VarSet, Term), + Pieces = PrefixPieces ++ + [words("error: expected a list of the form,"), + nl_indent_delta(1), + quote("[V1 = , ...]"), suffix(","), + nl_indent_delta(-1), + words("got"), quote(ErrorTermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeTypeSubst = error1([Spec]) + ) + ) + else + ErrorTermStr = describe_error_term(!.VarSet, Term), + Pieces = PrefixPieces ++ + [words("error: expected a term of the form"), nl_indent_delta(1), + quote("subst([V1 = , ...])"), suffix(","), + nl_indent_delta(-1), + words("got"), quote(ErrorTermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeTypeSubst = error1([Spec]) + ). + +%---------------------% + +:- pred parse_apply_to_supers(term::in, maybe1(maybe_apply_to_supers)::out) + is det. + +parse_apply_to_supers(Term, MaybeApplyToSupers) :- + ( if + Term = term.functor(Functor, Args, _), + Functor = term.atom(AtomStr), + ( + AtomStr = "do_not_apply_to_superclasses", + ApplyToSupers0 = do_not_apply_to_supers + ; + AtomStr = "apply_to_superclasses", + ApplyToSupers0 = apply_to_supers + ) + then + ( + Args = [], + MaybeApplyToSupers = ok1(ApplyToSupers0) + ; + Args = [_ | _], + Pieces = [words("Error in the second argument of"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), quote(AtomStr), + words("may not have any arguments."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeApplyToSupers = error1([Spec]) + ) + else + Pieces = [words("Error: the second argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration must be either"), + quote("do_not_apply_to_superclasses"), words("or"), + quote("apply_to_superclasses"), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeApplyToSupers = error1([Spec]) + ). + +%---------------------% + +:- pred var_or_ground_constraint_acc_tvars(var_or_ground_constraint::in, + set(tvar)::in, set(tvar)::out) is det. + +var_or_ground_constraint_acc_tvars(Constraint, !TVars) :- + Constraint = var_or_ground_constraint(_ClassName, VoGTypes, _Context), + list.foldl(var_or_ground_type_acc_tvars, VoGTypes, !TVars). + +:- pred var_or_ground_type_acc_tvars(var_or_ground_type::in, + set(tvar)::in, set(tvar)::out) is det. + +var_or_ground_type_acc_tvars(VoGType, !TVars) :- + ( + VoGType = type_var_name(TVar, _TVarName), + set.insert(TVar, !TVars) + ; + VoGType = ground_type(_GroundType) + ). + +:- pred check_type_substs(tvarset::in, set(tvar)::in, term::in, int::in, + list(type_subst)::in, list(error_spec)::in, list(error_spec)::out) is det. + +check_type_substs(_, _, _, _, [], !TypeSubstTVarSpecs). +check_type_substs(TVarSet, ConstraintTVars, ErrorTerm, + SubstNum, [TypeSubst | TypeSubsts], !TypeSubstTVarSpecs) :- + check_type_subst(TVarSet, ConstraintTVars, ErrorTerm, + SubstNum, TypeSubst, !TypeSubstTVarSpecs), + check_type_substs(TVarSet, ConstraintTVars, ErrorTerm, + SubstNum + 1, TypeSubsts, !TypeSubstTVarSpecs). + +:- pred check_type_subst(tvarset::in, set(tvar)::in, term::in, int::in, + type_subst::in, list(error_spec)::in, list(error_spec)::out) is det. + +check_type_subst(TVarSet, ConstraintTVars, ErrorTerm, SubstNum, TypeSubst, + !Specs) :- + TypeSubst = one_or_more(HeadTVarSubst, TailTVarSubsts), + check_tvar_subst(TVarSet, ConstraintTVars, HeadTVarSubst, + set.init, BadLHSTVars1, set.init, BadRHSTVars1), + list.foldl2(check_tvar_subst(TVarSet, ConstraintTVars), TailTVarSubsts, + BadLHSTVars1, BadLHSTVars, BadRHSTVars1, BadRHSTVars), + BadLHSTVarList = set.to_sorted_list(BadLHSTVars), + BadRHSTVarList = set.to_sorted_list(BadRHSTVars), + % If a type_spec_constrained_preds pragma contains N substitutions + % in its third argument, then the process of checking those substitutions + % can generate up to 2N error_specs: one for each lhs or rhs in those + % N substitutions. We don't have a context for any part of the third + % argument, just the context of the third argument as a whole (our caller + % passes us the term containing that argument as ErrorTerm). We want to + % generate any error messages for the parts of that third argument + % in an order which matches the order of the complained-about entities + % in that argument, which we achieve through the use of the invis order + % format pieces below. + ( + BadLHSTVarList = [] + ; + BadLHSTVarList = [_HeadBadLHSTVar | TailBadLHSTVars], + ( + TailBadLHSTVars = [], + TheTypeVar = "the left-hand-side type variable", + ItDoesNot = "it does not." + ; + TailBadLHSTVars = [_ | _], + TheTypeVar = "the left-hand-side type variables", + ItDoesNot = "they do not." + ), + BadLHSTVarStrs = + list.map(mercury_var_to_string_vs(TVarSet, print_name_only), + BadLHSTVarList), + BadLHSTVarsPieces = list_to_pieces(BadLHSTVarStrs), + LHSPieces = [invis_order_default_start(SubstNum, "lhs"), + words("Error: in the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl, + words("in the"), nth_fixed(SubstNum), words("substitution:"), nl, + words(TheTypeVar)] ++ BadLHSTVarsPieces ++ [words("must occur"), + words("in the constraints listed in the first argument,"), + words("but"), words(ItDoesNot), nl], + LHSSpec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(ErrorTerm), LHSPieces), + !:Specs = [LHSSpec | !.Specs] + ), + ( + BadRHSTVarList = [] + ; + BadRHSTVarList = [_HeadBadRHSTVar | TailBadRHSTVars], + ( + TailBadRHSTVars = [], + IsNot = "is not." + ; + TailBadRHSTVars = [_ | _], + IsNot = "are not." + ), + BadRHSTVarStrs = + list.map(mercury_var_to_string_vs(TVarSet, print_name_only), + BadRHSTVarList), + BadRHSTVarsPieces = list_to_pieces(BadRHSTVarStrs), + RHSPieces = [invis_order_default_start(SubstNum, "rhs"), + words("Error: in the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl, + words("in the"), nth_fixed(SubstNum), words("substitution:"), nl, + words("any type variables that occur on the right hand side"), + words("of a substitution must be anonymous, but")] ++ + BadRHSTVarsPieces ++ [words(IsNot), nl], + RHSSpec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(ErrorTerm), RHSPieces), + !:Specs = [RHSSpec | !.Specs] + ). + +:- pred check_tvar_subst(tvarset::in, set(tvar)::in, tvar_subst::in, + set(tvar)::in, set(tvar)::out, set(tvar)::in, set(tvar)::out) is det. + +check_tvar_subst(TVarSet, ConstraintTVars, TVarSubst, + !BadLHSTVars, !BadRHSTVars) :- + TVarSubst = tvar_subst(LHSTVar, RHSType), + ( if set.contains(ConstraintTVars, LHSTVar) then + true + else + set.insert(LHSTVar, !BadLHSTVars) + ), + set_of_type_vars_in_type(RHSType, RHSTVars), + set.foldl(check_tvar_subst_rhs_tvar(TVarSet), RHSTVars, !BadRHSTVars). + +:- pred check_tvar_subst_rhs_tvar(tvarset::in, tvar::in, + set(tvar)::in, set(tvar)::out) is det. + +check_tvar_subst_rhs_tvar(TVarSet, TVar, !BadRHSTVars) :- + ( if varset.search_name(TVarSet, TVar, _VarName) then + set.insert(TVar, !BadRHSTVars) + else + true + ). + %---------------------------------------------------------------------------% % % Parse type_spec pragmas. @@ -1248,13 +1779,9 @@ parse_oisu_preds_term(ModuleName, VarSet, ArgNum, ExpectedFunctor, Term, parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :- - ( if - ( PragmaTerms = [PredAndModesTerm, TypeSubnTerm] - ; PragmaTerms = [PredAndModesTerm, TypeSubnTerm, _] - ) - then + ( if PragmaTerms = [PredAndModesTerm, TypeSubstTerm] then ArityOrModesContextPieces = cord.from_list( - [words("In the first argument"), pragma_decl("type_spec"), + [words("In the first argument of"), pragma_decl("type_spec"), words("declaration:"), nl]), parse_pred_pfu_name_arity_maybe_modes(ModuleName, ArityOrModesContextPieces, VarSet0, PredAndModesTerm, @@ -1263,43 +1790,62 @@ parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms, MaybePredOrProcSpec = ok1(PredOrProcSpec), PredOrProcSpec = pred_or_proc_pfumm_name(PFUMM, PredName), - % Give any anonymous variables in TypeSubnTerm names that - % do not conflict with the names of any named variables, - % nor, due to the use of sequence numbers, with each other. - acc_var_names_in_term(VarSet0, TypeSubnTerm, + WNHII = wnhii_pragma_type_spec, + TypeContextPieces = + [words("In the second argument of"), pragma_decl("type_spec"), + words("declaration:"), nl], + acc_var_names_in_term(VarSet0, TypeSubstTerm, set.init, NamedVarNames), - name_unnamed_vars_in_term(NamedVarNames, TypeSubnTerm, - counter.init(1), _, VarSet0, VarSet), - conjunction_to_one_or_more(TypeSubnTerm, TypeSubnTerms), - TypeSubnTerms = one_or_more(HeadSubnTerm, TailSubnTerms), - ( if - parse_type_spec_pair(HeadSubnTerm, HeadTypeSubn), - list.map(parse_type_spec_pair, TailSubnTerms, TailTypeSubns) - then - % The varset is actually a tvarset. - varset.coerce(VarSet, TVarSet), - TypeSubns = one_or_more(HeadTypeSubn, TailTypeSubns), - TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, - ModuleName, TypeSubns, TVarSet, set.init, Context, SeqNum), - Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)), - MaybeIOM = ok1(iom_item(Item)) + ( if TypeSubstTerm = term.functor(atom("subst"), _, _) then + parse_type_subst(WNHII, TypeContextPieces, NamedVarNames, + TypeSubstTerm, MaybeTypeSubst, + counter.init(1), _, VarSet0, VarSet), + ( + MaybeTypeSubst = ok1(OoMTVarSubsts), + % The varset is actually a tvarset. + varset.coerce(VarSet, TVarSet), + TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, + ModuleName, OoMTVarSubsts, TVarSet, + set.init, Context, SeqNum), + Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)), + MaybeIOM = ok1(iom_item(Item)) + ; + MaybeTypeSubst = error1(TypeSubstSpecs), + MaybeIOM = error1(TypeSubstSpecs) + ) else - TypeSubnTermStr = describe_error_term(VarSet0, TypeSubnTerm), - Pieces = [words("In the second argument of"), - pragma_decl("type_spec"), words("declaration:"), nl, - words("error: expected a type substitution, got"), - quote(TypeSubnTermStr), suffix("."), nl], - TypeSubnContext = get_term_context(TypeSubnTerm), - Spec = simplest_spec($pred, severity_error, - phase_term_to_parse_tree, TypeSubnContext, Pieces), - MaybeIOM = error1([Spec]) + % Give any anonymous variables in TypeSubstTerm names that + % do not conflict with the names of any named variables, + % nor, due to the use of sequence numbers, with each other. + % (In the then branch, this is done by parse_type_subst_acc.) + name_unnamed_vars_in_term(NamedVarNames, TypeSubstTerm, + counter.init(1), _, VarSet0, VarSet), + conjunction_to_one_or_more(TypeSubstTerm, TypeSubstTerms), + TypeSubstTerms = + one_or_more(HeadTypeSubstTerm, TailTypeSubstTerms), + parse_tvar_substs(WNHII, TypeContextPieces, VarSet0, + HeadTypeSubstTerm, TailTypeSubstTerms, + TVarSubsts, [], TypeSpecs), + ( + TypeSpecs = [], + % The varset is actually a tvarset. + varset.coerce(VarSet, TVarSet), + det_list_to_one_or_more(TVarSubsts, OoMTVarSubsts), + TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, + ModuleName, OoMTVarSubsts, TVarSet, + set.init, Context, SeqNum), + Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)), + MaybeIOM = ok1(iom_item(Item)) + ; + TypeSpecs = [_ | _], + MaybeIOM = error1(TypeSpecs) + ) ) ; MaybePredOrProcSpec = error1(Specs), MaybeIOM = error1(Specs) ) else - % XXX We allow three as a bootstrapping measure. Pieces = [words("Error: a"), pragma_decl("type_spec"), words("declaration must have two arguments."), nl], Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, @@ -1307,16 +1853,100 @@ parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms, MaybeIOM = error1([Spec]) ). -:- pred parse_type_spec_pair(term::in, pair(tvar, mer_type)::out) is semidet. +%---------------------------------------------------------------------------% +% +% Utility predicates needed for both type_spec_constrained_preds +% and type_spec pragmas. +% -parse_type_spec_pair(Term, TypeSpec) :- - Term = term.functor(term.atom("="), [TypeVarTerm, SpecTypeTerm], _), - TypeVarTerm = term.variable(TypeVar0, _), - term.coerce_var(TypeVar0, TypeVar), - % XXX We should call parse_type instead. - maybe_parse_type(no_allow_ho_inst_info(wnhii_pragma_type_spec), - SpecTypeTerm, SpecType), - TypeSpec = TypeVar - SpecType. +:- pred parse_tvar_substs(why_no_ho_inst_info::in, list(format_piece)::in, + varset::in, term::in, list(term)::in, list(tvar_subst)::out, + list(error_spec)::in, list(error_spec)::out) is det. + +parse_tvar_substs(WNHII, ContextPieces, VarSet, HeadTerm, TailTerms, + TVarSubsts, !Specs) :- + TVarSubstCord0 = cord.init, + parse_tvar_subst_acc(WNHII, ContextPieces, VarSet, + HeadTerm, TVarSubstCord0, TVarSubstCord1, !Specs), + list.foldl2(parse_tvar_subst_acc(WNHII, ContextPieces, VarSet), + TailTerms, TVarSubstCord1, TVarSubstCord, !Specs), + TVarSubsts = cord.list(TVarSubstCord). + +:- pred parse_tvar_subst_acc(why_no_ho_inst_info::in, list(format_piece)::in, + varset::in, term::in, + cord(tvar_subst)::in, cord(tvar_subst)::out, + list(error_spec)::in, list(error_spec)::out) is det. + +parse_tvar_subst_acc(WNHII, ContextPieces, VarSet, Term, + !TVarSubstCord, !Specs) :- + ( if + Term = term.functor(term.atom(Atom), [TypeVarTerm, TypeTerm], _), + ( Atom = "=", AtomStr = "equals sign" + ; Atom = "=>", AtomStr = "arrow" + ) + then + ( if TypeVarTerm = term.variable(TypeVar0, _) then + RHSPieces = [words("on the right hand side of the"), + words(AtomStr), suffix(":"), nl], + TypeContextPieces = cord.from_list(ContextPieces) ++ + cord.from_list(RHSPieces), + parse_type(no_allow_ho_inst_info(WNHII), VarSet, TypeContextPieces, + TypeTerm, MaybeType), + ( + MaybeType = ok1(Type), + % XXX Having Type be a type variable would not make sense. + % The reference manual does not prohibit it, but it does not + % explicitly allow it either. + % + % The two usual shapes of Type are + % + % - an arity-zero type constructor, and + % - an arity-N type constructor for N > 0 being applied + % to N anonymous variables. + % + % A type containing more than one nested type constructor + % also makes sense. Types containing *named* variables can + % also make sense, but only if each such variable occurs + % exactly once not just in this tvar_subst, but in the list + % of one or more tvar_substs that a type_subst consists of. + % This is because repeated variables restrict the applicability + % of the type substitution in a way + % + % XXX We should consider adding code here to check for + % the cases that do not make sense, *after* documenting + % those restrictions in the reference manual. + term.coerce_var(TypeVar0, TypeVar), + TVarSubst = tvar_subst(TypeVar, Type), + cord.snoc(TVarSubst, !TVarSubstCord) + ; + MaybeType = error1(TypeSpecs), + !:Specs = TypeSpecs ++ !.Specs + ) + else + TypeVarTermStr = describe_error_term(VarSet, TypeVarTerm), + Pieces = ContextPieces ++ + [words("on the left hand side of the"), + words(AtomStr), suffix(":"), nl, + words("error: expected a variable, got"), + quote(TypeVarTermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(TypeVarTerm), + Pieces), + !:Specs = [Spec | !.Specs] + ) + else + TermStr = describe_error_term(VarSet, Term), + Pieces = ContextPieces ++ + [words("error: expected a term of the form"), nl_indent_delta(1), + % XXX We should replace the = with => when we start recommending + % that syntax for both type_spec and type_spec_constrained_preds + % pragmas. + quote("V1 = "), suffix(","), nl_indent_delta(-11), + words("got"), quote(TermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, + get_term_context(Term), Pieces), + !:Specs = [Spec | !.Specs] + ). %---------------------% diff --git a/compiler/parse_tree_out_inst.m b/compiler/parse_tree_out_inst.m index a523da332..d6d3f2ac7 100644 --- a/compiler/parse_tree_out_inst.m +++ b/compiler/parse_tree_out_inst.m @@ -51,6 +51,8 @@ %---------------------------------------------------------------------------% +:- func mercury_constrained_inst_vars_to_string(output_lang, inst_varset, + set(inst_var), mer_inst) = string. :- pred mercury_format_constrained_inst_vars(output_lang::in, inst_varset::in, set(inst_var)::in, mer_inst::in, S::in, U::di, U::uo) is det <= pt_output(S, U). @@ -343,6 +345,12 @@ mercury_format_inst_name(Lang, InstVarSet, InstName, S, !U) :- %---------------------------------------------------------------------------% +mercury_constrained_inst_vars_to_string(Lang, InstVarSet, Vars, Inst) = Str :- + State0 = string.builder.init, + mercury_format_constrained_inst_vars(Lang, InstVarSet, Vars, Inst, + string.builder.handle, State0, State), + Str = string.builder.to_string(State). + mercury_format_constrained_inst_vars(Lang, InstVarSet, !.Vars, Inst, S, !U) :- ( if set.remove_least(Var, !Vars) then add_string("(", S, !U), diff --git a/compiler/parse_tree_out_pragma.m b/compiler/parse_tree_out_pragma.m index c5445b962..e59ecd2cf 100644 --- a/compiler/parse_tree_out_pragma.m +++ b/compiler/parse_tree_out_pragma.m @@ -63,6 +63,10 @@ :- pred mercury_format_item_foreign_proc(S::in, output_lang::in, item_foreign_proc_info::in, U::di, U::uo) is det <= pt_output(S, U). +:- pred mercury_format_pragma_type_spec_constr(S::in, output_lang::in, + decl_pragma_type_spec_constr_info::in, U::di, U::uo) is det + <= pt_output(S, U). + :- pred mercury_format_pragma_type_spec(S::in, output_lang::in, decl_pragma_type_spec_info::in, U::di, U::uo) is det <= pt_output(S, U). @@ -166,6 +170,10 @@ mercury_format_item_decl_pragma(Info, Stream, DeclPragma, !IO) :- ; DeclPragma = decl_pragma_format_call(FormatCall), mercury_format_pragma_format_call(FormatCall, Stream, !IO) + ; + DeclPragma = decl_pragma_type_spec_constr(TypeSpecConstr), + mercury_format_pragma_type_spec_constr(Stream, Lang, + TypeSpecConstr, !IO) ; DeclPragma = decl_pragma_type_spec(TypeSpec), mercury_format_pragma_type_spec(Stream, Lang, TypeSpec, !IO) @@ -919,9 +927,29 @@ backend_to_string(Backend) = Str :- % Output a type_spec pragma. % +mercury_format_pragma_type_spec_constr(S, _Lang, TypeSpecConstr, !U) :- + TypeSpecConstr = decl_pragma_type_spec_constr_info(_ModuleName, + OoMConstraints, ApplyToSupers, OoMTypeSubsts, TVarSet, _, _, _), + IndentStr = " ", + add_string(":- pragma type_spec_constrained_preds([", S, !U), + add_list(mercury_format_type_spec_constraint(IndentStr, TVarSet), ",\n", + one_or_more_to_list(OoMConstraints), S, !U), + add_string("\n], ", S, !U), + ( + ApplyToSupers = do_not_apply_to_supers, + add_string("do_not_apply_to_superclasses, ", S, !U) + ; + ApplyToSupers = apply_to_supers, + add_string("apply_to_superclasses, ", S, !U) + ), + add_string("[\n", S, !U), + add_list(mercury_format_type_subst_new(IndentStr, TVarSet), ",\n", + one_or_more_to_list(OoMTypeSubsts), S, !U), + add_string("\n]).\n", S, !U). + mercury_format_pragma_type_spec(S, Lang, TypeSpec, !U) :- TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, _SpecModuleName, - TypeSubst, VarSet, _, _, _), + TypeSubst, TVarSet, _, _, _), add_string(":- pragma type_spec(", S, !U), ( ( @@ -946,35 +974,78 @@ mercury_format_pragma_type_spec(S, Lang, TypeSpec, !U) :- mercury_format_pred_name_arity(PredName, PredArity, S, !U) ), add_string(", ", S, !U), - % The code that parses type_spec pragmas ensures that all types variables - % in the substitution are named. Therefore there is no reason to print - % variable numbers. In fact, printing variable numbers would be a bug, - % since any code reading the pragma we are now writing out would mistake - % the variable number as part of the variable *name*. See the long comment - % on the tspec_tvarset field of the pragma in prog_item.m. + mercury_format_type_subst_old(TVarSet, TypeSubst, S, !U), + add_string(").\n", S, !U). + +:- pred mercury_format_type_spec_constraint(string::in, tvarset::in, + var_or_ground_constraint::in, S::in, U::di, U::uo) is det + <= pt_output(S, U). + +mercury_format_type_spec_constraint(Prefix, TVarSet, Constraint, S, !U) :- + add_string(Prefix, S, !U), + Constraint = var_or_ground_constraint(Name, Args, _Context), + mercury_format_sym_name(Name, S, !U), + add_string("(", S, !U), + add_list(mercury_format_var_or_ground_type(TVarSet), ", ", + Args, S, !U), + add_string(")", S, !U). + +:- pred mercury_format_var_or_ground_type(tvarset::in, var_or_ground_type::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). + +mercury_format_var_or_ground_type(TVarSet, Arg, S, !U) :- + ( + Arg = type_var_name(_, VarName), + add_string(VarName, S, !U) + ; + Arg = ground_type(GroundType), + Type = coerce(GroundType), + mercury_format_type(TVarSet, print_name_only, Type, S, !U) + ). + +:- pred mercury_format_type_subst_new(string::in, tvarset::in, type_subst::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). + +mercury_format_type_subst_new(Prefix, TVarSet, TypeSubst, S, !U) :- + TypeSubst = one_or_more(HeadTypeSubst, TailTypeSubsts), + add_string(Prefix, S, !U), + add_string("subst([", S, !U), + add_list(mercury_format_tvar_subst(TVarSet), ", ", + [HeadTypeSubst | TailTypeSubsts], S, !U), + add_string("])", S, !U). + +:- pred mercury_format_type_subst_old(tvarset::in, type_subst::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). + +mercury_format_type_subst_old(TVarSet, TypeSubst, S, !U) :- TypeSubst = one_or_more(HeadTypeSubst, TailTypeSubsts), ( TailTypeSubsts = [], % In the common case of there being only type substitution, % do not put unnecessary parentheses around it. - mercury_format_type_subst(VarSet, print_name_only, HeadTypeSubst, - S, !U) + mercury_format_tvar_subst(TVarSet, HeadTypeSubst, S, !U) ; TailTypeSubsts = [_ | _], add_string("(", S, !U), - add_list(mercury_format_type_subst(VarSet, print_name_only), ", ", + add_list(mercury_format_tvar_subst(TVarSet), ", ", [HeadTypeSubst | TailTypeSubsts], S, !U), add_string(")", S, !U) - ), - add_string(").\n", S, !U). + ). -:- pred mercury_format_type_subst(tvarset::in, var_name_print::in, - pair(tvar, mer_type)::in, S::in, U::di, U::uo) is det <= pt_output(S, U). +:- pred mercury_format_tvar_subst(tvarset::in, tvar_subst::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). -mercury_format_type_subst(VarSet, VarNamePrint, Var - Type, S, !U) :- - mercury_format_var_vs(VarSet, VarNamePrint, Var, S, !U), +mercury_format_tvar_subst(VarSet, TVarSubst, S, !U) :- + % The code that parses type_spec pragmas ensures that all type variables + % in the substitution are named. Therefore there is no reason to print + % variable numbers. In fact, printing variable numbers would be a bug, + % since any code reading the pragma we are now writing out would mistake + % the variable number as part of the variable *name*. See the long comment + % on the tspec_tvarset field of the pragma in prog_item.m. + TVarSubst = tvar_subst(Var, Type), + mercury_format_var_vs(VarSet, print_name_only, Var, S, !U), add_string(" = ", S, !U), - mercury_format_type(VarSet, VarNamePrint, Type, S, !U). + mercury_format_type(VarSet, print_name_only, Type, S, !U). %---------------------------------------------------------------------------% % @@ -1605,8 +1676,15 @@ mercury_pred_name_arity_to_string(PredName, UserArity) = Str :- :- pred mercury_format_pred_name_arity(sym_name::in, user_arity::in, S::in, U::di, U::uo) is det <= pt_output(S, U). -mercury_format_pred_name_arity(PredName, user_arity(Arity), S, !U) :- - NGT = next_to_graphic_token, +mercury_format_pred_name_arity(PredName, UserArity, S, !U) :- + mercury_format_pred_name_arity_ngt(next_to_graphic_token, PredName, + UserArity, S, !U). + +:- pred mercury_format_pred_name_arity_ngt(needs_quotes::in, + sym_name::in, user_arity::in, S::in, U::di, U::uo) is det + <= pt_output(S, U). + +mercury_format_pred_name_arity_ngt(NGT, PredName, user_arity(Arity), S, !U) :- mercury_format_bracketed_sym_name_ngt(NGT, PredName, S, !U), add_string("/", S, !U), add_int(Arity, S, !U). @@ -1627,7 +1705,8 @@ mercury_pred_pf_name_arity_to_string(PredOrFunc, PredName, UserArity) = Str :- mercury_format_pred_pf_name_arity(PredOrFunc, PredName, UserArity, S, !U) :- add_string(pred_or_func_to_str(PredOrFunc), S, !U), add_string("(", S, !U), - mercury_format_pred_name_arity(PredName, UserArity, S, !U), + mercury_format_pred_name_arity_ngt(not_next_to_graphic_token, + PredName, UserArity, S, !U), add_string(")", S, !U). :- func mercury_pred_pfu_name_arity_to_string(pred_func_or_unknown, diff --git a/compiler/parse_tree_out_sym_name.m b/compiler/parse_tree_out_sym_name.m index 076828d1a..dc519bd0f 100644 --- a/compiler/parse_tree_out_sym_name.m +++ b/compiler/parse_tree_out_sym_name.m @@ -255,12 +255,25 @@ mercury_output_bracketed_sym_name_ngt(NextToGraphicToken, SymName, mercury_format_bracketed_sym_name_ngt(NextToGraphicToken, SymName, S, !U) :- ( SymName = qualified(ModuleName, Name), + % XXX REDUNDANT PARENS +% ( +% NextToGraphicToken = next_to_graphic_token, +% add_string("(", S, !U) +% ; +% NextToGraphicToken = not_next_to_graphic_token +% ), add_string("(", S, !U), mercury_format_bracketed_sym_name_ngt(next_to_graphic_token, ModuleName, S, !U), add_string(".", S, !U), mercury_format_bracketed_atom(next_to_graphic_token, Name, S, !U), add_string(")", S, !U) +% ( +% NextToGraphicToken = next_to_graphic_token, +% add_string(")", S, !U) +% ; +% NextToGraphicToken = not_next_to_graphic_token +% ) ; SymName = unqualified(Name), mercury_format_bracketed_atom(NextToGraphicToken, Name, S, !U) diff --git a/compiler/parse_tree_out_type.m b/compiler/parse_tree_out_type.m index 942d9acd6..da1242aef 100644 --- a/compiler/parse_tree_out_type.m +++ b/compiler/parse_tree_out_type.m @@ -26,7 +26,8 @@ %---------------------------------------------------------------------------% -:- func mercury_type_list_to_string(tvarset, list(mer_type)) = string. +:- func mercury_types_to_string(tvarset, var_name_print, list(mer_type)) + = string. :- func mercury_type_to_string(tvarset, var_name_print, mer_type) = string. :- pred mercury_output_type(tvarset::in, var_name_print::in, mer_type::in, @@ -92,19 +93,20 @@ %---------------------------------------------------------------------------% -mercury_type_list_to_string(_, []) = "". -mercury_type_list_to_string(VarSet, [Type | Types]) = String :- - HeadString = mercury_type_to_string(VarSet, print_name_only, Type), - TailString = mercury_comma_type_list_to_string(VarSet, Types), - String = HeadString ++ TailString. +mercury_types_to_string(_, _, []) = "". +mercury_types_to_string(VarSet, VarNamePrint, [Type | Types]) = Str :- + HeadStr = mercury_type_to_string(VarSet, VarNamePrint, Type), + TailStr = mercury_comma_types_to_string(VarSet, VarNamePrint, Types), + Str = HeadStr ++ TailStr. -:- func mercury_comma_type_list_to_string(tvarset, list(mer_type)) = string. +:- func mercury_comma_types_to_string(tvarset, var_name_print, list(mer_type)) + = string. -mercury_comma_type_list_to_string(_, []) = "". -mercury_comma_type_list_to_string(VarSet, [Type | Types]) = String :- - HeadString = mercury_type_to_string(VarSet, print_name_only, Type), - TailString = mercury_comma_type_list_to_string(VarSet, Types), - String = ", " ++ HeadString ++ TailString. +mercury_comma_types_to_string(_, _, []) = "". +mercury_comma_types_to_string(VarSet, VarNamePrint, [Type | Types]) = Str :- + HeadStr = mercury_type_to_string(VarSet, VarNamePrint, Type), + TailStr = mercury_comma_types_to_string(VarSet, VarNamePrint, Types), + Str = ", " ++ HeadStr ++ TailStr. %---------------------------------------------------------------------------% diff --git a/compiler/parse_type_name.m b/compiler/parse_type_name.m index 148fcdc88..ef9825fde 100644 --- a/compiler/parse_type_name.m +++ b/compiler/parse_type_name.m @@ -49,6 +49,7 @@ ; wnhii_ctgc_type_selector ; wnhii_pragma_struct_sharing ; wnhii_pragma_struct_reuse + ; wnhii_pragma_type_spec_constr ; wnhii_pragma_type_spec. :- pred maybe_parse_type(allow_ho_inst_info::in, term::in, mer_type::out) @@ -847,6 +848,9 @@ no_ho_inst_allowed_result(ContextPieces, Why, VarSet, Term) = Result :- ; Why = wnhii_pragma_struct_reuse, Place = "a structure_reuse pragma" + ; + Why = wnhii_pragma_type_spec_constr, + Place = "a type_spec_constrained_preds pragma" ; Why = wnhii_pragma_type_spec, Place = "a type_spec pragma" diff --git a/compiler/pred_name.m b/compiler/pred_name.m index b0527f884..5ac3938f1 100644 --- a/compiler/pred_name.m +++ b/compiler/pred_name.m @@ -956,7 +956,8 @@ origin_user_to_user_dev_string(UserOrDev, OriginUser) = Str :- InstanceTypes, _, _), ClassId = class_id(ClassName, _), ClassStr = sym_name_to_string(ClassName), - TypeStrs = mercury_type_list_to_string(varset.init, InstanceTypes), + TypeStrs = mercury_types_to_string(varset.init, print_name_only, + InstanceTypes), ( UserOrDev = user, string.format("instance method %s for `%s(%s)'", @@ -1852,9 +1853,9 @@ type_subst_to_string(VarSet, TypeSubst) = Str :- TVarsStr = string.join_list(", ", TVarStrs), string.format("[%s]", [s(TVarsStr)], Str). -:- func type_var_subst_to_string(tvarset, pair(tvar, mer_type)) = string. +:- func type_var_subst_to_string(tvarset, tvar_subst) = string. -type_var_subst_to_string(VarSet, Var - Type) = Str :- +type_var_subst_to_string(VarSet, tvar_subst(Var, Type)) = Str :- varset.lookup_name(VarSet, Var, VarName), TypeStr = mercury_type_to_string(VarSet, print_name_only, Type), % XXX The use of = here *requires* mangling the names we construct. diff --git a/compiler/prog_data.m b/compiler/prog_data.m index 2a768a1ef..51502ea65 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -871,6 +871,15 @@ cons_id_is_const_struct(ConsId, ConstNum) :- % A type expression with an explicit kind annotation. % (These are not yet used.) +:- type ground_type =< mer_type + ---> defined_type(sym_name, list(ground_type), kind) + ; builtin_type(builtin_type) + ; tuple_type(list(ground_type), kind) + ; higher_order_type(pred_or_func, list(ground_type), ho_inst_info, + purity, lambda_eval_method) + ; apply_n_type(tvar, list(ground_type), kind) + ; kinded_type(ground_type, kind). + % We could use this subtype in the mercury_nb_type function symbol % of mlds_type in mlds.m. % diff --git a/compiler/prog_data_pragma.m b/compiler/prog_data_pragma.m index eb7c6ef71..6c9be67f9 100644 --- a/compiler/prog_data_pragma.m +++ b/compiler/prog_data_pragma.m @@ -477,9 +477,11 @@ tabled_eval_method_to_table_type(EvalMethod) = TableTypeStr :- % The type substitution for a `pragma type_spec' declaration. % Elsewhere in the compiler we generally use the `tsubst' type - % which is a map rather than an assoc_list. + % which is a map rather than (effectively) an assoc_list. % -:- type type_subst == one_or_more(pair(tvar, mer_type)). +:- type type_subst == one_or_more(tvar_subst). +:- type tvar_subst + ---> tvar_subst(tvar, mer_type). %---------------------------------------------------------------------------% % diff --git a/compiler/prog_item.m b/compiler/prog_item.m index b1edddd2a..d5c14ff5e 100644 --- a/compiler/prog_item.m +++ b/compiler/prog_item.m @@ -1441,6 +1441,12 @@ ---> item_typeclass_info( tc_class_name :: class_name, tc_class_params :: list(tvar), + % The argument list of every superclass constraint + % must be either a type variable, or a ground type. + % This is enforced by parse_superclass_constraints + % in parse_class.m. + % XXX We should consider changing the type of this field + % from list(prog_constraint) to list(var_or_ground_constraint). tc_superclasses :: list(prog_constraint), tc_fundeps :: list(prog_fundep), tc_class_methods :: class_interface, @@ -2471,6 +2477,7 @@ ---> decl_pragma_obsolete_pred(decl_pragma_obsolete_pred_info) ; decl_pragma_obsolete_proc(decl_pragma_obsolete_proc_info) ; decl_pragma_format_call(decl_pragma_format_call_info) + ; decl_pragma_type_spec_constr(decl_pragma_type_spec_constr_info) ; decl_pragma_type_spec(decl_pragma_type_spec_info) ; decl_pragma_oisu(decl_pragma_oisu_info) ; decl_pragma_termination(decl_pragma_termination_info) @@ -2523,6 +2530,64 @@ format_seq_num :: item_seq_num ). +:- type decl_pragma_type_spec_constr_info + ---> decl_pragma_type_spec_constr_info( + % The name of the module from whose (source or interface) file + % we read the type_spec_constrained_preds pragma. This will + % always name the module that contains the pragma, because + % we never put a type_spec_constrained_preds pragma into + % any interface file other than an interface file of the + % module containing the pragma. + tsc_module_name :: module_name, + + % The list of constraints in the first argument of the pragma. + % The pragma asks for the type specialization of any predicates + % whose class context includes any nonempty subset of these + % constraints, and possibly (see the next field) their + % superclasses, as instances. + tsc_constraints :: one_or_more(var_or_ground_constraint), + + % The second argument of the pragma, which specifies whether + % the constraints in the first argument also implicitly specify + % their superclasses, *their* superclasses, and so on. + % If e.g. tc1(A, B, C) has tc2(A, B) as one of its + % superclasses, then a setting of apply_to_supers in this field + % means that the pragma asks us to specialize not only + % predicates whose class context includes tc1(A, char, B) + % (if that is has as its instance of one of the constraints), + % but also e.g. tc2(A, char). + tsc_apply_to_supers :: maybe_apply_to_supers, + + % The third argument of the pragma, which specifies the list + % of type substitutions for which the pragma asks us to create + % type-specialized versions of each predicate that matches + % the requirements described by the first and second args. + % + % Each type var on the left-hand-side of a substitution + % must occur in tsc_constraints, while all type vars that + % occur in a type on the right-hand-side of a substitution + % must be anonymous. These requirements are enforced by the + % code that parses these pragmas. + tsc_tsubst :: one_or_more(type_subst), + + % The varset of the term containing the pragma, coerced + % to being a tvarset (since all variables in the pragma + % are type variables). + % + % All variables in this tvarset have to have explicit names. + % If the original pragma contains anonymous variables, the + % code constructing this decl_pragma_type_spec will give + % those variable names. See the comment on the tspec_tvarset + % field below for the reason behind this requirement. + tsc_tvarset :: tvarset, + + % The equivalence types used. + tsc_items :: set(recomp_item_id), + + tsc_context :: prog_context, + tsc_seq_num :: item_seq_num + ). + :- type decl_pragma_type_spec_info ---> decl_pragma_type_spec_info( tspec_pfumm :: pred_func_or_unknown_maybe_modes, @@ -2532,7 +2597,7 @@ % The name of the module from whose (source or interface) file % we read the type_spec pragma. This will always name - % the module that contain the pragma, because we never put + % the module that contains the pragma, because we never put % a type_spec pragma into any interface file other than % an interface file of the module containing the pragma. tspec_module_name :: module_name, @@ -2580,6 +2645,21 @@ tspec_seq_num :: item_seq_num ). +:- type var_or_ground_constraint + ---> var_or_ground_constraint( + class_name, + list(var_or_ground_type), + prog_context + ). + +:- type var_or_ground_type + ---> type_var_name(tvar, string) + ; ground_type(ground_type). + +:- type maybe_apply_to_supers + ---> do_not_apply_to_supers + ; apply_to_supers. + :- type decl_pragma_oisu_info ---> decl_pragma_oisu_info( oisu_type_ctor :: type_ctor, @@ -3493,6 +3573,9 @@ get_decl_pragma_context(DeclPragma) = Context :- ; DeclPragma = decl_pragma_format_call(FormatCall), Context = FormatCall ^ format_context + ; + DeclPragma = decl_pragma_type_spec_constr(TypeSpecConstr), + Context = TypeSpecConstr ^ tsc_context ; DeclPragma = decl_pragma_type_spec(TypeSpec), Context = TypeSpec ^ tspec_context diff --git a/compiler/prog_item_stats.m b/compiler/prog_item_stats.m index b06a5da00..7aa5e06d7 100644 --- a/compiler/prog_item_stats.m +++ b/compiler/prog_item_stats.m @@ -329,6 +329,7 @@ gather_stats_in_item_decl_pragma(DeclPragma, !ItemStats) :- ; ( DeclPragma = decl_pragma_format_call(_) ; DeclPragma = decl_pragma_type_spec(_) + ; DeclPragma = decl_pragma_type_spec_constr(_) ; DeclPragma = decl_pragma_obsolete_pred(_) ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_oisu(_) diff --git a/compiler/prog_type_test.m b/compiler/prog_type_test.m index 39dc53e4a..cbddd4cd0 100644 --- a/compiler/prog_type_test.m +++ b/compiler/prog_type_test.m @@ -68,9 +68,11 @@ %---------------------------------------------------------------------------% % Succeeds iff the given type is ground (that is, contains no type - % variables). + % variables). The second version returns the input type with a form + % that expresses its groundness in its own type. % :- pred type_is_ground(mer_type::in) is semidet. +:- pred type_is_ground(mer_type::in, ground_type::out) is semidet. % Succeeds iff the given type contains no type variables except % for those in the given list. @@ -174,6 +176,42 @@ type_is_higher_order_details_det(Type, !:Purity, !:PredOrFunc, !:EvalMethod, type_is_ground(Type) :- not type_contains_var(Type, _). +type_is_ground(Type, GroundType) :- + require_complete_switch [Type] + ( + ( Type = type_variable(_TVar, _) + ; Type = apply_n_type(_TVar, _, _) + ), + fail + ; + Type = builtin_type(BuiltinType), + GroundType = builtin_type(BuiltinType) + ; + Type = defined_type(SymName, ArgTypes, Kind), + types_are_ground(ArgTypes, GroundArgTypes), + GroundType = defined_type(SymName, GroundArgTypes, Kind) + ; + Type = tuple_type(ArgTypes, Kind), + types_are_ground(ArgTypes, GroundArgTypes), + GroundType = tuple_type(GroundArgTypes, Kind) + ; + Type = higher_order_type(PorF, ArgTypes, HoInstInfo, Purity, EM), + types_are_ground(ArgTypes, GroundArgTypes), + GroundType = higher_order_type(PorF, GroundArgTypes, HoInstInfo, + Purity, EM) + ; + Type = kinded_type(SubType, Kind), + type_is_ground(SubType, GroundSubType), + GroundType = kinded_type(GroundSubType, Kind) + ). + +:- pred types_are_ground(list(mer_type)::in, list(ground_type)::out) is semidet. + +types_are_ground([], []). +types_are_ground([Type | Types], [GroundType | GroundTypes]) :- + type_is_ground(Type, GroundType), + types_are_ground(Types, GroundTypes). + type_is_ground_except_vars(Type, Except) :- all [TVar] ( type_contains_var(Type, TVar) diff --git a/compiler/prog_type_unify.m b/compiler/prog_type_unify.m index 6ee13fe7c..5ccbdf09c 100644 --- a/compiler/prog_type_unify.m +++ b/compiler/prog_type_unify.m @@ -31,8 +31,8 @@ % No kind checking is done, since it is assumed that kind errors % will be picked up elsewhere. % -:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, tsubst::in, - tsubst::out) is semidet. +:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, + tsubst::in, tsubst::out) is semidet. :- pred type_unify_list(list(mer_type)::in, list(mer_type)::in, list(tvar)::in, tsubst::in, tsubst::out) is semidet. diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m index 6315e7658..d178d9e9f 100644 --- a/compiler/recompilation.usage.m +++ b/compiler/recompilation.usage.m @@ -42,6 +42,7 @@ :- import_module mdbcomp.prim_data. :- import_module mdbcomp.sym_name. :- import_module parse_tree.prog_data. +:- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_item. :- import_module parse_tree.prog_type. :- import_module parse_tree.prog_type_test. @@ -799,7 +800,8 @@ find_items_used_by_pred(PredOrFunc, NameArity, PredId - PredModule, !Info) :- % Record items used by `:- pragma type_spec' declarations. module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo), TypeSpecInfo = type_spec_info(_, _, _, PragmaMap), - ( if map.search(PragmaMap, PredId, TypeSpecPragmas) then + ( if map.search(PragmaMap, PredId, OoMTypeSpecPragmas) then + TypeSpecPragmas = one_or_more_to_list(OoMTypeSpecPragmas), list.foldl(find_items_used_by_type_spec, TypeSpecPragmas, !Info) else true @@ -831,7 +833,8 @@ find_items_used_by_type_spec(TypeSpecInfo, !Info) :- ; PFUMM = pfumm_unknown(_Arity) ), - assoc_list.values(one_or_more_to_list(Subst), SubstTypes), + SubstTypes = list.map((func(tvar_subst(_Var, Type)) = Type), + one_or_more_to_list(Subst)), find_items_used_by_types(SubstTypes, !Info). :- pred find_items_used_by_functors(simple_item_set::in, diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m index affef21dc..c7c6f0e66 100644 --- a/compiler/recompilation.version.m +++ b/compiler/recompilation.version.m @@ -91,6 +91,7 @@ :- import_module parse_tree.parse_tree_out_term. :- import_module parse_tree.parse_tree_to_term. :- import_module parse_tree.parse_util. +:- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_type. :- import_module parse_tree.prog_type_subst. :- import_module parse_tree.prog_type_unify. @@ -957,6 +958,14 @@ distribute_pragma_items_class_items(MaybePredOrFunc, SymName, Arity, gather_decl_pragma_for_what_pf_id(DeclPragma, MaybePredOrFuncId) :- ( + DeclPragma = decl_pragma_type_spec_constr(_TypeSpecConstr), + % XXX Unlike all the other decl_pragmas, the type_spec_constr + % pragma is not about a single specified predicate or function, + % but about all predicates and functions that have a specified + % set of constraints in their signature. That set is computed later, + % when we add this pragma to the HLDS. + MaybePredOrFuncId = no + ; DeclPragma = decl_pragma_type_spec(TypeSpec), TypeSpec = decl_pragma_type_spec_info(PFUMM, Name, _, _, _, _, _, _), pfumm_to_maybe_pf_arity_maybe_modes(PFUMM, MaybePredOrFunc, @@ -1422,6 +1431,24 @@ is_decl_pragma_changed(DeclPragma1, DeclPragma2, Changed) :- DeclPragma2 = decl_pragma_format_call(FormatCall2), FormatCall1 = decl_pragma_format_call_info(A, B, _, _), FormatCall2 = decl_pragma_format_call_info(A, B, _, _) + ; + DeclPragma1 = decl_pragma_type_spec_constr(TypeSpecConstr1), + DeclPragma2 = decl_pragma_type_spec_constr(TypeSpecConstr2), + TypeSpecConstr1 = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints1, ApplyToSupers1, OoMTypeSubsts1, TVarSet1, + _, _, _), + TypeSpecConstr2 = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints2, ApplyToSupers2, OoMTypeSubsts2, TVarSet2, + _, _, _), + ApplyToSupers1 = ApplyToSupers2, + Constraints1 = one_or_more_to_list(OoMConstraints1), + Constraints2 = one_or_more_to_list(OoMConstraints2), + is_any_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraints1, Constraints2, unchanged), + TypeSubsts1 = one_or_more_to_list(OoMTypeSubsts1), + TypeSubsts2 = one_or_more_to_list(OoMTypeSubsts2), + is_any_type_subst_changed(TVarSet1, TVarSet2, + TypeSubsts1, TypeSubsts2, unchanged) ; DeclPragma1 = decl_pragma_type_spec(TypeSpec1), DeclPragma2 = decl_pragma_type_spec(TypeSpec2), @@ -1429,19 +1456,8 @@ is_decl_pragma_changed(DeclPragma1, DeclPragma2, Changed) :- TypeSubst1, TVarSet1, _, _, _), TypeSpec2 = decl_pragma_type_spec_info(PFUMM, Name, SpecName, TypeSubst2, TVarSet2, _, _, _), - assoc_list.keys_and_values(one_or_more_to_list(TypeSubst1), - TVars1, Types1), - assoc_list.keys_and_values(one_or_more_to_list(TypeSubst2), - TVars2, Types2), - % XXX kind inference: - % we assume vars have kind `star'. - KindMap = map.init, - prog_type.var_list_to_type_list(KindMap, TVars1, TVarTypes1), - prog_type.var_list_to_type_list(KindMap, TVars2, TVarTypes2), - type_list_is_unchanged( - TVarSet1, TVarTypes1 ++ Types1, - TVarSet2, TVarTypes2 ++ Types2, - _, _, _) + is_type_subst_changed(TVarSet1, TVarSet2, TypeSubst1, TypeSubst2, + unchanged) ; DeclPragma1 = decl_pragma_oisu(OISU1), DeclPragma2 = decl_pragma_oisu(OISU2), @@ -1616,7 +1632,7 @@ pred_or_func_type_is_unchanged(TVarSet1, ExistQVars1, TypesAndMaybeModes1, AllTypes2 = Types2 ), - type_list_is_unchanged(TVarSet1, AllTypes1, TVarSet2, AllTypes2, + type_list_is_unchanged(TVarSet1, TVarSet2, AllTypes1, AllTypes2, _TVarSet, Renaming, Types2ToTypes1Subst), % Check that the existentially quantified variables are equivalent. @@ -1645,11 +1661,104 @@ pred_or_func_type_is_unchanged(TVarSet1, ExistQVars1, TypesAndMaybeModes1, RenamedConstraints2, SubstConstraints2), Constraints1 = SubstConstraints2. -:- pred type_list_is_unchanged(tvarset::in, list(mer_type)::in, - tvarset::in, list(mer_type)::in, tvarset::out, - tvar_renaming::out, tsubst::out) is semidet. +:- pred is_any_var_or_ground_constraint_changed(tvarset::in, tvarset::in, + list(var_or_ground_constraint)::in, list(var_or_ground_constraint)::in, + maybe_changed::out) is det. -type_list_is_unchanged(TVarSet1, Types1, TVarSet2, Types2, +is_any_var_or_ground_constraint_changed(_, _, [], [], unchanged). +is_any_var_or_ground_constraint_changed(_, _, [], [_ | _], changed). +is_any_var_or_ground_constraint_changed(_, _, [_ | _], [], changed). +is_any_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + [Constraint1 | Constraints1], [Constraint2 | Constraints2], Changed) :- + is_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraint1, Constraint2, HeadChanged), + ( + HeadChanged = changed, + Changed = changed + ; + HeadChanged = unchanged, + is_any_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraints1, Constraints2, Changed) + ). + +:- pred is_var_or_ground_constraint_changed(tvarset::in, tvarset::in, + var_or_ground_constraint::in, var_or_ground_constraint::in, + maybe_changed::out) is det. + +is_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraint1, Constraint2, Changed) :- + Constraint1 = var_or_ground_constraint(ClassName1, Args1, _), + Constraint2 = var_or_ground_constraint(ClassName2, Args2, _), + VarOrGroundToType = + ( pred(Arg::in, Type::out) is det :- + ( + Arg = type_var_name(TVar, _), + Type = type_variable(TVar, kind_star) + ; + Arg = ground_type(GroundType), + Type = coerce(GroundType) + ) + ), + list.map(VarOrGroundToType, Args1, ArgTypes1), + list.map(VarOrGroundToType, Args2, ArgTypes2), + ( if + ClassName1 = ClassName2, + type_list_is_unchanged(TVarSet1, TVarSet2, ArgTypes1, ArgTypes2, + _, _, _) + then + Changed = unchanged + else + Changed = changed + ). + +:- pred is_any_type_subst_changed(tvarset::in, tvarset::in, + list(type_subst)::in, list(type_subst)::in, maybe_changed::out) is det. + +is_any_type_subst_changed(_, _, [], [], unchanged). +is_any_type_subst_changed(_, _, [], [_ | _], changed). +is_any_type_subst_changed(_, _, [_ | _], [], changed). +is_any_type_subst_changed(TVarSet1, TVarSet2, + [TypeSubst1 | TypeSubsts1], [TypeSubst2 | TypeSubsts2], Changed) :- + is_type_subst_changed(TVarSet1, TVarSet2, + TypeSubst1, TypeSubst2, HeadChanged), + ( + HeadChanged = changed, + Changed = changed + ; + HeadChanged = unchanged, + is_any_type_subst_changed(TVarSet1, TVarSet2, + TypeSubsts1, TypeSubsts2, Changed) + ). + +:- pred is_type_subst_changed(tvarset::in, tvarset::in, + type_subst::in, type_subst::in, maybe_changed::out) is det. + +is_type_subst_changed(TVarSet1, TVarSet2, TypeSubst1, TypeSubst2, Changed) :- + GetVarType = + ( pred(tvar_subst(TVar, Type)::in, TVar::out, Type::out) is det ), + list.map2(GetVarType, one_or_more_to_list(TypeSubst1), + TVars1, Types1), + list.map2(GetVarType, one_or_more_to_list(TypeSubst2), + TVars2, Types2), + % XXX kind inference: + % we assume vars have kind `star'. + KindMap = map.init, + prog_type.var_list_to_type_list(KindMap, TVars1, TVarTypes1), + prog_type.var_list_to_type_list(KindMap, TVars2, TVarTypes2), + ( if + type_list_is_unchanged(TVarSet1, TVarSet2, + TVarTypes1 ++ Types1, TVarTypes2 ++ Types2, _, _, _) + then + Changed = unchanged + else + Changed = changed + ). + +:- pred type_list_is_unchanged(tvarset::in, tvarset::in, + list(mer_type)::in, list(mer_type)::in, + tvarset::out, tvar_renaming::out, tsubst::out) is semidet. + +type_list_is_unchanged(TVarSet1, TVarSet2, Types1, Types2, TVarSet, Renaming, Types2ToTypes1Subst) :- tvarset_merge_renaming(TVarSet1, TVarSet2, TVarSet, Renaming), apply_variable_renaming_to_type_list(Renaming, Types2, SubstTypes2), diff --git a/doc/user_guide.texi b/doc/user_guide.texi index 05b3df26f..069d67ee5 100644 --- a/doc/user_guide.texi +++ b/doc/user_guide.texi @@ -7048,6 +7048,13 @@ could be packed more tightly if they were reordered. @c Print an informational message for each otherwise-ignored error @c that reports an inability to find the procedure that a pragma refers to. +@c @sp 1 +@c @item --inform-generated-type-spec-pragmas +@c @findex --inform-generated-type-spec-pragmas +@c Print an informational message for each @code{type_spec pragma} that +@c the compiler generates to implement +@c a @code{type_spec_constrained_pred} pragma. + @end table @node Verbosity options diff --git a/mdbcomp/slice_and_dice.m b/mdbcomp/slice_and_dice.m index d46cf5218..fb7ab4903 100644 --- a/mdbcomp/slice_and_dice.m +++ b/mdbcomp/slice_and_dice.m @@ -976,14 +976,16 @@ format_float(DecimalPlaces, Flt) = :- pred proc_label_is_for_module(string::in, proc_label::in) is semidet. -proc_label_is_for_module(Module, ProcLabel) :- +proc_label_is_for_module(ModuleNameStr, ProcLabel) :- ( - ProcLabel = ordinary_proc_label(_, _, ProcSymModule, _, _, _) + ProcLabel = ordinary_proc_label(_, _, ProcModuleName, _, _, _) ; - ProcLabel = special_proc_label(_, _, ProcSymModule, _, _, _) + ProcLabel = special_proc_label(_, _, ProcModuleName, _, _, _) ), - SymModule = string_to_sym_name(Module), - is_submodule(ProcSymModule, SymModule). + ModuleName = string_to_sym_name(ModuleNameStr), + % XXX Why are we saying that ProcLabel is for ModuleNameStr if it + % specifies the name of a module that is a *submodule* of ModuleNameStr? + is_same_module_or_submodule(ProcModuleName, ModuleName). :- func format_proc_label(proc_label) = string. diff --git a/mdbcomp/sym_name.m b/mdbcomp/sym_name.m index 54da37f4d..3feffef45 100644 --- a/mdbcomp/sym_name.m +++ b/mdbcomp/sym_name.m @@ -100,12 +100,14 @@ % :- pred det_list_to_sym_name(list(string)::in, sym_name::out) is det. - % is_submodule(SymName1, SymName2): + % is_same_module_or_submodule(ModuleName1, ModuleName2): % - % True iff SymName1 is a submodule of SymName2. - % For example mod1.mod2.mod3 is a submodule of mod1.mod2. + % True iff ModuleName1 is either the same as ModuleName2, + % or is a submodule of ModuleName2. For example, mod1.mod2.mod3 + % is a submodule of mod1.mod2. % -:- pred is_submodule(module_name::in, module_name::in) is semidet. +:- pred is_same_module_or_submodule(module_name::in, module_name::in) + is semidet. % Given a symbol name, return its unqualified name. % @@ -333,9 +335,9 @@ list_to_sym_name_loop(RevNames, SymName) :- %---------------------------------------------------------------------------% -is_submodule(SymName, SymName). -is_submodule(qualified(SymNameA, _), SymNameB) :- - is_submodule(SymNameA, SymNameB). +is_same_module_or_submodule(ModuleName, ModuleName). +is_same_module_or_submodule(qualified(ModuleNameA, _), ModuleNameB) :- + is_same_module_or_submodule(ModuleNameA, ModuleNameB). %---------------------------------------------------------------------------% diff --git a/tests/hard_coded/type_spec_modes.m b/tests/hard_coded/type_spec_modes.m index 32f864638..5ff953b17 100644 --- a/tests/hard_coded/type_spec_modes.m +++ b/tests/hard_coded/type_spec_modes.m @@ -21,7 +21,7 @@ :- mode my_unify(out, in) is det. :- pragma no_inline(my_unify/2). -:- pragma type_spec(my_unify(in, in), T = list(int)). +:- pragma type_spec(my_unify(in, in), subst([T = list(int)])). :- pragma type_spec(my_unify(in, in), T = int). :- pragma type_spec(my_unify(in, out), T = int). :- pragma type_spec(my_unify(out, in), T = list(int)). diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile index 94ea435c0..e8779d85d 100644 --- a/tests/invalid/Mmakefile +++ b/tests/invalid/Mmakefile @@ -79,6 +79,7 @@ BORING_SINGLEMODULE_PROGS = \ bad_pred_arity \ bad_statevar_bad_context \ bad_sv_unify_msg \ + bad_tscp \ bad_type_for_inst \ bind_in_negated \ bind_var_errors \ diff --git a/tests/invalid/bad_tscp.err_exp b/tests/invalid/bad_tscp.err_exp new file mode 100644 index 000000000..9242ca9c6 --- /dev/null +++ b/tests/invalid/bad_tscp.err_exp @@ -0,0 +1,30 @@ +bad_tscp.m:054: Error: in the third argument of a +bad_tscp.m:054: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:054: in the second substitution: +bad_tscp.m:054: any type variables that occur on the right hand side of a +bad_tscp.m:054: substitution must be anonymous, but Y is not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the first substitution: +bad_tscp.m:069: the left-hand-side type variable Unit must occur in the +bad_tscp.m:069: constraints listed in the first argument, but it does not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the first substitution: +bad_tscp.m:069: any type variables that occur on the right hand side of a +bad_tscp.m:069: substitution must be anonymous, but T is not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the second substitution: +bad_tscp.m:069: the left-hand-side type variables Unit and Xyzzy must occur +bad_tscp.m:069: in the constraints listed in the first argument, but they do +bad_tscp.m:069: not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the second substitution: +bad_tscp.m:069: any type variables that occur on the right hand side of a +bad_tscp.m:069: substitution must be anonymous, but U, K and V are not. +bad_tscp.m:072: In the third argument of a +bad_tscp.m:072: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:072: on the left hand side of the arrow: +bad_tscp.m:072: error: expected a variable, got `set(U)'. diff --git a/tests/invalid/bad_tscp.m b/tests/invalid/bad_tscp.m new file mode 100644 index 000000000..7c9153f9a --- /dev/null +++ b/tests/invalid/bad_tscp.m @@ -0,0 +1,79 @@ +%---------------------------------------------------------------------------% +% vim: ts=4 sw=4 et ft=mercury +%---------------------------------------------------------------------------% +% Test the operation of type_spec_constrained_preds pragmas. +% We keep the module name short to make the type_spec pragmas +% that the compiler outputs as informational messages fit on one line. +%---------------------------------------------------------------------------% + +:- module bad_tscp. +:- interface. + +:- import_module io. +:- pred main(io::di, io::uo) is det. + +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module bool. +:- import_module char. +:- import_module list. +:- import_module term. +:- import_module stream. +:- import_module string. +:- import_module string.builder. + +%---------------------------------------------------------------------------% + +:- typeclass tc1(E, F, G, H) <= (tc2(E, int, H), tc4(float, G)) where []. +:- typeclass tc2(K, L, M) <= (tc3(K, L), tc3(L, M)) where []. +:- typeclass tc3(P, Q) where []. +:- typeclass tc4(S, T) where []. + +:- instance tc1(int, int, int, int) where []. +:- instance tc2(int, int, int) where []. +:- instance tc3(int, int) where []. +:- instance tc4(float, int) where []. + +%---------------------------------------------------------------------------% + +main(!IO) :- + p1(41, 42, 43, 44, N), + io.write_int(N, !IO), + io.nl(!IO), + + io.input_stream(InputStream, !IO), + p2({InputStream, 'a', make_io_error("xyzzy")}, !IO). + +%---------------------------------------------------------------------------% + +:- pragma type_spec_constrained_preds( + [tc1(X1, X2, X3, X4)], + apply_to_superclasses, + [subst([X2 => char, X3 => bool]), + subst([X3 => int, X4 => var(Y)])]). + +:- pred p1(A::in, B::in, C::in, D::in, D::out) is det <= tc1(A, B, C, D). + +p1(_A, _B, _C, !D). + +%---------------------------------------------------------------------------% + +:- pragma type_spec_constrained_preds( + [stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, char, State, Error)], + apply_to_superclasses, + [subst([Stream => io.text_input_stream, Unit => list(T), + State => io.state, Error => io.error]), + subst([Stream => set(U), Unit => map(K, V), + State => io.state, Error => io.error, Xyzzy => float]), + subst([set(U) => map(K, V)])]). + +:- pred p2({Stream, Unit, Error}::in, State::di, State::uo) is det + <= (stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, Unit, State, Error)). + +p2({_Stream, _Unit, _Errors}, !State). diff --git a/tests/invalid_nodepend/typeclass_test_3.err_exp b/tests/invalid_nodepend/typeclass_test_3.err_exp index ce5c7a95a..7a17277e5 100644 --- a/tests/invalid_nodepend/typeclass_test_3.err_exp +++ b/tests/invalid_nodepend/typeclass_test_3.err_exp @@ -6,5 +6,5 @@ typeclass_test_3.m:005: than `:- import_module' in its interface section(s). typeclass_test_3.m:005: This would normally be a `:- pred' or `:- func' typeclass_test_3.m:005: declaration, or a `:- type', `:- inst', `:- mode', typeclass_test_3.m:005: `:- typeclass' or `:- instance' definition. -typeclass_test_3.m:008: Error: constraints on class declarations may only -typeclass_test_3.m:008: constrain type variables and ground types. +typeclass_test_3.m:008: Error: a class declaration may not contain an inst +typeclass_test_3.m:008: constraint such as `(T =< blah(X))'. diff --git a/tests/warnings/Mercury.options b/tests/warnings/Mercury.options index 419d39a6b..b4754cf2e 100644 --- a/tests/warnings/Mercury.options +++ b/tests/warnings/Mercury.options @@ -79,3 +79,5 @@ MCFLAGS-warn_self_import = --warn-simple-code MCFLAGS-warn_return = --warn-suspicious-foreign-procs MCFLAGS-warn_succ_ind = --warn-suspicious-foreign-procs MCFLAGS-suspicious_foreign_code = --warn-suspicious-foreign-code + +MCFLAGS-test_tscp = --inform-generated-type-spec-pragmas diff --git a/tests/warnings/Mmakefile b/tests/warnings/Mmakefile index c5020a989..7a545e962 100644 --- a/tests/warnings/Mmakefile +++ b/tests/warnings/Mmakefile @@ -56,6 +56,7 @@ ERRORCHECK_PROGS = \ suspicious_foreign_code \ suspicious_recursion \ table_with_inline \ + test_tscp \ unify_f_g \ unify_x_f_x \ unknown_warning \ diff --git a/tests/warnings/test_tscp.exp b/tests/warnings/test_tscp.exp index db73788cb..76f1fe772 100644 --- a/tests/warnings/test_tscp.exp +++ b/tests/warnings/test_tscp.exp @@ -1,4 +1,16 @@ -% For the type_spec_constrained_pred pragma at test_tscp.m:37, +% For the type_spec_constrained_preds pragma at test_tscp.m:54, % the compiler generated these type_spec pragmas: -% :- pragma type_spec(pred((test_tscp.test)/5), (C = int, D = term.var(V_3))). -% :- pragma type_spec(pred((test_tscp.test)/5), (B = character, C = bool.bool)). +% :- pragma type_spec(pred((test_tscp.p1)/5), (C = int, D = term.var(V_3))). +% :- pragma type_spec(pred((test_tscp.p1)/5), (B = character, C = bool.bool)). +% For the type_spec_constrained_preds pragma at test_tscp.m:66, +% the compiler generated these type_spec pragmas: +% :- pragma type_spec(pred((test_tscp.p2)/3), (Stream = io.text_input_stream, State = io.state, Error = io.error)). +% For the type_spec_constrained_preds pragma at test_tscp.m:74, +% the compiler generated these type_spec pragmas: +% :- pragma type_spec(pred((test_tscp.p2)/3), (Stream = io.text_input_stream, State = io.state, Error = io.error)). +% For the type_spec_constrained_preds pragma at test_tscp.m:100, +% the compiler generated these type_spec pragmas: +% :- pragma type_spec(pred((test_tscp.p3)/2), A = int). +% :- pragma type_spec(pred((test_tscp.p3)/2), B = int). +% :- pragma type_spec(pred((test_tscp.p3)/2), A = float). +% :- pragma type_spec(pred((test_tscp.p3)/2), B = float). diff --git a/tests/warnings/test_tscp.m b/tests/warnings/test_tscp.m index e92644707..e896a2331 100644 --- a/tests/warnings/test_tscp.m +++ b/tests/warnings/test_tscp.m @@ -12,34 +12,98 @@ :- import_module io. :- pred main(io::di, io::uo) is det. +%---------------------------------------------------------------------------% + :- implementation. :- import_module bool. :- import_module char. :- import_module list. :- import_module term. +:- import_module stream. +:- import_module string. +:- import_module string.builder. -main(!IO) :- - test(41, 42, 43, 44, N), - io.write_int(N, !IO), - io.nl(!IO). +%---------------------------------------------------------------------------% :- typeclass tc1(E, F, G, H) <= (tc2(E, int, H), tc4(float, G)) where []. :- typeclass tc2(K, L, M) <= (tc3(K, L), tc3(L, M)) where []. :- typeclass tc3(P, Q) where []. :- typeclass tc4(S, T) where []. +:- typeclass tc5(S) where []. :- instance tc1(int, int, int, int) where []. :- instance tc2(int, int, int) where []. :- instance tc3(int, int) where []. :- instance tc4(float, int) where []. +:- instance tc5(int) where []. +:- instance tc5(float) where []. + +%---------------------------------------------------------------------------% + +main(!IO) :- + p1(41, 42, 43, 44, N), + io.write_int(N, !IO), + io.nl(!IO), + + io.input_stream(InputStream, !IO), + p2({InputStream, 'a', make_io_error("xyzzy")}, !IO). + +%---------------------------------------------------------------------------% :- pragma type_spec_constrained_preds( [tc1(X1, X2, X3, X4)], apply_to_superclasses, [subst([X2 = char, X3 = bool]), - subst([X3 = int, X4 = var(Y)])]). + subst([X3 = int, X4 = var(_)])]). -:- pred test(A::in, B::in, C::in, D::in, D::out) is det <= tc1(A, B, C, D). +:- pred p1(A::in, B::in, C::in, D::in, D::out) is det <= tc1(A, B, C, D). -test(_A, _B, _C, !D). +p1(_A, _B, _C, !D). + +%---------------------------------------------------------------------------% + +:- pragma type_spec_constrained_preds( + [stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, char, State, Error)], + apply_to_superclasses, + [subst([Stream = io.text_input_stream, + State = io.state, Error = io.error])]). + +:- pragma type_spec_constrained_preds( + [stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.unboxed_reader(Stream, string, State, Error)], + apply_to_superclasses, + [subst([Stream = io.text_input_stream, + State = io.state, Error = io.error])]). + +:- pred p2({Stream, Unit, Error}::in, State::di, State::uo) is det + <= (stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, Unit, State, Error)). + +p2({_Stream, _Unit, _Errors}, !State). + +%---------------------------------------------------------------------------% + + % For now, we get only non-composed type_spec pragmas: + % + % :- pragma type_spec(pred((test_tscp.p3)/2), A = int). + % :- pragma type_spec(pred((test_tscp.p3)/2), B = int). + % :- pragma type_spec(pred((test_tscp.p3)/2), A = float). + % :- pragma type_spec(pred((test_tscp.p3)/2), B = float). + % + % We don't (yet) get any type_specs that specialize *both* type vars + % at the same time. +:- pragma type_spec_constrained_preds( + [tc5(X)], + do_not_apply_to_superclasses, + [subst([X => int]), subst([X => float])]). + +:- pred p3({A, B}::in, {B, A}::out) is det <= (tc5(A), tc5(B)). + +p3({A, B}, {B, A}). + +%---------------------------------------------------------------------------% diff --git a/vim/syntax/mercury.vim b/vim/syntax/mercury.vim index aa0a78770..affd1b9ce 100644 --- a/vim/syntax/mercury.vim +++ b/vim/syntax/mercury.vim @@ -100,6 +100,7 @@ syn keyword mercuryPragma promise_equivalent_clauses syn keyword mercuryPragma source_file syn keyword mercuryPragma terminates syn keyword mercuryPragma type_spec +syn keyword mercuryPragma type_spec_constrained_preds syn keyword mercuryCInterface foreign_code syn keyword mercuryCInterface foreign_decl