mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-13 04:44:39 +00:00
Code Issues Projects Releases Wiki Activity
Files
4ee7e744b715b7adf665a267de3814131839a617
mercury/compiler/type_assign.m
Zoltan Somogyi 15aa457e12 Delete $module arg from calls to unexpected.
2018-04-07 18:25:43 +10:00

736 lines
28 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2014 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.
%-----------------------------------------------------------------------------%
%
% File: type_assign.m.
% Main author: fjh (when this code was in typecheck_info.m, or earlier).
%
% This module defines the type_assign and args_type_assign types, plus some
% useful predicates that work with those types.
%
%-----------------------------------------------------------------------------%
:- module check_hlds.type_assign.
:- interface.
:- import_module hlds.
:- import_module hlds.hlds_class.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module hlds.vartypes.
:- import_module parse_tree.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module io.
:- import_module list.
:- import_module maybe.
%-----------------------------------------------------------------------------%
%
% The type_assign data structure.
%
:- type type_assign
---> type_assign(
ta_var_types :: vartypes,
ta_type_varset :: tvarset,
% Universally quantified type variables.
ta_external_type_params :: external_type_params,
% Type bindings.
ta_type_bindings :: tsubst,
% The set of class constraints collected so far.
ta_class_constraints :: hlds_constraints,
% For each constraint found to be redundant, why is it so?
ta_constraint_proof_map :: constraint_proof_map,
% Maps constraint identifiers to the actual constraints.
ta_constraint_map :: constraint_map
).
:- pred type_assign_get_var_types(type_assign::in,
vartypes::out) is det.
:- pred type_assign_get_typevarset(type_assign::in,
tvarset::out) is det.
:- pred type_assign_get_external_type_params(type_assign::in,
external_type_params::out) is det.
:- pred type_assign_get_type_bindings(type_assign::in,
tsubst::out) is det.
:- pred type_assign_get_typeclass_constraints(type_assign::in,
hlds_constraints::out) is det.
:- pred type_assign_get_constraint_proof_map(type_assign::in,
constraint_proof_map::out) is det.
:- pred type_assign_get_constraint_map(type_assign::in,
constraint_map::out) is det.
:- pred type_assign_set_var_types(vartypes::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_typevarset(tvarset::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_external_type_params(external_type_params::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_type_bindings(tsubst::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_typeclass_constraints(hlds_constraints::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_constraint_proof_map(constraint_proof_map::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_constraint_map(constraint_map::in,
type_assign::in, type_assign::out) is det.
:- pred type_assign_set_reduce_results(tvarset::in, tsubst::in,
hlds_constraints::in, constraint_proof_map::in, constraint_map::in,
type_assign::in, type_assign::out) is det.
%-----------------------------------------------------------------------------%
%
% The type_assign_set data structure.
%
:- type type_assign_set == list(type_assign).
:- pred type_assign_set_init(tvarset::in, vartypes::in,
external_type_params::in, hlds_constraints::in, type_assign_set::out)
is det.
% type_assign_set_get_final_info(TypeAssignSet, OldExternalTypeParams,
% OldExistQVars, OldExplicitVarTypes, NewTypeVarSet, New* ...,
% TypeRenaming, ExistTypeRenaming):
%
% Extracts the final inferred types from TypeAssignSet.
%
% OldExternalTypeParams should be the type variables from the head of the
% predicate. XXX How about type variables from existentially quantified
% types returned by predicates called in the body?
% OldExistQVars should be the declared existentially quantified
% type variables (if any).
% OldExplicitVarTypes is the vartypes map containing the explicit
% type qualifications.
% New* is the newly inferred types, in NewTypeVarSet.
% TypeRenaming is a map to rename things from the old TypeVarSet
% to the NewTypeVarSet.
% ExistTypeRenaming is a map (which should be applied *before*
% applying TypeRenaming) to rename existential type variables
% in OldExistQVars.
%
:- pred type_assign_set_get_final_info(type_assign_set::in,
list(tvar)::in, existq_tvars::in, vartypes::in, tvarset::out,
existq_tvars::out, vartypes::out, prog_constraints::out,
constraint_proof_map::out, constraint_map::out,
tvar_renaming::out, tvar_renaming::out) is det.
%-----------------------------------------------------------------------------%
%
% The args_type_assign data structure.
%
:- type args_type_assign
---> args_type_assign(
% Type assignment.
ata_caller_arg_assign :: type_assign,
% Types of callee args, renamed apart.
ata_callee_arg_types :: list(mer_type),
% Constraints from callee, renamed apart.
ata_callee_constraints :: hlds_constraints
).
:- func get_caller_arg_assign(args_type_assign) = type_assign.
:- func get_callee_arg_types(args_type_assign) = list(mer_type).
:- func get_callee_constraints(args_type_assign) = hlds_constraints.
%-----------------------------------------------------------------------------%
%
% The args_type_assign_set data structure.
%
:- type args_type_assign_set == list(args_type_assign).
% XXX document me
%
:- func convert_args_type_assign_set(args_type_assign_set) = type_assign_set.
% Same as convert_args_type_assign_set, but aborts when the args are
% non-empty.
%
:- func convert_args_type_assign_set_check_empty_args(args_type_assign_set) =
type_assign_set.
%-----------------------------------------------------------------------------%
%
% Functions and predicates to help debug the typechecker.
%
:- func type_assign_set_to_pieces(type_assign_set, maybe(int), prog_varset)
= list(format_component).
:- func args_type_assign_set_to_pieces(args_type_assign_set, maybe(int),
prog_varset) = list(format_component).
:- pred type_checkpoint(string::in, module_info::in, prog_varset::in,
type_assign_set::in, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module check_hlds.type_util.
:- import_module libs.
:- import_module libs.file_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.parse_tree_out_term.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
:- import_module bool.
:- import_module int.
:- import_module map.
:- import_module require.
:- import_module set.
:- import_module string.
:- import_module varset.
%-----------------------------------------------------------------------------%
type_assign_get_var_types(TA, X) :-
X = TA ^ ta_var_types.
type_assign_get_typevarset(TA, X) :-
X = TA ^ ta_type_varset.
type_assign_get_external_type_params(TA, X) :-
X = TA ^ ta_external_type_params.
type_assign_get_type_bindings(TA, X) :-
X = TA ^ ta_type_bindings.
type_assign_get_typeclass_constraints(TA, X) :-
X = TA ^ ta_class_constraints.
type_assign_get_constraint_proof_map(TA, X) :-
X = TA ^ ta_constraint_proof_map.
type_assign_get_constraint_map(TA, X) :-
X = TA ^ ta_constraint_map.
type_assign_set_var_types(X, !TA) :-
!TA ^ ta_var_types := X.
type_assign_set_typevarset(X, !TA) :-
!TA ^ ta_type_varset := X.
type_assign_set_external_type_params(X, !TA) :-
!TA ^ ta_external_type_params := X.
type_assign_set_type_bindings(X, !TA) :-
!TA ^ ta_type_bindings := X.
type_assign_set_typeclass_constraints(X, !TA) :-
!TA ^ ta_class_constraints := X.
type_assign_set_constraint_proof_map(X, !TA) :-
!TA ^ ta_constraint_proof_map := X.
type_assign_set_constraint_map(X, !TA) :-
!TA ^ ta_constraint_map := X.
type_assign_set_reduce_results(TVarSet, Bindings, Constraints, ProofMap,
ConstraintMap, TypeAssign0, TypeAssign) :-
TypeAssign0 = type_assign(VarTypes, _, ExternalTypeParams, _, _, _, _),
TypeAssign = type_assign(VarTypes, TVarSet, ExternalTypeParams, Bindings,
Constraints, ProofMap, ConstraintMap).
%-----------------------------------------------------------------------------%
type_assign_set_init(TypeVarSet, VarTypes, ExternalTypeParams, Constraints,
TypeAssignSet) :-
map.init(TypeBindings),
map.init(ProofMap),
map.init(ConstraintMap),
TypeAssignSet = [type_assign(VarTypes, TypeVarSet, ExternalTypeParams,
TypeBindings, Constraints, ProofMap, ConstraintMap)].
type_assign_set_get_final_info(TypeAssignSet,
OldExternalTypeParams, OldExistQVars,
OldExplicitVarTypes, NewTypeVarSet, NewExternalTypeParams,
NewVarTypes, NewTypeConstraints, NewConstraintProofMap,
NewConstraintMap, TSubst, ExistTypeRenaming) :-
(
TypeAssignSet = [TypeAssign | _]
% XXX Why are we using only the first TypeAssign?
;
TypeAssignSet = [],
unexpected($pred, "TypeAssignSet = []")
),
TypeAssign = type_assign(VarTypes0, OldTypeVarSet, ExternalTypeParams,
TypeBindings, HLDSTypeConstraints, ConstraintProofMap0,
ConstraintMap0),
( if map.is_empty(TypeBindings) then
VarTypes1 = VarTypes0,
ConstraintProofMap = ConstraintProofMap0,
ConstraintMap1 = ConstraintMap0,
vartypes_types(VarTypes1, Types1),
type_vars_list(Types1, TypeVars1)
else
transform_foldl_var_types(expand_types(TypeBindings),
VarTypes0, VarTypes1, set.init, TypeVarsSet1),
set.to_sorted_list(TypeVarsSet1, TypeVars1),
apply_rec_subst_to_constraint_proof_map(TypeBindings,
ConstraintProofMap0, ConstraintProofMap),
apply_rec_subst_to_constraint_map(TypeBindings,
ConstraintMap0, ConstraintMap1)
),
% When inferring the typeclass constraints, the universal constraints
% here may be assumed (if this is the last pass) but will not have been
% eliminated during context reduction, hence they will not yet be
% in the constraint map. Since they may be required, put them in now.
%
% Additionally, existential constraints are assumed so don't need to be
% eliminated during context reduction, so they need to be put in the
% constraint map now.
HLDSTypeConstraints = hlds_constraints(HLDSUnivConstraints,
HLDSExistConstraints, _, _),
list.foldl(update_constraint_map, HLDSUnivConstraints,
ConstraintMap1, ConstraintMap2),
list.foldl(update_constraint_map, HLDSExistConstraints,
ConstraintMap2, ConstraintMap),
% Figure out how we should rename the existential types
% in the type declaration (if any).
get_existq_tvar_renaming(OldExternalTypeParams, OldExistQVars,
TypeBindings, ExistTypeRenaming),
% We used to just use the OldTypeVarSet that we got from the type
% assignment.
%
% However, that caused serious efficiency problems, because the
% typevarsets get bigger and bigger with each inference step. Instead,
% we now construct a new typevarset NewTypeVarSet which contains
% only the variables we want, and we rename the type variables so that
% they fit into this new typevarset.
% First, find the set (sorted list) of type variables that we need.
% This must include any type variables in the inferred types, the
% explicit type qualifications, and any existentially typed variables
% that will remain in the declaration.
%
% There may also be some type variables in the ExternalTypeParams
% which do not occur in the type of any variable (e.g. this can happen
% in the case of code containing type errors). We'd better keep those,
% too, to avoid errors when we apply the TSubst to the ExternalTypeParams.
% (XXX should we do the same for TypeConstraints and ConstraintProofMap
% too?)
vartypes_types(OldExplicitVarTypes, ExplicitTypes),
type_vars_list(ExplicitTypes, ExplicitTypeVars0),
map.keys(ExistTypeRenaming, ExistQVarsToBeRenamed),
list.delete_elems(OldExistQVars, ExistQVarsToBeRenamed,
ExistQVarsToRemain),
list.condense([ExistQVarsToRemain, ExternalTypeParams,
TypeVars1, ExplicitTypeVars0], TypeVars2),
list.sort_and_remove_dups(TypeVars2, TypeVars),
% Next, create a new typevarset with the same number of variables.
varset.squash(OldTypeVarSet, TypeVars, NewTypeVarSet, TSubst),
% Finally, if necessary, rename the types and type class constraints
% to use the new typevarset type variables.
retrieve_prog_constraints(HLDSTypeConstraints, TypeConstraints),
( if map.is_empty(TSubst) then
NewVarTypes = VarTypes1,
NewExternalTypeParams = ExternalTypeParams,
NewTypeConstraints = TypeConstraints,
NewConstraintProofMap = ConstraintProofMap,
NewConstraintMap = ConstraintMap
else
apply_variable_renaming_to_vartypes(TSubst, VarTypes1, NewVarTypes),
map.apply_to_list(ExternalTypeParams, TSubst, NewExternalTypeParams),
apply_variable_renaming_to_prog_constraints(TSubst,
TypeConstraints, NewTypeConstraints),
apply_variable_renaming_to_constraint_proof_map(TSubst,
ConstraintProofMap, NewConstraintProofMap),
apply_variable_renaming_to_constraint_map(TSubst,
ConstraintMap, NewConstraintMap)
).
% Fully expand the types of the variables by applying the type bindings.
% We also accumulate the set of type variables we have seen so far,
% since doing so saves having to do a separate traversal for that.
%
:- pred expand_types(tsubst::in, mer_type::in, mer_type::out,
set(tvar)::in, set(tvar)::out) is det.
expand_types(TypeSubst, Type0, Type, !TypeVarsSet) :-
apply_rec_subst_to_type(TypeSubst, Type0, Type),
type_vars(Type, TypeVars),
set.insert_list(TypeVars, !TypeVarsSet).
% We rename any existentially quantified type variables which get mapped
% to other type variables, unless they are mapped to universally quantified
% type variables from the head of the predicate.
%
:- pred get_existq_tvar_renaming(list(tvar)::in, existq_tvars::in, tsubst::in,
tvar_renaming::out) is det.
get_existq_tvar_renaming(OldExternalTypeParams, ExistQVars, TypeBindings,
ExistTypeRenaming) :-
list.foldl(get_existq_tvar_renaming_2(OldExternalTypeParams, TypeBindings),
ExistQVars, map.init, ExistTypeRenaming).
:- pred get_existq_tvar_renaming_2(existq_tvars::in, tsubst::in,
tvar::in, tvar_renaming::in, tvar_renaming::out) is det.
get_existq_tvar_renaming_2(OldExternalTypeParams, TypeBindings, TVar,
!Renaming) :-
( if
tvar_maps_to_tvar(TypeBindings, TVar, NewTVar),
NewTVar \= TVar,
not list.member(NewTVar, OldExternalTypeParams)
then
map.det_insert(TVar, NewTVar, !Renaming)
else
true
).
:- pred tvar_maps_to_tvar(tsubst::in, tvar::in, tvar::out) is semidet.
tvar_maps_to_tvar(TypeBindings, TVar0, TVar) :-
( if map.search(TypeBindings, TVar0, Type) then
Type = type_variable(TVar1, _),
tvar_maps_to_tvar(TypeBindings, TVar1, TVar)
else
TVar = TVar0
).
%-----------------------------------------------------------------------------%
get_caller_arg_assign(ArgsTypeAssign) =
ArgsTypeAssign ^ ata_caller_arg_assign.
get_callee_arg_types(ArgsTypeAssign) =
ArgsTypeAssign ^ ata_callee_arg_types.
get_callee_constraints(ArgsTypeAssign) =
ArgsTypeAssign ^ ata_callee_constraints.
%-----------------------------------------------------------------------------%
convert_args_type_assign_set([]) = [].
convert_args_type_assign_set([ArgsTypeAssign | ArgsTypeAssigns]) =
[convert_args_type_assign(ArgsTypeAssign) |
convert_args_type_assign_set(ArgsTypeAssigns)].
convert_args_type_assign_set_check_empty_args([]) = [].
convert_args_type_assign_set_check_empty_args([ArgTypeAssign | ArgTypeAssigns])
= Result :-
ArgTypeAssign = args_type_assign(_, Args, _),
(
Args = [],
Result =
[convert_args_type_assign(ArgTypeAssign) |
convert_args_type_assign_set_check_empty_args(ArgTypeAssigns)]
;
Args = [_ | _],
% This should never happen, since the arguments should all have been
% processed at this point.
unexpected($pred, "Args != []")
).
:- func convert_args_type_assign(args_type_assign) = type_assign.
convert_args_type_assign(ArgsTypeAssign) = TypeAssign :-
ArgsTypeAssign = args_type_assign(TypeAssign0, _, Constraints0),
type_assign_get_typeclass_constraints(TypeAssign0, OldConstraints),
type_assign_get_type_bindings(TypeAssign0, Bindings),
apply_rec_subst_to_constraints(Bindings, Constraints0, Constraints),
merge_hlds_constraints(Constraints, OldConstraints, NewConstraints),
type_assign_set_typeclass_constraints(NewConstraints,
TypeAssign0, TypeAssign).
%-----------------------------------------------------------------------------%
type_assign_set_to_pieces([], _, _) = [].
type_assign_set_to_pieces([TypeAssign | TypeAssigns], MaybeSeq, VarSet) =
type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) ++
type_assign_set_to_pieces(TypeAssigns, inc_maybe_seq(MaybeSeq), VarSet).
args_type_assign_set_to_pieces([], _, _) = [].
args_type_assign_set_to_pieces([ArgTypeAssign | ArgTypeAssigns], MaybeSeq,
VarSet) = Pieces :-
% XXX Why does this simply pick the TypeAssign part of the ArgTypeAssign,
% instead of invoking convert_args_type_assign?
ArgTypeAssign = args_type_assign(TypeAssign, _ArgTypes, _Cnstrs),
Pieces = type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) ++
args_type_assign_set_to_pieces(ArgTypeAssigns, inc_maybe_seq(MaybeSeq),
VarSet).
%-----------------------------------------------------------------------------%
:- func type_assign_to_pieces(type_assign, maybe(int), prog_varset)
= list(format_component).
type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) = Pieces :-
(
MaybeSeq = yes(N),
SeqPieces0 = [words("Type assignment"), int_fixed(N), suffix(":"), nl],
( if N > 1 then
SeqPieces = [blank_line | SeqPieces0]
else
SeqPieces = SeqPieces0
)
;
MaybeSeq = no,
SeqPieces = []
),
type_assign_get_external_type_params(TypeAssign, ExternalTypeParams),
type_assign_get_var_types(TypeAssign, VarTypes),
type_assign_get_typeclass_constraints(TypeAssign, Constraints),
type_assign_get_type_bindings(TypeAssign, TypeBindings),
type_assign_get_typevarset(TypeAssign, TypeVarSet),
vartypes_vars(VarTypes, Vars),
(
ExternalTypeParams = [],
HeadPieces = []
;
ExternalTypeParams = [_ | _],
VarsStr =
mercury_vars_to_string(TypeVarSet, varnums, ExternalTypeParams),
HeadPieces = [words("some [" ++ VarsStr ++ "]"), nl]
),
TypePieces = type_assign_types_to_pieces(Vars, VarSet, VarTypes,
TypeBindings, TypeVarSet, no),
ConstraintPieces = type_assign_hlds_constraints_to_pieces(Constraints,
TypeBindings, TypeVarSet),
Pieces = SeqPieces ++ HeadPieces ++ TypePieces ++ ConstraintPieces ++ [nl].
:- func type_assign_types_to_pieces(list(prog_var), prog_varset,
vartypes, tsubst, tvarset, bool) = list(format_component).
type_assign_types_to_pieces([], _, _, _, _, FoundOne) = Pieces :-
(
FoundOne = no,
Pieces = [words("(No variables were assigned a type)")]
;
FoundOne = yes,
Pieces = []
).
type_assign_types_to_pieces([Var | Vars], VarSet, VarTypes, TypeBindings,
TypeVarSet, FoundOne) = Pieces :-
( if search_var_type(VarTypes, Var, Type) then
(
FoundOne = yes,
PrefixPieces = [nl]
;
FoundOne = no,
PrefixPieces = []
),
VarStr = mercury_var_to_string(VarSet, varnums, Var),
TypeStr = type_with_bindings_to_string(Type, TypeVarSet, TypeBindings),
AssignPieces = [fixed(VarStr), suffix(":"), words(TypeStr)],
TailPieces = type_assign_types_to_pieces(Vars, VarSet, VarTypes,
TypeBindings, TypeVarSet, yes),
Pieces = PrefixPieces ++ AssignPieces ++ TailPieces
else
Pieces = type_assign_types_to_pieces(Vars, VarSet, VarTypes,
TypeBindings, TypeVarSet, FoundOne)
).
:- func type_with_bindings_to_string(mer_type, tvarset, tsubst) = string.
type_with_bindings_to_string(Type0, TypeVarSet, TypeBindings) = Str :-
apply_rec_subst_to_type(TypeBindings, Type0, Type1),
strip_builtin_qualifiers_from_type(Type1, Type),
Str = mercury_type_to_string(TypeVarSet, print_name_only, Type).
:- func type_assign_hlds_constraints_to_pieces(hlds_constraints,
tsubst, tvarset) = list(format_component).
type_assign_hlds_constraints_to_pieces(Constraints, TypeBindings, TypeVarSet)
= Pieces1 ++ Pieces2 :-
Constraints =
hlds_constraints(ConstraintsToProve, AssumedConstraints, _, _),
PiecesList1 = type_assign_constraints_to_pieces_list("&",
AssumedConstraints, TypeBindings, TypeVarSet, no),
PiecesList2 = type_assign_constraints_to_pieces_list("<=",
ConstraintsToProve, TypeBindings, TypeVarSet, no),
Pieces1 = component_list_to_line_pieces(PiecesList1, []),
Pieces2 = component_list_to_line_pieces(PiecesList2, []).
:- func type_assign_constraints_to_pieces_list(string, list(hlds_constraint),
tsubst, tvarset, bool) = list(list(format_component)).
type_assign_constraints_to_pieces_list(_, [], _, _, _) = [].
type_assign_constraints_to_pieces_list(Operator, [Constraint | Constraints],
TypeBindings, TypeVarSet, FoundOne) = [ThisPieces] ++ TailPieceLists :-
(
FoundOne = no,
Prefix = Operator ++ " "
;
FoundOne = yes,
Prefix = " "
),
apply_rec_subst_to_constraint(TypeBindings, Constraint, BoundConstraint),
retrieve_prog_constraint(BoundConstraint, ProgConstraint),
ThisPieces = [fixed(Prefix ++
mercury_constraint_to_string(TypeVarSet, ProgConstraint))],
TailPieceLists = type_assign_constraints_to_pieces_list(Operator,
Constraints, TypeBindings, TypeVarSet, yes).
:- func inc_maybe_seq(maybe(int)) = maybe(int).
inc_maybe_seq(no) = no.
inc_maybe_seq(yes(N)) = yes(N + 1).
:- func varnums = var_name_print.
varnums = print_name_and_num.
%-----------------------------------------------------------------------------%
type_checkpoint(Msg, ModuleInfo, VarSet, TypeAssignSet, !IO) :-
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, debug_types, DoCheckPoint),
(
DoCheckPoint = yes,
do_type_checkpoint(Msg, ModuleInfo, VarSet, TypeAssignSet, !IO)
;
DoCheckPoint = no
).
:- pred do_type_checkpoint(string::in, module_info::in, prog_varset::in,
type_assign_set::in, io::di, io::uo) is det.
do_type_checkpoint(Msg, ModuleInfo, VarSet, TypeAssignSet, !IO) :-
io.write_string("At ", !IO),
io.write_string(Msg, !IO),
io.write_string(": ", !IO),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, detailed_statistics, Statistics),
maybe_report_stats(Statistics, !IO),
io.write_string("\n", !IO),
( if
Statistics = yes,
TypeAssignSet = [TypeAssign | _]
then
type_assign_get_var_types(TypeAssign, VarTypes),
vartypes_count(VarTypes, VarTypesCount),
io.format("\t`var -> type' map: count = %d\n",
[i(VarTypesCount)], !IO),
type_assign_get_type_bindings(TypeAssign, TypeBindings),
map.count(TypeBindings, TypeBindingsCount),
io.format("\t`type var -> type' map: count = %d\n",
[i(TypeBindingsCount)], !IO)
else
true
),
write_type_assign_set(TypeAssignSet, VarSet, !IO).
:- pred write_type_assign_set(type_assign_set::in, prog_varset::in,
io::di, io::uo) is det.
write_type_assign_set([], _, !IO).
write_type_assign_set([TypeAssign | TypeAssigns], VarSet, !IO) :-
io.write_string("\t", !IO),
write_type_assign(TypeAssign, VarSet, !IO),
io.write_string("\n", !IO),
write_type_assign_set(TypeAssigns, VarSet, !IO).
:- pred write_type_assign(type_assign::in, prog_varset::in, io::di, io::uo)
is det.
write_type_assign(TypeAssign, VarSet, !IO) :-
type_assign_get_external_type_params(TypeAssign, ExternalTypeParams),
type_assign_get_var_types(TypeAssign, VarTypes),
type_assign_get_typeclass_constraints(TypeAssign, Constraints),
type_assign_get_type_bindings(TypeAssign, TypeBindings),
type_assign_get_typevarset(TypeAssign, TypeVarSet),
vartypes_vars(VarTypes, Vars),
(
ExternalTypeParams = []
;
ExternalTypeParams = [_ | _],
io.write_string("some [", !IO),
mercury_output_vars(TypeVarSet, varnums, ExternalTypeParams, !IO),
io.write_string("]\n\t", !IO)
),
write_type_assign_types(VarSet, TypeVarSet, VarTypes, TypeBindings,
no, Vars, !IO),
write_type_assign_hlds_constraints(TypeVarSet, TypeBindings, Constraints,
!IO),
io.write_string("\n", !IO).
:- pred write_type_assign_types(prog_varset::in, tvarset::in, vartypes::in,
tsubst::in, bool::in, list(prog_var)::in, io::di, io::uo) is det.
write_type_assign_types(_, _, _, _, FoundOne, [], !IO) :-
(
FoundOne = no,
io.write_string("(No variables were assigned a type)", !IO)
;
FoundOne = yes
).
write_type_assign_types(VarSet, TypeVarSet, VarTypes, TypeBindings,
FoundOne, [Var | Vars], !IO) :-
( if search_var_type(VarTypes, Var, Type) then
(
FoundOne = yes,
io.write_string("\n\t", !IO)
;
FoundOne = no
),
mercury_output_var(VarSet, varnums, Var, !IO),
io.write_string(": ", !IO),
write_type_with_bindings(TypeVarSet, TypeBindings, Type, !IO),
write_type_assign_types(VarSet, TypeVarSet, VarTypes, TypeBindings,
yes, Vars, !IO)
else
write_type_assign_types(VarSet, TypeVarSet, VarTypes, TypeBindings,
FoundOne, Vars, !IO)
).
% write_type_with_bindings writes out a type after applying the
% type bindings.
%
:- pred write_type_with_bindings(tvarset::in, tsubst::in, mer_type::in,
io::di, io::uo) is det.
write_type_with_bindings(TypeVarSet, TypeBindings, Type0, !IO) :-
apply_rec_subst_to_type(TypeBindings, Type0, Type1),
strip_builtin_qualifiers_from_type(Type1, Type),
mercury_output_type(TypeVarSet, print_name_and_num, Type, !IO).
:- pred write_type_assign_hlds_constraints(tvarset::in, tsubst::in,
hlds_constraints::in, io::di, io::uo) is det.
write_type_assign_hlds_constraints(TypeVarSet, TypeBindings, Constraints,
!IO) :-
Constraints =
hlds_constraints(ConstraintsToProve, AssumedConstraints, _, _),
write_type_assign_constraints(TypeVarSet, TypeBindings,
"&", AssumedConstraints, no, !IO),
write_type_assign_constraints(TypeVarSet, TypeBindings,
"<=", ConstraintsToProve, no, !IO).
:- pred write_type_assign_constraints(tvarset::in, tsubst::in,
string::in, list(hlds_constraint)::in, bool::in, io::di, io::uo) is det.
write_type_assign_constraints(_, _, _, [], _, !IO).
write_type_assign_constraints(TypeVarSet, TypeBindings, Operator,
[Constraint | Constraints], FoundOne, !IO) :-
(
FoundOne = no,
io.write_strings(["\n\t", Operator, " "], !IO)
;
FoundOne = yes,
io.write_string(",\n\t ", !IO)
),
apply_rec_subst_to_constraint(TypeBindings, Constraint, BoundConstraint),
retrieve_prog_constraint(BoundConstraint, ProgConstraint),
mercury_output_constraint(TypeVarSet, varnums, ProgConstraint, !IO),
write_type_assign_constraints(TypeVarSet, TypeBindings, Operator,
Constraints, yes, !IO).
%-----------------------------------------------------------------------------%
:- end_module check_hlds.type_assign.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink