%-----------------------------------------------------------------------------% % Copyright (C) 1994-2001 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% % File: type_util.m. % Main author: fjh. % This file provides some utility predicates which operate on types. % It is used by various stages of the compilation after type-checking, % include the mode checker and the code generator. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- module type_util. :- interface. :- import_module hlds_module, hlds_pred, hlds_data, prog_data, globals. :- import_module term. :- import_module std_util, list, map. %-----------------------------------------------------------------------------% % Succeed iff type is an "atomic" type - one which can be % unified using a simple_test rather than a complicated_unify. :- pred type_is_atomic(type, module_info). :- mode type_is_atomic(in, in) is semidet. :- pred type_id_is_atomic(type_id, module_info). :- mode type_id_is_atomic(in, in) is semidet. % type_is_higher_order(Type, PredOrFunc, ArgTypes) succeeds iff % Type is a higher-order predicate or function type with the specified % argument types (for functions, the return type is appended to the % end of the argument types). :- pred type_is_higher_order(type, pred_or_func, lambda_eval_method, list(type)). :- mode type_is_higher_order(in, out, out, out) is semidet. % Succeed if the given type is a tuple type, returning % the argument types. :- pred type_is_tuple(type, list(type)). :- mode type_is_tuple(in, out) is semidet. % type_id_is_higher_order(TypeId, PredOrFunc) succeeds iff % TypeId is a higher-order predicate or function type. :- pred type_id_is_higher_order(type_id, pred_or_func, lambda_eval_method). :- mode type_id_is_higher_order(in, out, out) is semidet. % type_id_is_tuple(TypeId) succeeds iff TypeId is a tuple type. :- pred type_id_is_tuple(type_id). :- mode type_id_is_tuple(in) is semidet. % return true iff there was a `where equality is ' % declaration for the specified type, and return the name of % the equality predicate and the context of the type declaration. :- pred type_has_user_defined_equality_pred(module_info, (type), sym_name). :- mode type_has_user_defined_equality_pred(in, in, out) is semidet. % Certain types, e.g. io__state and store__store(S), % are just dummy types used to ensure logical semantics; % there is no need to actually pass them, and so when % importing or exporting procedures to/from C, we don't % include arguments with these types. :- pred type_util__is_dummy_argument_type(type). :- mode type_util__is_dummy_argument_type(in) is semidet. :- pred type_util__constructors_are_dummy_argument_type(list(constructor)). :- mode type_util__constructors_are_dummy_argument_type(in) is semidet. :- pred type_is_io_state(type). :- mode type_is_io_state(in) is semidet. :- pred type_is_aditi_state(type). :- mode type_is_aditi_state(in) is semidet. :- pred type_id_is_array(type_id). :- mode type_id_is_array(in) is semidet. % Remove an `aditi:state' from the given list if one is present. :- pred type_util__remove_aditi_state(list(type), list(T), list(T)). :- mode type_util__remove_aditi_state(in, in, out) is det. % A test for types that are defined in Mercury, but whose definitions % are `lies', i.e. they are not sufficiently accurate for RTTI % structures describing the types. Since the RTTI will be hand defined, % the compiler shouldn't generate RTTI for these types. :- pred type_id_has_hand_defined_rtti(type_id). :- mode type_id_has_hand_defined_rtti(in) is semidet. % A test for type_info-related types that are introduced by % polymorphism.m. Mode inference never infers unique modes % for these types, since it would not be useful, and since we % want to minimize the number of different modes that we infer. :- pred is_introduced_type_info_type(type). :- mode is_introduced_type_info_type(in) is semidet. % In the forwards mode, this predicate checks for a "new " prefix % at the start of the functor name, and removes it if present; % it fails if there is no such prefix. % In the reverse mode, this predicate prepends such a prefix. % (These prefixes are used for construction unifications % with existentially typed functors.) :- pred remove_new_prefix(sym_name, sym_name). :- mode remove_new_prefix(in, out) is semidet. :- mode remove_new_prefix(out, in) is det. % Given a type, determine what sort of type it is. :- pred classify_type(type, module_info, builtin_type). :- mode classify_type(in, in, out) is det. % Given a type_id, determine what sort of type it is. :- pred classify_type_id(module_info, type_id, builtin_type). :- mode classify_type_id(in, in, out) is det. :- type builtin_type ---> int_type ; char_type ; str_type ; float_type ; pred_type ; tuple_type ; enum_type ; polymorphic_type ; user_type. % Given a non-variable type, return its type-id and argument types. :- pred type_to_type_id(type, type_id, list(type)). :- mode type_to_type_id(in, out, out) is semidet. % Given a variable type, return its type variable. :- pred type_util__var(type, tvar). :- mode type_util__var(in, out) is semidet. :- mode type_util__var(out, in) is det. % Given a type_id and a list of argument types, % construct a type. :- pred construct_type(type_id, list(type), (type)). :- mode construct_type(in, in, out) is det. :- pred construct_higher_order_type(pred_or_func, lambda_eval_method, list(type), (type)). :- mode construct_higher_order_type(in, in, in, out) is det. :- pred construct_higher_order_pred_type(lambda_eval_method, list(type), (type)). :- mode construct_higher_order_pred_type(in, in, out) is det. :- pred construct_higher_order_func_type(lambda_eval_method, list(type), (type), (type)). :- mode construct_higher_order_func_type(in, in, in, out) is det. % Construct builtin types. :- func int_type = (type). :- func string_type = (type). :- func float_type = (type). :- func char_type = (type). :- func c_pointer_type = (type). % Given a constant and an arity, return a type_id. % Fails if the constant is not an atom. :- pred make_type_id(const, int, type_id). :- mode make_type_id(in, in, out) is semidet. % Given a type_id, look up its module/name/arity :- pred type_util__type_id_module(module_info, type_id, module_name). :- mode type_util__type_id_module(in, in, out) is det. :- pred type_util__type_id_name(module_info, type_id, string). :- mode type_util__type_id_name(in, in, out) is det. :- pred type_util__type_id_arity(module_info, type_id, arity). :- mode type_util__type_id_arity(in, in, out) is det. % If the type is a du type or a tuple type, % return the list of its constructors. :- pred type_constructors(type, module_info, list(constructor)). :- mode type_constructors(in, in, out) is semidet. % Given a type on which it is possible to have a complete switch, % return the number of alternatives. (It is possible to have a complete % switch on any du type and on the builtin type character. It is not % feasible to have a complete switch on the builtin types integer, % float, and switch. One cannot have a switch on an abstract type, % and equivalence types will have been expanded out by the time % we consider switches.) :- pred type_util__switch_type_num_functors(module_info::in, (type)::in, int::out) is semidet. % Work out the types of the arguments of a functor. % Aborts if the functor is existentially typed. % The cons_id is expected to be un-module-qualified. :- pred type_util__get_cons_id_arg_types(module_info::in, (type)::in, cons_id::in, list(type)::out) is det. % The same as type_util__get_cons_id_arg_types except that it % fails rather than aborting if the functor is existentially % typed. % The cons_id is expected to be un-module-qualified. :- pred type_util__get_cons_id_non_existential_arg_types(module_info::in, (type)::in, cons_id::in, list(type)::out) is semidet. % The same as type_util__get_cons_id_arg_types except that the % cons_id is output non-deterministically. % The cons_id is not module-qualified. :- pred type_util__cons_id_arg_types(module_info::in, (type)::in, cons_id::out, list(type)::out) is nondet. % Given a type and a cons_id, look up the definitions of that % type and constructor. Aborts if the cons_id is not user-defined. :- pred type_util__get_type_and_cons_defn(module_info, (type), cons_id, hlds_type_defn, hlds_cons_defn). :- mode type_util__get_type_and_cons_defn(in, in, in, out, out) is det. % Given a type and a cons_id, look up the definition of that % constructor; if it is existentially typed, return its definition, % otherwise fail. :- pred type_util__get_existq_cons_defn(module_info::in, (type)::in, cons_id::in, ctor_defn::out) is semidet. :- pred type_util__is_existq_cons(module_info::in, (type)::in, cons_id::in) is semidet. % This type is used to return information about a constructor % definition, extracted from the hlds_type_defn and hlds_cons_defn % data types. :- type ctor_defn ---> ctor_defn( tvarset, existq_tvars, list(class_constraint), % existential constraints list(type), % functor argument types (type) % functor result type ). % Check whether a type is a no_tag type % (i.e. one with only one constructor, and % whose one constructor has only one argument, % and which is not private_builtin:type_info/1), % and if so, return its constructor symbol and argument type. :- pred type_is_no_tag_type(module_info, type, sym_name, type). :- mode type_is_no_tag_type(in, in, out, out) is semidet. % Check whether some constructors are a no_tag type % (i.e. one with only one constructor, and % whose one constructor has only one argument, % and which is not private_builtin:type_info/1), % and if so, return its constructor symbol, argument type, % and the argument's name (if it has one). % % This doesn't do any checks for options that might be set % (such as turning off no_tag_types). If you want those checks % you should use type_is_no_tag_type/4, or if you really know % what you are doing, perform the checks yourself. :- pred type_constructors_are_no_tag_type(list(constructor), sym_name, type, maybe(string)). :- mode type_constructors_are_no_tag_type(in, out, out, out) is semidet. % Given a list of constructors for a type, check whether that % type is a private_builtin:type_info/n or similar type. :- pred type_constructors_are_type_info(list(constructor)). :- mode type_constructors_are_type_info(in) is semidet. % Check whether some constructors are a no_tag type, and that this % is compatible with the grade options set in the globals. :- pred type_constructors_should_be_no_tag(list(constructor), globals, sym_name, type, maybe(string)). :- mode type_constructors_should_be_no_tag(in, in, out, out, out) is semidet. % Unify (with occurs check) two types with respect to a type % substitution and update the type bindings. % The third argument is a list of type variables which cannot % be bound (i.e. head type variables). :- pred type_unify(type, type, list(tvar), tsubst, tsubst). :- mode type_unify(in, in, in, in, out) is semidet. :- pred type_unify_list(list(type), list(type), list(tvar), tsubst, tsubst). :- mode type_unify_list(in, in, in, in, out) is semidet. % Return a list of the type variables of a type. :- pred type_util__vars(type, list(tvar)). :- mode type_util__vars(in, out) is det. % Return a list of the type variables of a type, % ignoring any type variables if the variable in % question is a type-info :- pred type_util__real_vars(type, list(tvar)). :- mode type_util__real_vars(in, out) is det. % type_list_subsumes(TypesA, TypesB, Subst) succeeds iff the list % TypesA subsumes (is more general than) TypesB, producing a % type substitution which when applied to TypesA will give TypesB. :- pred type_list_subsumes(list(type), list(type), tsubst). :- mode type_list_subsumes(in, in, out) is semidet. % arg_type_list_subsumes(TVarSet, ArgTypes, % CalleeTVarSet, CalleeExistQVars, CalleeArgTypes). % % Check that the argument types of the called predicate, % function or constructor subsume the types of the % arguments of the call. This checks that none % of the existentially quantified type variables of % the callee are bound. :- pred arg_type_list_subsumes(tvarset, list(type), tvarset, existq_tvars, list(type)). :- mode arg_type_list_subsumes(in, in, in, in, in) is semidet. % apply a type substitution (i.e. map from tvar -> type) % to all the types in a variable typing (i.e. map from var -> type). :- pred apply_substitution_to_type_map(map(prog_var, type), tsubst, map(prog_var, type)). :- mode apply_substitution_to_type_map(in, in, out) is det. % same thing as above, except for a recursive substitution % (i.e. we keep applying the substitution recursively until % there are no more changes). :- pred apply_rec_substitution_to_type_map(map(prog_var, type), tsubst, map(prog_var, type)). :- mode apply_rec_substitution_to_type_map(in, in, out) is det. % Update a map from tvar to type_info_locn, using the type renaming % and substitution to rename tvars and a variable substitution to % rename vars. The type renaming is applied before the type % substitution. % % If tvar maps to a another type variable, we keep the new % variable, if it maps to a type, we remove it from the map. :- pred apply_substitutions_to_var_map(map(tvar, type_info_locn), tsubst, map(tvar, type), map(prog_var, prog_var), map(tvar, type_info_locn)). :- mode apply_substitutions_to_var_map(in, in, in, in, out) is det. % Update a map from class_constraint to var, using the type renaming % and substitution to rename tvars and a variable substition to % rename vars. The type renaming is applied before the type % substitution. :- pred apply_substitutions_to_typeclass_var_map( map(class_constraint, prog_var), tsubst, map(tvar, type), map(prog_var, prog_var), map(class_constraint, prog_var)). :- mode apply_substitutions_to_typeclass_var_map(in, in, in, in, out) is det. :- pred apply_rec_subst_to_constraints(tsubst, class_constraints, class_constraints). :- mode apply_rec_subst_to_constraints(in, in, out) is det. :- pred apply_rec_subst_to_constraint_list(tsubst, list(class_constraint), list(class_constraint)). :- mode apply_rec_subst_to_constraint_list(in, in, out) is det. :- pred apply_rec_subst_to_constraint(tsubst, class_constraint, class_constraint). :- mode apply_rec_subst_to_constraint(in, in, out) is det. :- pred apply_subst_to_constraints(tsubst, class_constraints, class_constraints). :- mode apply_subst_to_constraints(in, in, out) is det. :- pred apply_subst_to_constraint_list(tsubst, list(class_constraint), list(class_constraint)). :- mode apply_subst_to_constraint_list(in, in, out) is det. :- pred apply_subst_to_constraint(tsubst, class_constraint, class_constraint). :- mode apply_subst_to_constraint(in, in, out) is det. :- pred apply_subst_to_constraint_proofs(tsubst, map(class_constraint, constraint_proof), map(class_constraint, constraint_proof)). :- mode apply_subst_to_constraint_proofs(in, in, out) is det. :- pred apply_rec_subst_to_constraint_proofs(tsubst, map(class_constraint, constraint_proof), map(class_constraint, constraint_proof)). :- mode apply_rec_subst_to_constraint_proofs(in, in, out) is det. :- pred apply_variable_renaming_to_type_map(map(tvar, tvar), vartypes, vartypes). :- mode apply_variable_renaming_to_type_map(in, in, out) is det. :- pred apply_variable_renaming_to_constraints(map(tvar, tvar), class_constraints, class_constraints). :- mode apply_variable_renaming_to_constraints(in, in, out) is det. :- pred apply_variable_renaming_to_constraint_list(map(tvar, tvar), list(class_constraint), list(class_constraint)). :- mode apply_variable_renaming_to_constraint_list(in, in, out) is det. :- pred apply_variable_renaming_to_constraint(map(tvar, tvar), class_constraint, class_constraint). :- mode apply_variable_renaming_to_constraint(in, in, out) is det. % Apply a renaming (partial map) to a list. % Useful for applying a variable renaming to a list of variables. :- pred apply_partial_map_to_list(list(T), map(T, T), list(T)). :- mode apply_partial_map_to_list(in, in, out) is det. % cons_id_adjusted_arity(ModuleInfo, Type, ConsId): % Returns the number of arguments of specified constructor id, % adjusted to include the extra typeclassinfo and typeinfo % arguments inserted by polymorphism.m for existentially % typed constructors. % :- func cons_id_adjusted_arity(module_info, type, cons_id) = int. % constraint_list_get_tvars(Constraints, TVars): % return the list of type variables contained in a % list of constraints % :- pred constraint_list_get_tvars(list(class_constraint), list(tvar)). :- mode constraint_list_get_tvars(in, out) is det. % constraint_list_get_tvars(Constraint, TVars): % return the list of type variables contained in a constraint. :- pred constraint_get_tvars(class_constraint, list(tvar)). :- mode constraint_get_tvars(in, out) is det. :- pred get_unconstrained_tvars(list(tvar), list(class_constraint), list(tvar)). :- mode get_unconstrained_tvars(in, in, out) is det. %-----------------------------------------------------------------------------% % If possible, get the argument types for the cons_id. % We need to pass in the arity rather than using the arity % from the cons_id because the arity in the cons_id will not % include any extra type_info arguments for existentially % quantified types. :- pred maybe_get_cons_id_arg_types(module_info, maybe(type), cons_id, arity, list(maybe(type))). :- mode maybe_get_cons_id_arg_types(in, in, in, in, out) is det. :- pred maybe_get_higher_order_arg_types(maybe(type), arity, list(maybe(type))). :- mode maybe_get_higher_order_arg_types(in, in, out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module prog_io, prog_io_goal, prog_util, options, globals. :- import_module bool, char, int, string. :- import_module assoc_list, require, varset. type_util__type_id_module(_ModuleInfo, TypeName - _Arity, ModuleName) :- sym_name_get_module_name(TypeName, unqualified(""), ModuleName). type_util__type_id_name(_ModuleInfo, Name0 - _Arity, Name) :- unqualify_name(Name0, Name). type_util__type_id_arity(_ModuleInfo, _Name - Arity, Arity). type_is_atomic(Type, ModuleInfo) :- type_to_type_id(Type, TypeId, _), type_id_is_atomic(TypeId, ModuleInfo). type_id_is_atomic(TypeId, ModuleInfo) :- classify_type_id(ModuleInfo, TypeId, BuiltinType), BuiltinType \= polymorphic_type, BuiltinType \= tuple_type, BuiltinType \= pred_type, BuiltinType \= user_type. type_id_is_array(qualified(unqualified("array"), "array") - 1). type_util__var(term__variable(Var), Var). type_id_has_hand_defined_rtti(qualified(PB, "type_info") - 1) :- mercury_private_builtin_module(PB). type_id_has_hand_defined_rtti(qualified(PB, "type_ctor_info") - 1) :- mercury_private_builtin_module(PB). type_id_has_hand_defined_rtti(qualified(PB, "typeclass_info") - 1) :- mercury_private_builtin_module(PB). type_id_has_hand_defined_rtti(qualified(PB, "base_typeclass_info") - 1) :- mercury_private_builtin_module(PB). is_introduced_type_info_type(Type) :- sym_name_and_args(Type, TypeName, _), TypeName = qualified(PrivateBuiltin, Name), ( Name = "type_info" ; Name = "type_ctor_info" ; Name = "typeclass_info" ; Name = "base_typeclass_info" ), mercury_private_builtin_module(PrivateBuiltin). remove_new_prefix(unqualified(Name0), unqualified(Name)) :- string__append("new ", Name, Name0). remove_new_prefix(qualified(Module, Name0), qualified(Module, Name)) :- string__append("new ", Name, Name0). %-----------------------------------------------------------------------------% % Given a type, determine what sort of type it is. classify_type(VarType, ModuleInfo, Type) :- ( type_to_type_id(VarType, TypeId, _) -> classify_type_id(ModuleInfo, TypeId, Type) ; Type = polymorphic_type ). classify_type_id(ModuleInfo, TypeId, Type) :- ( TypeId = unqualified("character") - 0 -> Type = char_type ; TypeId = unqualified("int") - 0 -> Type = int_type ; TypeId = unqualified("float") - 0 -> Type = float_type ; TypeId = unqualified("string") - 0 -> Type = str_type ; type_id_is_higher_order(TypeId, _, _) -> Type = pred_type ; type_id_is_tuple(TypeId) -> Type = tuple_type ; type_id_is_enumeration(TypeId, ModuleInfo) -> Type = enum_type ; Type = user_type ). type_is_higher_order(Type, PredOrFunc, EvalMethod, PredArgTypes) :- ( Type = term__functor(term__atom("="), [FuncEvalAndArgs, FuncRetType], _) -> get_lambda_eval_method_and_args("func", FuncEvalAndArgs, EvalMethod, FuncArgTypes), list__append(FuncArgTypes, [FuncRetType], PredArgTypes), PredOrFunc = function ; get_lambda_eval_method_and_args("pred", Type, EvalMethod, PredArgTypes), PredOrFunc = predicate ). type_is_tuple(Type, ArgTypes) :- type_to_type_id(Type, TypeId, ArgTypes), type_id_is_tuple(TypeId). % From the type of a lambda expression, work out how it should % be evaluated and extract the argument types. :- pred get_lambda_eval_method_and_args(string, (type), lambda_eval_method, list(type)) is det. :- mode get_lambda_eval_method_and_args(in, in, out, out) is semidet. get_lambda_eval_method_and_args(PorFStr, Type0, EvalMethod, ArgTypes) :- Type0 = term__functor(term__atom(Functor), Args, _), ( Functor = PorFStr -> EvalMethod = normal, ArgTypes = Args ; Args = [Type1], Type1 = term__functor(term__atom(PorFStr), ArgTypes, _), ( Functor = "aditi_bottom_up" -> EvalMethod = (aditi_bottom_up) ; Functor = "aditi_top_down", EvalMethod = (aditi_top_down) ) ). type_id_is_higher_order(SymName - _Arity, PredOrFunc, EvalMethod) :- ( SymName = qualified(unqualified(EvalMethodStr), PorFStr), ( EvalMethodStr = "aditi_bottom_up", EvalMethod = (aditi_bottom_up) ; EvalMethodStr = "aditi_top_down", EvalMethod = (aditi_top_down) ) ; SymName = unqualified(PorFStr), EvalMethod = normal ), ( PorFStr = "pred", PredOrFunc = predicate ; PorFStr = "func", PredOrFunc = function ). type_id_is_tuple(unqualified("{}") - _). type_has_user_defined_equality_pred(ModuleInfo, Type, SymName) :- module_info_types(ModuleInfo, TypeTable), type_to_type_id(Type, TypeId, _TypeArgs), map__search(TypeTable, TypeId, TypeDefn), hlds_data__get_type_defn_body(TypeDefn, TypeBody), TypeBody = du_type(_, _, _, yes(SymName)). % Certain types, e.g. io__state and store__store(S), % are just dummy types used to ensure logical semantics; % there is no need to actually pass them, and so when % importing or exporting procedures to/from C, we don't % include arguments with these types. type_util__is_dummy_argument_type(Type) :- Type = term__functor(term__atom(":"), [ term__functor(term__atom(ModuleName), [], _), term__functor(term__atom(TypeName), TypeArgs, _) ], _), list__length(TypeArgs, TypeArity), type_util__is_dummy_argument_type_2(ModuleName, TypeName, TypeArity). :- pred type_util__is_dummy_argument_type_2(string::in, string::in, arity::in) is semidet. % XXX should we include aditi:state/0 in this list? type_util__is_dummy_argument_type_2("io", "state", 0). % io:state/0 type_util__is_dummy_argument_type_2("store", "store", 1). % store:store/1. type_util__constructors_are_dummy_argument_type([Ctor]) :- Ctor = ctor([], [], qualified(unqualified("io"), "state"), [_]). type_util__constructors_are_dummy_argument_type([Ctor]) :- Ctor = ctor([], [], qualified(unqualified("store"), "store"), [_]). type_is_io_state(Type) :- type_to_type_id(Type, qualified(unqualified("io"), "state") - 0, []). type_is_aditi_state(Type) :- type_to_type_id(Type, qualified(unqualified("aditi"), "state") - 0, []). type_util__remove_aditi_state([], [], []). type_util__remove_aditi_state([], [_|_], _) :- error("type_util__remove_aditi_state"). type_util__remove_aditi_state([_|_], [], _) :- error("type_util__remove_aditi_state"). type_util__remove_aditi_state([Type | Types], [Arg | Args0], Args) :- ( type_is_aditi_state(Type) -> type_util__remove_aditi_state(Types, Args0, Args) ; type_util__remove_aditi_state(Types, Args0, Args1), Args = [Arg | Args1] ). :- pred type_id_is_enumeration(type_id, module_info). :- mode type_id_is_enumeration(in, in) is semidet. type_id_is_enumeration(TypeId, ModuleInfo) :- module_info_types(ModuleInfo, TypeDefnTable), map__search(TypeDefnTable, TypeId, TypeDefn), hlds_data__get_type_defn_body(TypeDefn, TypeBody), TypeBody = du_type(_, _, IsEnum, _), IsEnum = yes. type_to_type_id(Type, SymName - Arity, Args) :- Type \= term__variable(_), % higher order types may have representations where % their arguments don't directly correspond to the % arguments of the term. ( type_is_higher_order(Type, PredOrFunc, EvalMethod, PredArgTypes) -> Args = PredArgTypes, list__length(Args, Arity0), adjust_func_arity(PredOrFunc, Arity, Arity0), ( PredOrFunc = predicate, PorFStr = "pred" ; PredOrFunc = function, PorFStr = "func" ), ( EvalMethod = (aditi_bottom_up), SymName = qualified(unqualified("aditi_bottom_up"), PorFStr) ; EvalMethod = (aditi_top_down), SymName = qualified(unqualified("aditi_top_down"), PorFStr) ; EvalMethod = normal, SymName = unqualified(PorFStr) ) ; sym_name_and_args(Type, SymName, Args), % `private_builtin:constraint' is introduced by polymorphism, % and should only appear as the argument of a % `typeclass:info/1' type. % It behaves sort of like a type variable, so according to the % specification of `type_to_type_id', it should cause failure. % There isn't a definition in the type table. \+ ( SymName = qualified(ModuleName, UnqualName), UnqualName = "constraint", mercury_private_builtin_module(PrivateBuiltin), ModuleName = PrivateBuiltin ), list__length(Args, Arity) ). construct_type(TypeId, Args, Type) :- ( type_id_is_higher_order(TypeId, PredOrFunc, EvalMethod) -> construct_higher_order_type(PredOrFunc, EvalMethod, Args, Type) ; TypeId = SymName - _, construct_qualified_term(SymName, Args, Type) ). construct_higher_order_type(PredOrFunc, EvalMethod, ArgTypes, Type) :- ( PredOrFunc = predicate, construct_higher_order_pred_type(EvalMethod, ArgTypes, Type) ; PredOrFunc = function, pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType), construct_higher_order_func_type(EvalMethod, FuncArgTypes, FuncRetType, Type) ). construct_higher_order_pred_type(EvalMethod, ArgTypes, Type) :- construct_qualified_term(unqualified("pred"), ArgTypes, Type0), qualify_higher_order_type(EvalMethod, Type0, Type). construct_higher_order_func_type(EvalMethod, ArgTypes, RetType, Type) :- construct_qualified_term(unqualified("func"), ArgTypes, Type0), qualify_higher_order_type(EvalMethod, Type0, Type1), Type = term__functor(term__atom("="), [Type1, RetType], term__context_init). :- pred qualify_higher_order_type(lambda_eval_method, (type), (type)). :- mode qualify_higher_order_type(in, in, out) is det. qualify_higher_order_type(normal, Type, Type). qualify_higher_order_type((aditi_top_down), Type0, term__functor(term__atom("aditi_top_down"), [Type0], Context)) :- term__context_init(Context). qualify_higher_order_type((aditi_bottom_up), Type0, term__functor(term__atom("aditi_bottom_up"), [Type0], Context)) :- term__context_init(Context). int_type = Type :- construct_type(unqualified("int") - 0, [], Type). string_type = Type :- construct_type(unqualified("string") - 0, [], Type). float_type = Type :- construct_type(unqualified("float") - 0, [], Type). char_type = Type :- construct_type(unqualified("character") - 0, [], Type). c_pointer_type = Type :- mercury_public_builtin_module(BuiltinModule), construct_type(qualified(BuiltinModule, "c_pointer") - 0, [], Type). %-----------------------------------------------------------------------------% % Given a constant and an arity, return a type_id. % This really ought to take a name and an arity - % use of integers/floats/strings as type names should % be rejected by the parser in prog_io.m, not in module_qual.m. make_type_id(term__atom(Name), Arity, unqualified(Name) - Arity). %-----------------------------------------------------------------------------% % If the type is a du type, return the list of its constructors. type_constructors(Type, ModuleInfo, Constructors) :- type_to_type_id(Type, TypeId, TypeArgs), ( type_id_is_tuple(TypeId) -> % Tuples are never existentially typed. ExistQVars = [], ClassConstraints = [], CtorArgs = list__map((func(ArgType) = no - ArgType), TypeArgs), Constructors = [ctor(ExistQVars, ClassConstraints, unqualified("{}"), CtorArgs)] ; module_info_types(ModuleInfo, TypeTable), map__search(TypeTable, TypeId, TypeDefn), hlds_data__get_type_defn_tparams(TypeDefn, TypeParams), hlds_data__get_type_defn_body(TypeDefn, TypeBody), TypeBody = du_type(Constructors0, _, _, _), substitute_type_args(TypeParams, TypeArgs, Constructors0, Constructors) ). %-----------------------------------------------------------------------------% type_util__switch_type_num_functors(ModuleInfo, Type, NumFunctors) :- type_to_type_id(Type, TypeId, _), ( TypeId = unqualified("character") - 0 -> % XXX the following code uses the source machine's character % size, not the target's, so it won't work if cross-compiling % to a machine with a different size character. char__max_char_value(MaxChar), char__min_char_value(MinChar), NumFunctors is MaxChar - MinChar + 1 ; type_id_is_tuple(TypeId) -> NumFunctors = 1 ; module_info_types(ModuleInfo, TypeTable), map__search(TypeTable, TypeId, TypeDefn), hlds_data__get_type_defn_body(TypeDefn, TypeBody), TypeBody = du_type(_, ConsTable, _, _), map__count(ConsTable, NumFunctors) ). %-----------------------------------------------------------------------------% type_util__get_cons_id_arg_types(ModuleInfo, Type, ConsId, ArgTypes) :- type_util__get_cons_id_arg_types_2(abort_on_exist_qvar, ModuleInfo, Type, ConsId, ArgTypes). type_util__get_cons_id_non_existential_arg_types(ModuleInfo, Type, ConsId, ArgTypes) :- type_util__get_cons_id_arg_types_2(fail_on_exist_qvar, ModuleInfo, Type, ConsId, ArgTypes). :- type exist_qvar_action ---> fail_on_exist_qvar ; abort_on_exist_qvar. :- pred type_util__get_cons_id_arg_types_2(exist_qvar_action, module_info, (type), cons_id, list(type)). :- mode type_util__get_cons_id_arg_types_2(in(bound(fail_on_exist_qvar)), in, in, in, out) is semidet. :- mode type_util__get_cons_id_arg_types_2(in(bound(abort_on_exist_qvar)), in, in, in, out) is det. type_util__get_cons_id_arg_types_2(EQVarAction, ModuleInfo, VarType, ConsId, ArgTypes) :- ( type_to_type_id(VarType, TypeId, TypeArgs) -> ( % The argument types of a tuple cons_id are the % arguments of the tuple type. type_id_is_tuple(TypeId) -> ArgTypes = TypeArgs ; type_util__do_get_type_and_cons_defn(ModuleInfo, TypeId, ConsId, TypeDefn, ConsDefn), ConsDefn = hlds_cons_defn(ExistQVars0, _Constraints0, Args, _, _), Args \= [] -> hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams), term__term_list_to_var_list(TypeDefnParams, TypeDefnVars), % XXX handle ExistQVars ( ExistQVars0 = [] -> true ; ( EQVarAction = abort_on_exist_qvar, error("type_util__get_cons_id_arg_types: existentially typed cons_id") ; EQVarAction = fail_on_exist_qvar, fail ) ), map__from_corresponding_lists(TypeDefnVars, TypeArgs, TSubst), assoc_list__values(Args, ArgTypes0), term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes) ; ArgTypes = [] ) ; ArgTypes = [] ). type_util__cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :- type_to_type_id(VarType, TypeId, TypeArgs), module_info_types(ModuleInfo, Types), map__search(Types, TypeId, TypeDefn), hlds_data__get_type_defn_body(TypeDefn, TypeDefnBody), TypeDefnBody = du_type(_, ConsTags, _, _), map__member(ConsTags, ConsId, _), module_info_ctors(ModuleInfo, Ctors), map__lookup(Ctors, ConsId, ConsDefns), list__member(ConsDefn, ConsDefns), ConsDefn = hlds_cons_defn(ExistQVars0, _, Args, TypeId, _), % XXX handle ExistQVars ExistQVars0 = [], hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams), term__term_list_to_var_list(TypeDefnParams, TypeDefnVars), map__from_corresponding_lists(TypeDefnVars, TypeArgs, TSubst), assoc_list__values(Args, ArgTypes0), term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes). type_util__is_existq_cons(ModuleInfo, VarType, ConsId) :- type_util__is_existq_cons(ModuleInfo, VarType, ConsId, _). :- pred type_util__is_existq_cons(module_info::in, (type)::in, cons_id::in, hlds_cons_defn::out) is semidet. type_util__is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn) :- type_to_type_id(VarType, TypeId, _), type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn), ConsDefn = hlds_cons_defn(ExistQVars, _, _, _, _), ExistQVars \= []. % Given a type and a cons_id, look up the definition of that % constructor; if it is existentially typed, return its definition, % otherwise fail. type_util__get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :- type_util__is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn), ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, _, _), assoc_list__values(Args, ArgTypes), module_info_types(ModuleInfo, Types), type_to_type_id(VarType, TypeId, _), map__lookup(Types, TypeId, TypeDefn), hlds_data__get_type_defn_tvarset(TypeDefn, TypeVarSet), hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams), type_to_type_id(VarType, TypeId, _), construct_type(TypeId, TypeDefnParams, RetType), CtorDefn = ctor_defn(TypeVarSet, ExistQVars, Constraints, ArgTypes, RetType). type_util__get_type_and_cons_defn(ModuleInfo, Type, ConsId, TypeDefn, ConsDefn) :- ( type_to_type_id(Type, TypeId, _), type_util__do_get_type_and_cons_defn(ModuleInfo, TypeId, ConsId, TypeDefn0, ConsDefn0) -> TypeDefn = TypeDefn0, ConsDefn = ConsDefn0 ; error("type_util__get_type_and_cons_defn") ). :- pred type_util__do_get_type_and_cons_defn(module_info::in, type_id::in, cons_id::in, hlds_type_defn::out, hlds_cons_defn::out) is semidet. type_util__do_get_type_and_cons_defn(ModuleInfo, TypeId, ConsId, TypeDefn, ConsDefn) :- type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn), module_info_types(ModuleInfo, Types), map__lookup(Types, TypeId, TypeDefn). :- pred type_util__get_cons_defn(module_info::in, type_id::in, cons_id::in, hlds_cons_defn::out) is semidet. type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn) :- module_info_ctors(ModuleInfo, Ctors), % will fail for builtin cons_ids. map__search(Ctors, ConsId, ConsDefns), MatchingCons = lambda([ThisConsDefn::in] is semidet, ( ThisConsDefn = hlds_cons_defn(_, _, _, TypeId, _) )), list__filter(MatchingCons, ConsDefns, [ConsDefn]). %-----------------------------------------------------------------------------% type_is_no_tag_type(ModuleInfo, Type, Ctor, ArgType) :- type_to_type_id(Type, TypeId, TypeArgs), module_info_no_tag_types(ModuleInfo, NoTagTypes), map__search(NoTagTypes, TypeId, NoTagType), NoTagType = no_tag_type(TypeParams0, Ctor, ArgType0), ( TypeParams0 = [] -> ArgType = ArgType0 ; term__term_list_to_var_list(TypeParams0, TypeParams), map__from_corresponding_lists(TypeParams, TypeArgs, Subn), term__apply_substitution(ArgType0, Subn, ArgType) ). % The checks for type_info and type_ctor_info % are needed because those types lie about their % arity; it might be cleaner to change that in % private_builtin.m, but that would cause some % bootstrapping difficulties. % It might be slightly better to check for private_builtin:type_info % etc. rather than just checking the unqualified type name, % but I found it difficult to verify that the constructors % would always be fully module-qualified at points where % type_constructors_are_no_tag_type/3 is called. type_constructors_are_no_tag_type(Ctors, Ctor, ArgType, MaybeArgName) :- type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName0, ArgType), \+ ctor_is_type_info(Ctor), % We don't handle unary tuples as no_tag types -- % they are rare enough that it's not worth % the implementation effort. Ctor \= unqualified("{}"), map_maybe(unqualify_name, MaybeArgName0, MaybeArgName). type_constructors_are_type_info(Ctors) :- type_is_single_ctor_single_arg(Ctors, Ctor, _, _), ctor_is_type_info(Ctor). :- pred ctor_is_type_info(sym_name). :- mode ctor_is_type_info(in) is semidet. ctor_is_type_info(Ctor) :- unqualify_private_builtin(Ctor, Name), name_is_type_info(Name). :- pred name_is_type_info(string). :- mode name_is_type_info(in) is semidet. name_is_type_info("type_info"). name_is_type_info("type_ctor_info"). name_is_type_info("typeclass_info"). name_is_type_info("base_typeclass_info"). % If the sym_name is in the private_builtin module, unqualify it, % otherwise fail. % All, user-defined types should be module-qualified by the % time this predicate is called, so we assume that any % unqualified names are in private_builtin. :- pred unqualify_private_builtin(sym_name, string). :- mode unqualify_private_builtin(in, out) is semidet. unqualify_private_builtin(unqualified(Name), Name). unqualify_private_builtin(qualified(ModuleName, Name), Name) :- mercury_private_builtin_module(ModuleName). :- pred type_is_single_ctor_single_arg(list(constructor), sym_name, maybe(ctor_field_name), type). :- mode type_is_single_ctor_single_arg(in, out, out, out) is semidet. type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName, ArgType) :- Ctors = [SingleCtor], SingleCtor = ctor(ExistQVars, _Constraints, Ctor, [MaybeArgName - ArgType]), ExistQVars = []. %-----------------------------------------------------------------------------% % assign single functor of arity one a `no_tag' tag % (unless it is type_info/1 or we are reserving a tag, % or if it is one of the dummy types) type_constructors_should_be_no_tag(Ctors, Globals, SingleFunc, SingleArg, MaybeArgName) :- type_constructors_are_no_tag_type(Ctors, SingleFunc, SingleArg, MaybeArgName), ( globals__lookup_bool_option(Globals, reserve_tag, no), globals__lookup_bool_option(Globals, unboxed_no_tag_types, yes) ; % Dummy types always need to be treated as no-tag types % as the low-level C back end just passes around % rubbish for them. When eg. using the debugger, it is % crucial that these values are treated as unboxed % c_pointers, not as tagged pointers to c_pointers % (otherwise the system winds up following a bogus % pointer). constructors_are_dummy_argument_type(Ctors) ). %-----------------------------------------------------------------------------% % Substitute the actual values of the type parameters % in list of constructors, for a particular instance of % a polymorphic type. :- pred substitute_type_args(list(type_param), list(type), list(constructor), list(constructor)). :- mode substitute_type_args(in, in, in, out) is det. substitute_type_args(TypeParams0, TypeArgs, Constructors0, Constructors) :- ( TypeParams0 = [] -> Constructors = Constructors0 ; term__term_list_to_var_list(TypeParams0, TypeParams), map__from_corresponding_lists(TypeParams, TypeArgs, Subst), substitute_type_args_2(Constructors0, Subst, Constructors) ). :- pred substitute_type_args_2(list(constructor), tsubst, list(constructor)). :- mode substitute_type_args_2(in, in, out) is det. substitute_type_args_2([], _, []). substitute_type_args_2([Ctor0| Ctors0], Subst, [Ctor | Ctors]) :- % Note: prog_io.m ensures that the existentially quantified % variables, if any, are distinct from the parameters, % and that the (existential) constraints can only contain % existentially quantified variables, so there's % no need to worry about applying the substitution to % ExistQVars or Constraints Ctor0 = ctor(ExistQVars, Constraints, Name, Args0), Ctor = ctor(ExistQVars, Constraints, Name, Args), substitute_type_args_3(Args0, Subst, Args), substitute_type_args_2(Ctors0, Subst, Ctors). :- pred substitute_type_args_3(list(constructor_arg), tsubst, list(constructor_arg)). :- mode substitute_type_args_3(in, in, out) is det. substitute_type_args_3([], _, []). substitute_type_args_3([Name - Arg0 | Args0], Subst, [Name - Arg | Args]) :- term__apply_substitution(Arg0, Subst, Arg), substitute_type_args_3(Args0, Subst, Args). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Check whether TypesA subsumes TypesB, and if so return % a type substitution that will map from TypesA to TypesB. type_list_subsumes(TypesA, TypesB, TypeSubst) :- % % TypesA subsumes TypesB iff TypesA can be unified with TypesB % without binding any of the type variables in TypesB. % term__vars_list(TypesB, TypesBVars), map__init(TypeSubst0), type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst). arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet, CalleeExistQVars0, CalleeArgTypes0) :- % % rename the type variables in the callee's argument types. % varset__merge_subst(TVarSet, CalleeTVarSet, _TVarSet1, Subst), term__apply_substitution_to_list(CalleeArgTypes0, Subst, CalleeArgTypes), map__apply_to_list(CalleeExistQVars0, Subst, CalleeExistQTypes0), % % check that the types of the candidate predicate/function % subsume the actual argument types % [This is the right thing to do even for calls to % existentially typed preds, because we're using the % type variables from the callee's pred decl (obtained % from the pred_info via pred_info_arg_types) not the types % inferred from the callee's clauses (and stored in the % clauses_info and proc_info) -- the latter % might not subsume the actual argument types.] % type_list_subsumes(CalleeArgTypes, ArgTypes, TypeSubst), % % check that the type substitution did not bind any % existentially typed variables to non-ground types % ( CalleeExistQTypes0 = [] -> % optimize common case true ; term__apply_rec_substitution_to_list(CalleeExistQTypes0, TypeSubst, CalleeExistQTypes), all [T] (list__member(T, CalleeExistQTypes) => type_util__var(T, _)) % it might make sense to also check that % the type substitution did not bind any % existentially typed variables to universally % quantified type variables in the caller's % argument types ). %-----------------------------------------------------------------------------% % Types are represented as terms, but we can't just use term__unify % because we need to avoid binding any of the "head type params" % (the type variables that occur in the head of the clause), % and because one day we might want to handle equivalent types. type_unify(term__variable(X), term__variable(Y), HeadTypeParams, Bindings0, Bindings) :- ( list__member(Y, HeadTypeParams) -> type_unify_head_type_param(X, Y, HeadTypeParams, Bindings0, Bindings) ; list__member(X, HeadTypeParams) -> type_unify_head_type_param(Y, X, HeadTypeParams, Bindings0, Bindings) ; map__search(Bindings0, X, BindingOfX) -> ( map__search(Bindings0, Y, BindingOfY) -> % both X and Y already have bindings - just % unify the types they are bound to type_unify(BindingOfX, BindingOfY, HeadTypeParams, Bindings0, Bindings) ; term__apply_rec_substitution(BindingOfX, Bindings0, SubstBindingOfX), % Y is a type variable which hasn't been bound yet ( SubstBindingOfX = term__variable(Y) -> Bindings = Bindings0 ; \+ term__occurs(SubstBindingOfX, Y, Bindings0), map__det_insert(Bindings0, Y, SubstBindingOfX, Bindings) ) ) ; ( map__search(Bindings0, Y, BindingOfY) -> term__apply_rec_substitution(BindingOfY, Bindings0, SubstBindingOfY), % X is a type variable which hasn't been bound yet ( SubstBindingOfY = term__variable(X) -> Bindings = Bindings0 ; \+ term__occurs(SubstBindingOfY, X, Bindings0), map__det_insert(Bindings0, X, SubstBindingOfY, Bindings) ) ; % both X and Y are unbound type variables - % bind one to the other ( X = Y -> Bindings = Bindings0 ; map__det_insert(Bindings0, X, term__variable(Y), Bindings) ) ) ). type_unify(term__variable(X), term__functor(F, As, C), HeadTypeParams, Bindings0, Bindings) :- ( map__search(Bindings0, X, BindingOfX) -> type_unify(BindingOfX, term__functor(F, As, C), HeadTypeParams, Bindings0, Bindings) ; \+ term__occurs_list(As, X, Bindings0), \+ list__member(X, HeadTypeParams), map__det_insert(Bindings0, X, term__functor(F, As, C), Bindings) ). type_unify(term__functor(F, As, C), term__variable(X), HeadTypeParams, Bindings0, Bindings) :- ( map__search(Bindings0, X, BindingOfX) -> type_unify(term__functor(F, As, C), BindingOfX, HeadTypeParams, Bindings0, Bindings) ; \+ term__occurs_list(As, X, Bindings0), \+ list__member(X, HeadTypeParams), map__det_insert(Bindings0, X, term__functor(F, As, C), Bindings) ). type_unify(term__functor(FX, AsX, _CX), term__functor(FY, AsY, _CY), HeadTypeParams, Bindings0, Bindings) :- list__length(AsX, ArityX), list__length(AsY, ArityY), ( FX = FY, ArityX = ArityY -> type_unify_list(AsX, AsY, HeadTypeParams, Bindings0, Bindings) ; fail ). % XXX Instead of just failing if the functors' name/arity is different, % we should check here if these types have been defined % to be equivalent using equivalence types. But this % is difficult because the relevant variable % TypeTable hasn't been passed in to here. /******* ... ; replace_eqv_type(FX, ArityX, AsX, EqvType) -> type_unify(EqvType, term__functor(FY, AsY, CY), HeadTypeParams, Bindings0, Bindings) ; replace_eqv_type(FY, ArityY, AsY, EqvType) -> type_unify(term__functor(FX, AsX, CX), EqvType, HeadTypeParams, Bindings0, Bindings) ; fail ). :- pred replace_eqv_type(const, int, list(type), type). :- mode replace_eqv_type(in, in, in, out) is semidet. replace_eqv_type(Functor, Arity, Args, EqvType) :- % XXX magically_obtain(TypeTable) make_type_id(Functor, Arity, TypeId), map__search(TypeTable, TypeId, TypeDefn), get_type_defn_body(TypeDefn, TypeBody), TypeBody = eqv_type(EqvType0), get_type_defn_tparams(TypeDefn, TypeParams0), type_param_to_var_list(TypeParams0, TypeParams), term__substitute_corresponding(EqvType0, TypeParams, AsX, EqvType). ******/ type_unify_list([], [], _) --> []. type_unify_list([X | Xs], [Y | Ys], HeadTypeParams) --> type_unify(X, Y, HeadTypeParams), type_unify_list(Xs, Ys, HeadTypeParams). :- pred type_unify_head_type_param(tvar, tvar, list(tvar), tsubst, tsubst). :- mode type_unify_head_type_param(in, in, in, in, out) is semidet. type_unify_head_type_param(Var, HeadVar, HeadTypeParams, Bindings0, Bindings) :- ( map__search(Bindings0, Var, BindingOfVar) -> BindingOfVar = term__variable(Var2), type_unify_head_type_param(Var2, HeadVar, HeadTypeParams, Bindings0, Bindings) ; ( Var = HeadVar -> Bindings = Bindings0 ; \+ list__member(Var, HeadTypeParams), map__det_insert(Bindings0, Var, term__variable(HeadVar), Bindings) ) ). %-----------------------------------------------------------------------------% type_util__vars(Type, Tvars) :- term__vars(Type, Tvars). type_util__real_vars(Type, Tvars) :- ( is_introduced_type_info_type(Type) -> % for these types, we don't add the type parameters Tvars = [] ; type_util__vars(Type, Tvars) ). %-----------------------------------------------------------------------------% apply_substitution_to_type_map(VarTypes0, Subst, VarTypes) :- % optimize the common case of an empty type substitution ( map__is_empty(Subst) -> VarTypes = VarTypes0 ; map__keys(VarTypes0, Vars), apply_substitution_to_type_map_2(Vars, VarTypes0, Subst, VarTypes) ). :- pred apply_substitution_to_type_map_2(list(prog_var)::in, map(prog_var, type)::in, tsubst::in, map(prog_var, type)::out) is det. apply_substitution_to_type_map_2([], VarTypes, _Subst, VarTypes). apply_substitution_to_type_map_2([Var | Vars], VarTypes0, Subst, VarTypes) :- map__lookup(VarTypes0, Var, VarType0), term__apply_substitution(VarType0, Subst, VarType), map__det_update(VarTypes0, Var, VarType, VarTypes1), apply_substitution_to_type_map_2(Vars, VarTypes1, Subst, VarTypes). %-----------------------------------------------------------------------------% apply_rec_substitution_to_type_map(VarTypes0, Subst, VarTypes) :- % optimize the common case of an empty type substitution ( map__is_empty(Subst) -> VarTypes = VarTypes0 ; map__keys(VarTypes0, Vars), apply_rec_substitution_to_type_map_2(Vars, VarTypes0, Subst, VarTypes) ). :- pred apply_rec_substitution_to_type_map_2(list(prog_var)::in, map(prog_var, type)::in, tsubst::in, map(prog_var, type)::out) is det. apply_rec_substitution_to_type_map_2([], VarTypes, _Subst, VarTypes). apply_rec_substitution_to_type_map_2([Var | Vars], VarTypes0, Subst, VarTypes) :- map__lookup(VarTypes0, Var, VarType0), term__apply_rec_substitution(VarType0, Subst, VarType), map__det_update(VarTypes0, Var, VarType, VarTypes1), apply_rec_substitution_to_type_map_2(Vars, VarTypes1, Subst, VarTypes). %-----------------------------------------------------------------------------% apply_substitutions_to_var_map(VarMap0, TRenaming, TSubst, Subst, VarMap) :- % optimize the common case of empty substitutions ( map__is_empty(Subst), map__is_empty(TSubst), map__is_empty(TRenaming) -> VarMap = VarMap0 ; map__keys(VarMap0, TVars), map__init(NewVarMap), apply_substitutions_to_var_map_2(TVars, VarMap0, TRenaming, TSubst, Subst, NewVarMap, VarMap) ). :- pred apply_substitutions_to_var_map_2(list(tvar)::in, map(tvar, type_info_locn)::in, tsubst::in, map(tvar, type)::in, map(prog_var, prog_var)::in, map(tvar, type_info_locn)::in, map(tvar, type_info_locn)::out) is det. apply_substitutions_to_var_map_2([], _VarMap0, _, _, _, NewVarMap, NewVarMap). apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TRenaming, TSubst, VarSubst, NewVarMap0, NewVarMap) :- map__lookup(VarMap0, TVar, Locn), type_info_locn_var(Locn, Var), % find the new var, if there is one ( map__search(VarSubst, Var, NewVar0) -> NewVar = NewVar0 ; NewVar = Var ), type_info_locn_set_var(Locn, NewVar, NewLocn), % find the new tvar, if there is one, otherwise just % create the old var as a type variable. ( map__search(TRenaming, TVar, NewTVar0) -> ( NewTVar0 = term__variable(NewTVar1) -> NewTVar2 = NewTVar1 ; % varset__merge_subst only returns var->var mappings, % never var->term. error( "apply_substitution_to_var_map_2: weird type renaming") ) ; % The variable wasn't renamed. NewTVar2 = TVar ), term__apply_rec_substitution(term__variable(NewTVar2), TSubst, NewType), % if the tvar is still a variable, insert it into the % map with the new var. ( type_util__var(NewType, NewTVar) -> % Don't abort if two old type variables % map to the same new type variable. map__set(NewVarMap0, NewTVar, NewLocn, NewVarMap1) ; NewVarMap1 = NewVarMap0 ), apply_substitutions_to_var_map_2(TVars, VarMap0, TRenaming, TSubst, VarSubst, NewVarMap1, NewVarMap). %-----------------------------------------------------------------------------% apply_substitutions_to_typeclass_var_map(VarMap0, TRenaming, TSubst, Subst, VarMap) :- map__to_assoc_list(VarMap0, VarAL0), list__map(apply_substitutions_to_typeclass_var_map_2(TRenaming, TSubst, Subst), VarAL0, VarAL), map__from_assoc_list(VarAL, VarMap). :- pred apply_substitutions_to_typeclass_var_map_2(tsubst, map(tvar, type), map(prog_var, prog_var), pair(class_constraint, prog_var), pair(class_constraint, prog_var)). :- mode apply_substitutions_to_typeclass_var_map_2(in, in, in, in, out) is det. apply_substitutions_to_typeclass_var_map_2(TRenaming, TSubst, VarRenaming, Constraint0 - Var0, Constraint - Var) :- apply_subst_to_constraint(TRenaming, Constraint0, Constraint1), apply_rec_subst_to_constraint(TSubst, Constraint1, Constraint), ( map__search(VarRenaming, Var0, Var1) -> Var = Var1 ; Var = Var0 ). %-----------------------------------------------------------------------------% apply_rec_subst_to_constraints(Subst, Constraints0, Constraints) :- Constraints0 = constraints(UnivCs0, ExistCs0), apply_rec_subst_to_constraint_list(Subst, UnivCs0, UnivCs), apply_rec_subst_to_constraint_list(Subst, ExistCs0, ExistCs), Constraints = constraints(UnivCs, ExistCs). apply_rec_subst_to_constraint_list(Subst, Constraints0, Constraints) :- list__map(apply_rec_subst_to_constraint(Subst), Constraints0, Constraints). apply_rec_subst_to_constraint(Subst, Constraint0, Constraint) :- Constraint0 = constraint(ClassName, Types0), term__apply_rec_substitution_to_list(Types0, Subst, Types), Constraint = constraint(ClassName, Types). apply_subst_to_constraints(Subst, constraints(UniversalCs0, ExistentialCs0), constraints(UniversalCs, ExistentialCs)) :- apply_subst_to_constraint_list(Subst, UniversalCs0, UniversalCs), apply_subst_to_constraint_list(Subst, ExistentialCs0, ExistentialCs). apply_subst_to_constraint_list(Subst, Constraints0, Constraints) :- list__map(apply_subst_to_constraint(Subst), Constraints0, Constraints). apply_subst_to_constraint(Subst, Constraint0, Constraint) :- Constraint0 = constraint(ClassName, Types0), term__apply_substitution_to_list(Types0, Subst, Types), Constraint = constraint(ClassName, Types). apply_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :- map__init(Empty), map__foldl( lambda([Constraint0::in, Proof0::in, Map0::in, Map::out] is det, ( apply_subst_to_constraint(Subst, Constraint0, Constraint), ( Proof0 = apply_instance(_), Proof = Proof0 ; Proof0 = superclass(Super0), apply_subst_to_constraint(Subst, Super0, Super), Proof = superclass(Super) ), map__set(Map0, Constraint, Proof, Map) )), Proofs0, Empty, Proofs). apply_rec_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :- map__init(Empty), map__foldl( lambda([Constraint0::in, Proof0::in, Map0::in, Map::out] is det, ( apply_rec_subst_to_constraint(Subst, Constraint0, Constraint), ( Proof0 = apply_instance(_), Proof = Proof0 ; Proof0 = superclass(Super0), apply_rec_subst_to_constraint(Subst, Super0, Super), Proof = superclass(Super) ), map__set(Map0, Constraint, Proof, Map) )), Proofs0, Empty, Proofs). apply_variable_renaming_to_type_map(Renaming, Map0, Map) :- map__map_values( (pred(_::in, Type0::in, Type::out) is det :- term__apply_variable_renaming(Type0, Renaming, Type) ), Map0, Map). apply_variable_renaming_to_constraints(Renaming, constraints(UniversalCs0, ExistentialCs0), constraints(UniversalCs, ExistentialCs)) :- apply_variable_renaming_to_constraint_list(Renaming, UniversalCs0, UniversalCs), apply_variable_renaming_to_constraint_list(Renaming, ExistentialCs0, ExistentialCs). apply_variable_renaming_to_constraint_list(Renaming, Constraints0, Constraints) :- list__map(apply_variable_renaming_to_constraint(Renaming), Constraints0, Constraints). apply_variable_renaming_to_constraint(Renaming, Constraint0, Constraint) :- Constraint0 = constraint(ClassName, ClassArgTypes0), term__apply_variable_renaming_to_list(ClassArgTypes0, Renaming, ClassArgTypes), Constraint = constraint(ClassName, ClassArgTypes). %-----------------------------------------------------------------------------% apply_partial_map_to_list([], _PartialMap, []). apply_partial_map_to_list([X|Xs], PartialMap, [Y|Ys]) :- ( map__search(PartialMap, X, Y0) -> Y = Y0 ; Y = X ), apply_partial_map_to_list(Xs, PartialMap, Ys). %-----------------------------------------------------------------------------% cons_id_adjusted_arity(ModuleInfo, Type, ConsId) = AdjustedArity :- % figure out the arity of this constructor, % _including_ any type-infos or typeclass-infos % inserted for existential data types. cons_id_arity(ConsId, ConsArity), ( type_util__get_existq_cons_defn(ModuleInfo, Type, ConsId, ConsDefn) -> ConsDefn = ctor_defn(_TVarSet, ExistQTVars, Constraints, _ArgTypes, _ResultType), list__length(Constraints, NumTypeClassInfos), constraint_list_get_tvars(Constraints, ConstrainedTVars), list__delete_elems(ExistQTVars, ConstrainedTVars, UnconstrainedExistQTVars), list__length(UnconstrainedExistQTVars, NumTypeInfos), AdjustedArity = ConsArity + NumTypeClassInfos + NumTypeInfos ; AdjustedArity = ConsArity ). %-----------------------------------------------------------------------------% constraint_list_get_tvars(Constraints, TVars) :- list__map(constraint_get_tvars, Constraints, TVarsList), list__condense(TVarsList, TVars). constraint_get_tvars(constraint(_Name, Args), TVars) :- term__vars_list(Args, TVars). get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :- constraint_list_get_tvars(Constraints, ConstrainedTvars), list__delete_elems(Tvars, ConstrainedTvars, Unconstrained0), list__remove_dups(Unconstrained0, Unconstrained). %-----------------------------------------------------------------------------% maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId0, Arity, MaybeTypes) :- ( ConsId0 = cons(SymName, _) -> ( SymName = qualified(_, Name) -> % get_cons_id_non_existential_arg_types % expects an unqualified cons_id. ConsId = cons(unqualified(Name), Arity) ; ConsId = ConsId0 ), ( MaybeType = yes(Type), % XXX get_cons_id_non_existential_arg_types will fail % for ConsIds with existentially typed arguments. get_cons_id_non_existential_arg_types(ModuleInfo, Type, ConsId, Types), list__length(Types, Arity) -> MaybeTypes = list__map(func(T) = yes(T), Types) ; list__duplicate(Arity, no, MaybeTypes) ) ; MaybeTypes = [] ). maybe_get_higher_order_arg_types(MaybeType, Arity, MaybeTypes) :- ( MaybeType = yes(Type), type_is_higher_order(Type, _, _, Types) -> MaybeTypes = list__map(func(T) = yes(T), Types) ; list__duplicate(Arity, no, MaybeTypes) ). %-----------------------------------------------------------------------------%