diff --git a/NEWS b/NEWS index 169db4a05..0917242b3 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,11 @@ Changes to the Mercury standard library: * We have added string.c_pointer_to_string/{1,2} and string.from_c_pointer/1 to convert c_pointers to a human readable form. +* We have changed term.variable so that it records the context where + the variable was used. This required the backward mode of + term.var_list_to_term_list to be removed. The backwards mode is + now accessed via term.term_list_to_var_list. + * We have renamed some library predicates whose names were ambiguous. Changes to the Mercury compiler: diff --git a/compiler/add_clause.m b/compiler/add_clause.m index 4c83a9b22..5d37e750c 100644 --- a/compiler/add_clause.m +++ b/compiler/add_clause.m @@ -132,7 +132,7 @@ module_add_clause(ClauseVarSet, PredOrFunc, PredName, Args0, Body, Status, ( GoalType = goal_type_promise(_) -> - term.term_list_to_var_list(Args, HeadVars), + HeadVars = term.term_list_to_var_list(Args), preds_add_implicit_for_assertion(HeadVars, !.ModuleInfo, ModuleName, PredName, Arity, Status, Context, PredOrFunc, PredId, !PredicateTable), @@ -868,11 +868,11 @@ transform_goal_2(unify_expr(A0, B0, Purity), Context, Subst, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :- % It is an error for the left or right hand side of a % unification to be !X (it may be !.X or !:X, however). - ( A0 = functor(atom("!"), [variable(StateVarA)], _) -> + ( A0 = functor(atom("!"), [variable(StateVarA, _)], _) -> report_svar_unify_error(Context, !.VarSet, StateVarA, !Specs), Goal = true_goal, NumAdded = 0 - ; B0 = functor(atom("!"), [variable(StateVarB)], _) -> + ; B0 = functor(atom("!"), [variable(StateVarB, _)], _) -> report_svar_unify_error(Context, !.VarSet, StateVarB, !Specs), Goal = true_goal, NumAdded = 0 @@ -896,8 +896,8 @@ extract_trace_mutable_var(Context, VarSet, Mutable, MutableHLDS, StateVar, MutableHLDS = trace_mutable_var_hlds(MutableName, StateVarName), GetPredName = unqualified("get_" ++ MutableName), SetPredName = unqualified("set_" ++ MutableName), - SetVar = functor(atom("!:"), [variable(StateVar)], Context), - UseVar = functor(atom("!."), [variable(StateVar)], Context), + SetVar = functor(atom("!:"), [variable(StateVar, Context)], Context), + UseVar = functor(atom("!."), [variable(StateVar, Context)], Context), GetPurity = purity_semipure, SetPurity = purity_impure, GetGoal = call_expr(GetPredName, [SetVar], GetPurity) - Context, @@ -910,8 +910,8 @@ extract_trace_io_var(Context, StateVar, GetGoal, SetGoal) :- Builtin = mercury_private_builtin_module, GetPredName = qualified(Builtin, "trace_get_io_state"), SetPredName = qualified(Builtin, "trace_set_io_state"), - SetVar = functor(atom("!:"), [variable(StateVar)], Context), - UseVar = functor(atom("!."), [variable(StateVar)], Context), + SetVar = functor(atom("!:"), [variable(StateVar, Context)], Context), + UseVar = functor(atom("!."), [variable(StateVar, Context)], Context), GetPurity = purity_semipure, SetPurity = purity_impure, GetGoal = call_expr(GetPredName, [SetVar], GetPurity) - Context, diff --git a/compiler/add_type.m b/compiler/add_type.m index df24ed327..af95ef702 100644 --- a/compiler/add_type.m +++ b/compiler/add_type.m @@ -678,9 +678,9 @@ convert_type_defn(parse_tree_foreign_type(ForeignType, MaybeUserEqComp, list(error_spec)::in, list(error_spec)::out) is det. ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs). -ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, Context, +ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, _Context, ImportStatus, !FieldNameTable, !Ctors, !Specs) :- - Ctor = ctor(ExistQVars, Constraints, Name, Args), + Ctor = ctor(ExistQVars, Constraints, Name, Args, Context), QualifiedConsId = make_cons_id(Name, Args, TypeCtor), ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeCtor, Context), @@ -727,7 +727,8 @@ ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, Context, list.map_foldl(add_ctor(ConsName, Arity, ConsDefn), PartialQuals, _PartiallyQualifiedConsIds, !Ctors), - assoc_list.keys(Args, FieldNames), + FieldNames = list.map(func(C) = C ^ arg_field_name, Args), + FirstField = 1, add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor, diff --git a/compiler/check_hlds.m b/compiler/check_hlds.m index 7cb2a08a2..27b155f6d 100644 --- a/compiler/check_hlds.m +++ b/compiler/check_hlds.m @@ -79,6 +79,9 @@ % Warnings about unused imports :- include_module unused_imports. +% Output XML representation useful for documentation of module +:- include_module xml_documentation. + :- include_module goal_path. %-----------------------------------------------------------------------------% diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 8d9d01aee..f282edf46 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -1297,8 +1297,8 @@ check_ctor_constraints(TypeTable, TypeCtor, !ModuleInfo, !Specs) :- list(error_spec)::in, list(error_spec)::out) is det. check_ctor_type_ambiguities(TypeCtor, TypeDefn, Ctor, !ModuleInfo, !Specs) :- - Ctor = ctor(ExistQVars, Constraints, _, CtorArgs), - assoc_list.values(CtorArgs, ArgTypes), + Ctor = ctor(ExistQVars, Constraints, _, CtorArgs, _), + ArgTypes = list.map(func(ctor_arg(_, T, _)) = T, CtorArgs), type_vars_list(ArgTypes, ArgTVars), list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)), ArgTVars, ExistQArgTVars), diff --git a/compiler/det_util.m b/compiler/det_util.m index 6bb728201..a7fd9f0e8 100644 --- a/compiler/det_util.m +++ b/compiler/det_util.m @@ -114,11 +114,11 @@ delete_unreachable_cases([Case | Cases0], [ConsId | ConsIds], Cases) :- ). interpret_unify(X, rhs_var(Y), !Subst) :- - unify_term(variable(X), variable(Y), !Subst). + unify_term(variable(X, context_init), variable(Y, context_init), !Subst). interpret_unify(X, rhs_functor(ConsId, _, ArgVars), !Subst) :- term.var_list_to_term_list(ArgVars, ArgTerms), cons_id_and_args_to_term(ConsId, ArgTerms, RhsTerm), - unify_term(variable(X), RhsTerm, !Subst). + unify_term(variable(X, context_init), RhsTerm, !Subst). interpret_unify(_X, rhs_lambda_goal(_, _, _, _, _, _, _, _), !Subst). % For ease of implementation we just ignore unifications with lambda terms. % This is a safe approximation, it just prevents us from optimizing them diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index 5ad77c0e1..17be18f5a 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -667,8 +667,8 @@ replace_in_ctors_location(Location, EqvMap, !Ctors, !VarSet, !Info, used_modules::in, used_modules::out) is det. replace_in_ctor(Location, EqvMap, - ctor(ExistQVars, Constraints0, TName, Targs0), - ctor(ExistQVars, Constraints, TName, Targs), + ctor(ExistQVars, Constraints0, TName, Targs0, Ctxt), + ctor(ExistQVars, Constraints, TName, Targs, Ctxt), !VarSet, !Info, !UsedModules) :- replace_in_ctor_arg_list(Location, EqvMap, Targs0, Targs, _, !VarSet, !Info, !UsedModules), @@ -751,8 +751,8 @@ replace_in_ctor_arg_list(Location, replace_in_ctor_arg_list_2(_Location, _EqvMap, _Seen, [], [], !Circ, !VarSet, !Info, !UsedModules). -replace_in_ctor_arg_list_2(Location, - EqvMap, Seen, [N - T0 | As0], [N - T | As], +replace_in_ctor_arg_list_2(Location, EqvMap, Seen, + [ctor_arg(N, T0, C) | As0], [ctor_arg(N, T, C) | As], !Circ, !VarSet, !Info, !UsedModules) :- replace_in_type_location_2(Location, EqvMap, Seen, T0, T, _, ContainsCirc, !VarSet, !Info, !UsedModules), diff --git a/compiler/error_util.m b/compiler/error_util.m index 52e7c19b4..f78e231fe 100644 --- a/compiler/error_util.m +++ b/compiler/error_util.m @@ -401,6 +401,13 @@ :- pred report_warning(prog_context::in, int::in, list(format_component)::in, io::di, io::uo) is det. +%-----------------------------------------------------------------------------% + + % Report why the file is not able to be opened, + % and set the exit status to be 1. + % +:- pred unable_to_open_file(string::in, io.error::in, io::di, io::uo) is det. + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -1278,6 +1285,18 @@ report_warning(Context, Indent, Components, !IO) :- %-----------------------------------------------------------------------------% +unable_to_open_file(FileName, IOErr, !IO) :- + io.stderr_stream(StdErr, !IO), + io.write_string(StdErr, "Unable to open file: '", !IO), + io.write_string(StdErr, FileName, !IO), + io.write_string(StdErr, "' because\n", !IO), + io.write_string(StdErr, io.error_message(IOErr), !IO), + io.nl(StdErr, !IO), + + io.set_exit_status(1, !IO). + +%-----------------------------------------------------------------------------% + :- func this_file = string. this_file = "error_util.m". diff --git a/compiler/fact_table.m b/compiler/fact_table.m index abfabf68e..f00f556e8 100644 --- a/compiler/fact_table.m +++ b/compiler/fact_table.m @@ -387,7 +387,7 @@ compile_facts(PredName, Arity, PredInfo, ModuleInfo, FactArgInfos, ProcStreams, int::in, fact_result::out, error_reports::in, error_reports::out, io::di, io::uo) is det. -check_fact_term(_, _, _, _, term.variable(_V), _, _, _, _, error, +check_fact_term(_, _, _, _, term.variable(_V, _), _, _, _, _, error, !Errors, !IO) :- io.get_line_number(LineNum, !IO), io.input_stream_name(FileName, !IO), @@ -489,7 +489,7 @@ check_fact_type_and_mode(Types0, [Term | Terms], ArgNum0, PredOrFunc, Context0, Result, !Errors) :- ArgNum = ArgNum0 + 1, ( - Term = term.variable(_), + Term = term.variable(_, _), Msg = "Error: non-ground term in fact.", add_error_report(Context0, [words(Msg)], !Errors), Result = error diff --git a/compiler/handle_options.m b/compiler/handle_options.m index 10f3ac6a7..eb7a6d8c6 100644 --- a/compiler/handle_options.m +++ b/compiler/handle_options.m @@ -128,6 +128,8 @@ handle_options(Args0, Errors, OptionArgs, Args, Link, !IO) :- MakeTransOptInt, !IO), globals.io_lookup_bool_option(make_analysis_registry, MakeAnalysisRegistry, !IO), + globals.io_lookup_bool_option(make_xml_documentation, + MakeXmlDocumentation, !IO), globals.io_lookup_bool_option(convert_to_mercury, ConvertToMercury, !IO), globals.io_lookup_bool_option(typecheck_only, TypecheckOnly, !IO), @@ -140,8 +142,8 @@ handle_options(Args0, Errors, OptionArgs, Args, Link, !IO) :- bool.or_list([GenerateDependencies, GenerateDependencyFile, MakeInterface, MakePrivateInterface, MakeShortInterface, MakeOptimizationInt, MakeTransOptInt, MakeAnalysisRegistry, - ConvertToMercury, TypecheckOnly, ErrorcheckOnly, TargetCodeOnly, - GenerateIL, CompileOnly], + MakeXmlDocumentation, ConvertToMercury, TypecheckOnly, + ErrorcheckOnly, TargetCodeOnly, GenerateIL, CompileOnly], NotLink), bool.not(NotLink, Link), globals.io_lookup_bool_option(smart_recompilation, Smart, !IO), diff --git a/compiler/hhf.m b/compiler/hhf.m index 627613a0b..ae4d2d5db 100644 --- a/compiler/hhf.m +++ b/compiler/hhf.m @@ -410,7 +410,7 @@ complete_inst_graph_node(ModuleInfo, BaseVars, Var, !HI) :- type_ctor::in, constructor::in, hhf_info::in, hhf_info::out) is det. maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeId, Ctor, !HI) :- - Ctor = ctor(_, _, Name, Args), + Ctor = ctor(_, _, Name, Args, _), ConsId = make_cons_id(Name, Args, TypeId), map.lookup(!.HI ^ inst_graph, Var, node(Functors0, MaybeParent)), ( map.contains(Functors0, ConsId) -> @@ -429,7 +429,7 @@ maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeId, Ctor, !HI) :- is det. add_cons_id(Var, ModuleInfo, BaseVars, Arg, NewVar, !HI) :- - Arg = _ - ArgType, + ArgType = Arg ^ arg_type, !.HI = hhf_info(InstGraph0, VarSet0, VarTypes0), ( find_var_with_type(Var, ArgType, InstGraph0, VarTypes0, diff --git a/compiler/hlds_out.m b/compiler/hlds_out.m index 51916c28e..9c6b3aa90 100644 --- a/compiler/hlds_out.m +++ b/compiler/hlds_out.m @@ -1763,7 +1763,7 @@ write_goal_2(generic_call(GenericCall, ArgVars, Modes, _), ), term.context_init(Context), Functor = term.atom("class_method_call"), - TCInfoTerm = term.variable(TCInfoVar), + TCInfoTerm = term.variable(TCInfoVar, Context), MethodNumTerm = term.functor(term.integer(MethodNum), [], Context), term.var_list_to_term_list(ArgVars, ArgTerms), Term = term.functor(Functor, [TCInfoTerm, MethodNumTerm | ArgTerms], @@ -3321,7 +3321,7 @@ write_constructors_2(Indent, TVarSet, [C | Cs], TagValues, !IO) :- write_ctor(C, TVarSet, TagValues, !IO) :- mercury_output_ctor(C, TVarSet, !IO), - C = ctor(_, _, Name, Args), + C = ctor(_, _, Name, Args, _), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), ( map.search(TagValues, ConsId, TagValue) -> io.write_string("\t% tag: ", !IO), @@ -3980,11 +3980,11 @@ inst_to_term_with_context(ground(Uniq, GroundInstInfo), Context) = Term :- Term = make_atom(inst_uniqueness(Uniq, "ground"), Context) ). inst_to_term_with_context(inst_var(Var), _) = - term.coerce(term.variable(Var)). + term.coerce(term.variable(Var, context_init)). inst_to_term_with_context(constrained_inst_vars(Vars, Inst), Context) = set.fold(func(Var, Term) = term.functor(term.atom("=<"), - [term.coerce(term.variable(Var)), Term], Context), + [term.coerce(term.variable(Var, context_init)), Term], Context), Vars, inst_to_term_with_context(Inst, Context)). inst_to_term_with_context(abstract_inst(Name, Args), Context) = inst_name_to_term(user_inst(Name, Args), Context). diff --git a/compiler/inst_check.m b/compiler/inst_check.m index 8645b99ec..1fe286017 100644 --- a/compiler/inst_check.m +++ b/compiler/inst_check.m @@ -304,7 +304,7 @@ get_du_functors_for_type_def(TypeDef) = Functors :- :- func constructor_to_sym_name_and_arity(constructor) = sym_name_and_arity. -constructor_to_sym_name_and_arity(ctor(_, _, Name, Args)) = +constructor_to_sym_name_and_arity(ctor(_, _, Name, Args, _)) = Name / list.length(Args). % multi_map_set is the same as multi_map.set, except that the arguments are diff --git a/compiler/inst_graph.m b/compiler/inst_graph.m index b032e4b9b..f26b6e623 100644 --- a/compiler/inst_graph.m +++ b/compiler/inst_graph.m @@ -362,7 +362,7 @@ corresponding_members([_ | As], [_ | Bs], A, B) :- merge(InstGraph0, VarSet0, NewInstGraph, NewVarSet, InstGraph, VarSet, Sub) :- varset.merge_subst_without_names(VarSet0, NewVarSet, VarSet, Sub0), ( - map.map_values(pred(_::in, term.variable(V)::in, V::out) is semidet, + map.map_values(pred(_::in, term.variable(V, _)::in, V::out) is semidet, Sub0, Sub1) -> Sub = Sub1 diff --git a/compiler/intermod.m b/compiler/intermod.m index a1ac60af9..5effdd3ca 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -1672,7 +1672,7 @@ strip_headvar_unifications(HeadVars, clause(ProcIds, Goal0, Lang, Context), ( map.search(HeadVarMap, HeadVar0, HeadTerm0) -> HeadTerm = HeadTerm0 ; - HeadTerm = term.variable(HeadVar0) + HeadTerm = term.variable(HeadVar0, Context) ) ), HeadVars, HeadTerms), conj_list_to_goal(Goals, GoalInfo0, Goal) @@ -1694,12 +1694,12 @@ strip_headvar_unifications_from_goal_list([Goal | Goals0], HeadVars, ( Goal = unify(LHSVar, RHS, _, _, _) - _, list.member(LHSVar, HeadVars), + term.context_init(Context), ( RHS = rhs_var(RHSVar), - RHSTerm = term.variable(RHSVar) + RHSTerm = term.variable(RHSVar, Context) ; RHS = rhs_functor(ConsId, _, Args), - term.context_init(Context), ( ConsId = int_const(Int), RHSTerm = term.functor(term.integer(Int), [], Context) diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m index 167b0c27d..3bdc0c181 100644 --- a/compiler/make_hlds_passes.m +++ b/compiler/make_hlds_passes.m @@ -1586,7 +1586,7 @@ add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context, % Construct the semipure get predicate. % UnsafeGetPredName = mutable_unsafe_get_pred_sym_name(ModuleName, Name), - UnsafeGetCallArgs = [variable(X)], + UnsafeGetCallArgs = [variable(X, Context)], CallUnsafeGet = call_expr(UnsafeGetPredName, UnsafeGetCallArgs, purity_semipure) - Context, @@ -1600,7 +1600,7 @@ add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context, ProgVarSet0, predicate, GetPredName, - [variable(X)], + [variable(X, context_init)], StdGetBody ), @@ -1610,7 +1610,7 @@ add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context, % Construct the impure set predicate. % UnsafeSetPredName = mutable_unsafe_set_pred_sym_name(ModuleName, Name), - UnsafeSetCallArgs = [variable(X)], + UnsafeSetCallArgs = [variable(X, context_init)], StdSetCallUnsafeSet = call_expr(UnsafeSetPredName, UnsafeSetCallArgs, purity_impure) - Context, @@ -1622,7 +1622,7 @@ add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context, ProgVarSet0, predicate, SetPredName, - [variable(X)], + [variable(X, context_init)], StdSetBody ), @@ -1639,12 +1639,13 @@ add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context, IOGetBody = promise_purity_expr(dont_make_implicit_promises, purity_pure, GetBody) - Context, + Ctxt = context_init, IOGetClause = item_clause( compiler(mutable_decl), ProgVarSet, predicate, GetPredName, - [variable(X), variable(IO), variable(IO)], + [variable(X, Ctxt), variable(IO, Ctxt), variable(IO, Ctxt)], IOGetBody ), @@ -1664,7 +1665,7 @@ add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context, ProgVarSet, predicate, SetPredName, - [variable(X), variable(IO), variable(IO)], + [variable(X, Ctxt), variable(IO, Ctxt), variable(IO, Ctxt)], IOSetBody ), diff --git a/compiler/make_tags.m b/compiler/make_tags.m index b5c71fbe1..b4b024417 100644 --- a/compiler/make_tags.m +++ b/compiler/make_tags.m @@ -195,7 +195,7 @@ assign_constructor_tags(Ctors, UserEqCmp, TypeCtor, ReservedTagPragma, Globals, assign_enum_constants([], _, !CtorTags). assign_enum_constants([Ctor | Rest], Val, !CtorTags) :- - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), Tag = int_tag(Val), svmap.set(ConsId, Tag, !CtorTags), @@ -215,7 +215,7 @@ assign_reserved_numeric_addresses([Ctor | Rest], LeftOverConstants, ( Address >= NumReservedAddresses -> LeftOverConstants = [Ctor | Rest] ; - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), ( Address = 0 -> Tag = reserved_address_tag(null_pointer) @@ -240,7 +240,7 @@ assign_reserved_symbolic_addresses([Ctor | Ctors], LeftOverConstants, TypeCtor, ( Num >= Max -> LeftOverConstants = [Ctor | Ctors] ; - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), Arity = list.length(Args), Tag = reserved_address_tag(reserved_object(TypeCtor, Name, Arity)), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), @@ -278,7 +278,7 @@ assign_constant_tags(Constants, !CtorTags, InitTag, NextTag) :- assign_unshared_tags([], _, _, _, !CtorTags). assign_unshared_tags([Ctor | Rest], Val, MaxTag, ReservedAddresses, !CtorTags) :- - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), % If there's only one functor, % give it the "single_functor" (untagged) @@ -313,7 +313,7 @@ assign_unshared_tags([Ctor | Rest], Val, MaxTag, ReservedAddresses, assign_shared_remote_tags([], _, _, _, !CtorTags). assign_shared_remote_tags([Ctor | Rest], PrimaryVal, SecondaryVal, ReservedAddresses, !CtorTags) :- - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), Tag = maybe_add_reserved_addresses(ReservedAddresses, shared_remote_tag(PrimaryVal, SecondaryVal)), @@ -327,7 +327,7 @@ assign_shared_remote_tags([Ctor | Rest], PrimaryVal, SecondaryVal, assign_shared_local_tags([], _, _, !CtorTags). assign_shared_local_tags([Ctor | Rest], PrimaryVal, SecondaryVal, !CtorTags) :- - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), ConsId = make_cons_id_from_qualified_sym_name(Name, Args), Tag = shared_local_tag(PrimaryVal, SecondaryVal), svmap.set(ConsId, Tag, !CtorTags), @@ -359,7 +359,7 @@ max_num_tags(NumTagBits) = MaxTags :- ctors_are_all_constants([]). ctors_are_all_constants([Ctor | Rest]) :- - Ctor = ctor(_ExistQVars, _Constraints, _Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, _Name, Args, _Ctxt), Args = [], ctors_are_all_constants(Rest). diff --git a/compiler/mercury_compile.m b/compiler/mercury_compile.m index b54cf8d63..9ecaeca65 100644 --- a/compiler/mercury_compile.m +++ b/compiler/mercury_compile.m @@ -139,6 +139,7 @@ :- import_module check_hlds.goal_path. :- import_module check_hlds.inst_check. :- import_module check_hlds.unused_imports. +:- import_module check_hlds.xml_documentation. :- import_module hlds.arg_info. :- import_module hlds.hlds_data. :- import_module hlds.hlds_module. @@ -1461,6 +1462,8 @@ mercury_compile(Module, NestedSubModules, FindTimestampFiles, MakeTransOptInt, !IO), globals.io_lookup_bool_option(make_analysis_registry, MakeAnalysisRegistry, !IO), + globals.io_lookup_bool_option(make_xml_documentation, + MakeXmlDocumentation, !IO), ( TypeCheckOnly = yes -> FactTableObjFiles = [] ; ErrorCheckOnly = yes -> @@ -1484,6 +1487,9 @@ mercury_compile(Module, NestedSubModules, FindTimestampFiles, ; MakeAnalysisRegistry = yes -> output_analysis_file(ModuleName, HLDS21, !DumpInfo, !IO), FactTableObjFiles = [] + ; MakeXmlDocumentation = yes -> + xml_documentation(HLDS21, !IO), + FactTableObjFiles = [] ; mercury_compile_after_front_end(NestedSubModules, FindTimestampFiles, MaybeTimestamps, ModuleName, HLDS21, @@ -2092,8 +2098,8 @@ frontend_pass_no_type_error(FoundUndefModeError, !FoundError, !HLDS, !DumpInfo, MakeOptInt = no, % Now go ahead and do the rest of mode checking % and determinism analysis. - frontend_pass_by_phases(!HLDS, FoundModeOrDetError, !DumpInfo, - !IO), + frontend_pass_by_phases(!HLDS, + FoundModeOrDetError, !DumpInfo, !IO), !:FoundError = !.FoundError `or` FoundModeOrDetError ) ) @@ -3509,6 +3515,7 @@ maybe_unused_imports(Verbose, Stats, HLDS, Specs, !IO) :- Specs = [] ). + :- pred maybe_type_ctor_infos(bool::in, bool::in, module_info::in, module_info::out, io::di, io::uo) is det. diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m index fa5dafdf1..a0c0ec4ac 100644 --- a/compiler/mercury_to_mercury.m +++ b/compiler/mercury_to_mercury.m @@ -1066,13 +1066,13 @@ mercury_write_module_spec_list([ModuleName | ModuleNames], !IO) :- mercury_output_inst_defn(VarSet, Name, Args, abstract_inst, Context, !IO) :- io.write_string(":- inst (", !IO), - list.map(pred(V::in, variable(V)::out) is det, Args, ArgTerms), + ArgTerms = list.map(func(V) = variable(V, Context), Args), construct_qualified_term(Name, ArgTerms, Context, InstTerm), mercury_output_term(InstTerm, VarSet, no, !IO), io.write_string(").\n", !IO). mercury_output_inst_defn(VarSet, Name, Args, eqv_inst(Body), Context, !IO) :- io.write_string(":- inst (", !IO), - list.map(pred(V::in, variable(V)::out) is det, Args, ArgTerms), + ArgTerms = list.map(func(V) = variable(V, Context), Args), construct_qualified_term(Name, ArgTerms, Context, InstTerm), mercury_output_term(InstTerm, VarSet, no, !IO), io.write_string(") == ", !IO), @@ -1648,7 +1648,7 @@ mercury_format_constrained_inst_vars(Vars0, Inst, InstInfo, !U) :- mercury_format_mode_defn(VarSet, Name, Args, eqv_mode(Mode), Context, !U) :- add_string(":- mode (", !U), - list.map(pred(V::in, variable(V)::out) is det, Args, ArgTerms), + ArgTerms = list.map(func(V) = variable(V, Context), Args), construct_qualified_term(Name, ArgTerms, Context, ModeTerm), mercury_format_term(ModeTerm, VarSet, no, !U), add_string(") == ", !U), @@ -1720,7 +1720,7 @@ mercury_format_mode(user_defined_mode(Name, Args), InstInfo, !U) :- mercury_output_type_defn(TVarSet, Name, TParams, parse_tree_abstract_type(IsSolverType), Context, !IO) :- mercury_output_begin_type_decl(IsSolverType, !IO), - Args = list.map((func(V) = term.variable(V)), TParams), + Args = list.map((func(V) = term.variable(V, Context)), TParams), construct_qualified_term(Name, Args, Context, TypeTerm), mercury_output_term(TypeTerm, TVarSet, no, next_to_graphic_token, !IO), io.write_string(".\n", !IO). @@ -1728,7 +1728,7 @@ mercury_output_type_defn(TVarSet, Name, TParams, mercury_output_type_defn(TVarSet, Name, TParams, parse_tree_eqv_type(Body), Context, !IO) :- mercury_output_begin_type_decl(non_solver_type, !IO), - Args = list.map((func(V) = term.variable(V)), TParams), + Args = list.map((func(V) = term.variable(V, Context)), TParams), construct_qualified_term(Name, Args, Context, TypeTerm), mercury_output_term(TypeTerm, TVarSet, no, !IO), io.write_string(" == ", !IO), @@ -1738,7 +1738,7 @@ mercury_output_type_defn(TVarSet, Name, TParams, parse_tree_eqv_type(Body), mercury_output_type_defn(TVarSet, Name, TParams, parse_tree_du_type(Ctors, MaybeUserEqComp), Context, !IO) :- mercury_output_begin_type_decl(non_solver_type, !IO), - Args = list.map((func(V) = term.variable(V)), TParams), + Args = list.map((func(V) = term.variable(V, Context)), TParams), construct_qualified_term(Name, Args, Context, TypeTerm), mercury_output_term(TypeTerm, TVarSet, no, !IO), io.write_string("\n\t--->\t", !IO), @@ -1750,7 +1750,7 @@ mercury_output_type_defn(TVarSet, Name, TParams, parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp), Context, !IO) :- mercury_output_begin_type_decl(solver_type, !IO), - Args = list.map((func(V) = term.variable(V)), TParams), + Args = list.map((func(V) = term.variable(V, Context)), TParams), construct_qualified_term(Name, Args, Context, TypeTerm), mercury_output_term(TypeTerm, TVarSet, no, !IO), mercury_output_where_attributes(TVarSet, yes(SolverTypeDetails), @@ -1771,7 +1771,7 @@ mercury_output_type_defn(TVarSet, Name, TParams, ForeignType = java(_), io.write_string("java, ", !IO) ), - Args = list.map((func(V) = term.variable(V)), TParams), + Args = list.map((func(V) = term.variable(V, context_init)), TParams), construct_qualified_term(Name, Args, MercuryType), mercury_output_term(MercuryType, TVarSet, no, !IO), io.write_string(", \"", !IO), @@ -1930,7 +1930,7 @@ mercury_output_ctors([Ctor | Ctors], VarSet, !IO) :- mercury_output_ctors(Ctors, VarSet, !IO). mercury_output_ctor(Ctor, VarSet, !IO) :- - Ctor = ctor(ExistQVars, Constraints, SymName, Args), + Ctor = ctor(ExistQVars, Constraints, SymName, Args, _Ctxt), % We'll have attached the module name to the type definition, % so there's no point adding it to the constructor as well. @@ -1994,15 +1994,14 @@ mercury_output_ctor(Ctor, VarSet, !IO) :- :- pred mercury_output_ctor_arg(tvarset::in, constructor_arg::in, io::di, io::uo) is det. -mercury_output_ctor_arg(Varset, N - T, !IO) :- +mercury_output_ctor_arg(Varset, ctor_arg(N, T, _), !IO) :- mercury_output_ctor_arg_name_prefix(N, !IO), mercury_output_type(Varset, no, T, !IO). mercury_output_remaining_ctor_args(_Varset, [], !IO). -mercury_output_remaining_ctor_args(Varset, [N - T | As], !IO) :- +mercury_output_remaining_ctor_args(Varset, [A | As], !IO) :- io.write_string(", ", !IO), - mercury_output_ctor_arg_name_prefix(N, !IO), - mercury_output_type(Varset, no, T, !IO), + mercury_output_ctor_arg(Varset, A, !IO), mercury_output_remaining_ctor_args(Varset, As, !IO). :- pred mercury_output_ctor_arg_name_prefix(maybe(ctor_field_name)::in, @@ -3694,7 +3693,7 @@ mercury_format_term(Term, VarSet, AppendVarnums, !U) :- :- pred mercury_format_term(term(T)::in, varset(T)::in, bool::in, needs_quotes::in, U::di, U::uo) is det <= output(U). -mercury_format_term(term.variable(Var), VarSet, AppendVarnums, _, !U) :- +mercury_format_term(term.variable(Var, _), VarSet, AppendVarnums, _, !U) :- mercury_format_var(VarSet, AppendVarnums, Var, !U). mercury_format_term(term.functor(Functor, Args, _), VarSet, AppendVarnums, NextToGraphicToken, !U) :- @@ -4289,7 +4288,7 @@ output_list([Item | Items], Sep, Pred, !Str) :- :- pred builtin_inst_name(sym_name::in, list(inst_var)::in) is semidet. builtin_inst_name(unqualified(Name), Args0) :- - Args1 = list.map(func(V) = term.variable(term.coerce_var(V)), Args0), + Args1 = list.map(func(V) = variable(coerce_var(V), context_init), Args0), Term = term.functor(term.atom(Name), Args1, term.context_init), convert_inst(no_allow_constrained_inst_var, Term, Inst), Inst \= defined_inst(user_inst(_, _)). diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m index 78c9a773c..f87d6c392 100644 --- a/compiler/ml_type_gen.m +++ b/compiler/ml_type_gen.m @@ -235,7 +235,7 @@ ml_gen_enum_value_member(Context) = ml_gen_enum_constant(Context, ConsTagValues, Ctor) = MLDS_Defn :- % Figure out the value of this enumeration constant. - Ctor = ctor(_ExistQTVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQTVars, _Constraints, Name, Args, _Ctxt), list.length(Args, Arity), map.lookup(ConsTagValues, cons(Name, Arity), TagVal), ( TagVal = int_tag(Int) -> @@ -449,7 +449,7 @@ ml_gen_tag_constant(Context, ConsTagValues, Ctor) = MLDS_Defns :- % we don't do the same thing for primary tags, so this is most useful % in the `--tags none' case, where there will be no primary tags. - Ctor = ctor(_ExistQTVars, _Constraints, Name, _Args), + Ctor = ctor(_ExistQTVars, _Constraints, Name, _Args, _Ctxt), UnqualifiedName = unqualify_name(Name), ConstValue = const(mlconst_int(SecondaryTag)), MLDS_Defn = mlds_defn( @@ -507,7 +507,7 @@ tagval_is_reserved_addr(shared_with_reserved_addresses_tag(_, TagVal), RA) :- :- func get_tagval(cons_tag_values, constructor) = cons_tag. get_tagval(ConsTagValues, Ctor) = TagVal :- - Ctor = ctor(_ExistQTVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQTVars, _Constraints, Name, Args, _Ctxt), list.length(Args, Arity), map.lookup(ConsTagValues, cons(Name, Arity), TagVal). @@ -566,7 +566,7 @@ ml_gen_secondary_tag_class(MLDS_Context, BaseClassQualifier, BaseClassId, ml_gen_du_ctor_member(ModuleInfo, BaseClassId, BaseClassQualifier, SecondaryTagClassId, TypeDefn, ConsTagValues, Ctor, MLDS_Members0, MLDS_Members, MLDS_CtorMethods0, MLDS_CtorMethods) :- - Ctor = ctor(ExistQTVars, Constraints, CtorName, Args), + Ctor = ctor(ExistQTVars, Constraints, CtorName, Args, _Ctxt), % XXX We should keep a context for the constructor, % but we don't, so we just use the context from the type. @@ -888,10 +888,9 @@ ml_gen_type_info_member(ModuleInfo, Context, TypeVar, MLDS_Defn, :- pred ml_gen_du_ctor_field(module_info::in, prog_context::in, constructor_arg::in, mlds_defn::out, int::in, int::out) is det. -ml_gen_du_ctor_field(ModuleInfo, Context, MaybeFieldName - Type, MLDS_Defn, - ArgNum0, ArgNum) :- - ml_gen_field(ModuleInfo, Context, MaybeFieldName, Type, MLDS_Defn, - ArgNum0, ArgNum). +ml_gen_du_ctor_field(ModuleInfo, Context, Arg, MLDS_Defn, ArgNum0, ArgNum) :- + ml_gen_field(ModuleInfo, Context, Arg ^ arg_field_name, Arg ^ arg_type, + MLDS_Defn, ArgNum0, ArgNum). :- pred ml_gen_field(module_info::in, prog_context::in, maybe(ctor_field_name)::in, mer_type::in, mlds_defn::out, diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m index b4ce0f457..78dddf990 100644 --- a/compiler/ml_unify_gen.m +++ b/compiler/ml_unify_gen.m @@ -968,7 +968,7 @@ constructor_arg_types(CtorId, ArgTypes, Type, ModuleInfo) = ConsArgTypes :- type_util.get_cons_defn(ModuleInfo, TypeCtor, CtorId, ConsDefn) -> ConsDefn = hlds_cons_defn(_, _, ConsArgDefns, _, _), - assoc_list.values(ConsArgDefns, ConsArgTypes0), + ConsArgTypes0 = list.map(func(C) = C ^ arg_type, ConsArgDefns), % There may have been additional types inserted to hold the % type_infos and type_class_infos for existentially quantified @@ -1426,7 +1426,8 @@ ml_tag_offset_and_argnum(Tag, TagBits, OffSet, ArgNum) :- ml_field_names_and_types(Info, Type, ConsId, ArgTypes, Fields) :- % Lookup the field types for the arguments of this cons_id. - MakeUnnamedField = (func(FieldType) = no - FieldType), + Context = term.context_init, + MakeUnnamedField = (func(FieldType) = ctor_arg(no, FieldType, Context)), ( type_is_tuple(Type, _), list.length(ArgTypes, TupleArity) @@ -1493,7 +1494,8 @@ ml_gen_unify_args_2(ConsId, [Arg | Args], [Mode | Modes], [ArgType | ArgTypes], ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval, Offset, ArgNum, Tag, Context, !Statements, !Info) :- - Field = MaybeFieldName - FieldType, + MaybeFieldName = Field ^ arg_field_name, + FieldType = Field ^ arg_type, ml_gen_info_get_module_info(!.Info, ModuleInfo), module_info_get_globals(ModuleInfo, Globals), globals.lookup_bool_option(Globals, highlevel_data, HighLevelData), diff --git a/compiler/mode_util.m b/compiler/mode_util.m index bd4c09f6c..11a37c624 100644 --- a/compiler/mode_util.m +++ b/compiler/mode_util.m @@ -763,7 +763,7 @@ constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors, BoundInsts) :- constructors_to_bound_insts_2(_, _, [], _, []). constructors_to_bound_insts_2(ModuleInfo, Uniq, [Ctor | Ctors], ArgInst, [BoundInst | BoundInsts]) :- - Ctor = ctor(_ExistQVars, _Constraints, Name, Args), + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), ctor_arg_list_to_inst_list(Args, ArgInst, Insts), list.length(Insts, Arity), BoundInst = bound_functor(cons(Name, Arity), Insts), @@ -774,7 +774,7 @@ constructors_to_bound_insts_2(ModuleInfo, Uniq, [Ctor | Ctors], ArgInst, list(mer_inst)::out) is det. ctor_arg_list_to_inst_list([], _, []). -ctor_arg_list_to_inst_list([_Name - _Type | Args], Inst, [Inst | Insts]) :- +ctor_arg_list_to_inst_list([_ | Args], Inst, [Inst | Insts]) :- ctor_arg_list_to_inst_list(Args, Inst, Insts). :- pred propagate_ctor_info_2(module_info::in, mer_type::in, @@ -844,14 +844,14 @@ propagate_ctor_info_3(ModuleInfo, Subst, TypeModule, Constructors, ( ConsId = cons(ConsName, Arity), GetCons = (pred(Ctor::in) is semidet :- - Ctor = ctor(_, _, ConsName, CtorArgs), + Ctor = ctor(_, _, ConsName, CtorArgs, _), list.length(CtorArgs, Arity) ), list.filter(GetCons, Constructors, [Constructor]) -> - Constructor = ctor(_ExistQVars, _Constraints, _Name, Args), + Constructor = ctor(_ExistQVars, _Constraints, _Name, Args, _Ctxt), GetArgTypes = (pred(CtorArg::in, ArgType::out) is det :- - CtorArg = _ArgName - ArgType + ArgType = CtorArg ^ arg_type ), list.map(GetArgTypes, Args, ArgTypes), propagate_types_into_inst_list(ModuleInfo, Subst, ArgTypes, diff --git a/compiler/module_qual.m b/compiler/module_qual.m index 7a7de3f34..c7490b1e8 100644 --- a/compiler/module_qual.m +++ b/compiler/module_qual.m @@ -825,11 +825,11 @@ qualify_type_defn(parse_tree_solver_type(SolverTypeDetails0, MaybeUserEqComp), qualify_constructors([], [], !Info, !Specs). qualify_constructors([Ctor0 | Ctors0], [Ctor | Ctors], !Info, !Specs) :- - Ctor0 = ctor(ExistQVars, Constraints0, SymName, Args0), + Ctor0 = ctor(ExistQVars, Constraints0, SymName, Args0, Ctxt), qualify_constructor_arg_list(Args0, Args, !Info, !Specs), qualify_constructors(Ctors0, Ctors, !Info, !Specs), qualify_prog_constraint_list(Constraints0, Constraints, !Info, !Specs), - Ctor = ctor(ExistQVars, Constraints, SymName, Args). + Ctor = ctor(ExistQVars, Constraints, SymName, Args, Ctxt). % Qualify the inst parameters of an inst definition. % @@ -1006,9 +1006,9 @@ qualify_bound_inst_list([bound_functor(ConsId, Insts0) | BoundInsts0], list(error_spec)::in, list(error_spec)::out) is det. qualify_constructor_arg_list([], [], !Info, !Specs). -qualify_constructor_arg_list([Name - Type0 | Args0], [Name - Type | Args], - !Info, !Specs) :- - qualify_type(Type0, Type, !Info, !Specs), +qualify_constructor_arg_list([Arg0 | Args0], [Arg | Args], !Info, !Specs) :- + qualify_type(Arg0 ^ arg_type, Type, !Info, !Specs), + Arg = Arg0 ^ arg_type := Type, qualify_constructor_arg_list(Args0, Args, !Info, !Specs). :- pred qualify_type_list(list(mer_type)::in, list(mer_type)::out, diff --git a/compiler/notes/compiler_design.html b/compiler/notes/compiler_design.html index e049994ad..c22f7447b 100644 --- a/compiler/notes/compiler_design.html +++ b/compiler/notes/compiler_design.html @@ -866,6 +866,14 @@ so that the compiler does the right thing for options such as implementation.

+

xml documentation (xml_documentation.m) + +
+ xml_documentation.m outputs a XML representation of all the + declarations in the module. This XML representation is designed + to be transformed via XSL into more human readable documentation. +

+

3. High-level transformations

@@ -1690,6 +1698,6 @@ The following modules are part of the libs.m package.
-Last update was $Date: 2006-09-15 11:14:37 $ by $Author: petdr $@cs.mu.oz.au.
+Last update was $Date: 2006-11-01 06:33:32 $ by $Author: petdr $@cs.mu.oz.au.
diff --git a/compiler/options.m b/compiler/options.m index 83b82aba6..8ba7545cf 100644 --- a/compiler/options.m +++ b/compiler/options.m @@ -164,6 +164,7 @@ ; make_optimization_interface ; make_transitive_opt_interface ; make_analysis_registry + ; make_xml_documentation ; generate_source_file_mapping ; generate_dependency_file ; generate_dependencies @@ -936,6 +937,7 @@ option_defaults_2(output_option, [ make_optimization_interface - bool(no), make_transitive_opt_interface - bool(no), make_analysis_registry - bool(no), + make_xml_documentation - bool(no), convert_to_mercury - bool(no), typecheck_only - bool(no), errorcheck_only - bool(no), @@ -1560,6 +1562,7 @@ short_option('t', typecheck_only). short_option('v', verbose). short_option('V', very_verbose). short_option('w', inhibit_warnings). +short_option('x', make_xml_documentation). short_option('?', help). % warning options @@ -1661,6 +1664,8 @@ long_option("make-transitive-optimisation-interface", make_transitive_opt_interface). long_option("make-trans-opt", make_transitive_opt_interface). long_option("make-analysis-registry", make_analysis_registry). +long_option("make-xml-doc", make_xml_documentation). +long_option("make-xml-documentation", make_xml_documentation). long_option("convert-to-mercury", convert_to_mercury). long_option("convert-to-Mercury", convert_to_mercury). long_option("pretty-print", convert_to_mercury). @@ -3055,6 +3060,10 @@ options_help_output --> "\tOutput transitive optimization information", "\tinto the `.trans_opt' file.", "\tThis option should only be used by mmake.", + "-x,--make-xml-doc,--make-xml-documentation", + "\tOutput XML documentation of the module", + "\tinto the `.xml' file.", + "\tThis option should only be used by mmake.", "-P, --convert-to-mercury", "\tConvert to Mercury. Output to file `.ugly'", "\tThis option acts as a Mercury ugly-printer.", diff --git a/compiler/post_typecheck.m b/compiler/post_typecheck.m index 6c982503f..266ec51f7 100644 --- a/compiler/post_typecheck.m +++ b/compiler/post_typecheck.m @@ -1041,7 +1041,7 @@ find_matching_constructor(ModuleInfo, TVarSet, ConsId, Type, ArgTypes) :- hlds_data.get_type_defn_tvarset(TypeDefn, TypeTVarSet), hlds_data.get_type_defn_kind_map(TypeDefn, TypeKindMap), - assoc_list.values(ConsArgs, ConsArgTypes), + ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgs), arg_type_list_subsumes(TVarSet, ArgTypes, TypeTVarSet, TypeKindMap, ConsExistQVars, ConsArgTypes). @@ -1207,7 +1207,7 @@ get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, GoalPath, ConsId, type_util.get_type_and_cons_defn(ModuleInfo, TermType, ConsId, TypeDefn, ConsDefn), ConsDefn = hlds_cons_defn(ConsExistQVars, ConsConstraints, ConsArgs, _, _), - assoc_list.values(ConsArgs, ConsArgTypes), + ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgs), ( ConsExistQVars = [], @@ -1338,7 +1338,7 @@ get_constructor_containing_field_2([], _, _, _) :- "get_constructor_containing_field: can't find field"). get_constructor_containing_field_2([Ctor | Ctors], FieldName, ConsId, FieldNumber) :- - Ctor = ctor(_, _, SymName, CtorArgs), + Ctor = ctor(_, _, SymName, CtorArgs, _Ctxt), ( get_constructor_containing_field_3(CtorArgs, FieldName, 1, FieldNumber0) @@ -1354,10 +1354,10 @@ get_constructor_containing_field_2([Ctor | Ctors], FieldName, :- pred get_constructor_containing_field_3(list(constructor_arg)::in, ctor_field_name::in, int::in, int::out) is semidet. -get_constructor_containing_field_3([MaybeArgFieldName - _ | CtorArgs], +get_constructor_containing_field_3([CtorArg | CtorArgs], FieldName, FieldNumber0, FieldNumber) :- ( - MaybeArgFieldName = yes(ArgFieldName), + CtorArg ^ arg_field_name = yes(ArgFieldName), UnqualFieldName = unqualify_name(ArgFieldName), UnqualFieldName = unqualify_name(FieldName) -> diff --git a/compiler/prog_ctgc.m b/compiler/prog_ctgc.m index c9cf396f3..8afbbe2ef 100644 --- a/compiler/prog_ctgc.m +++ b/compiler/prog_ctgc.m @@ -279,7 +279,7 @@ parse_datastruct(Term) = Datastruct :- Term = term.functor(term.atom(Cons), Args, _), Cons = "cel", Args = [VarTerm, SelectorTerm], - VarTerm = term.variable(Var) + VarTerm = term.variable(Var, _) -> Datastruct = selected_cel(term.coerce_var(Var), parse_selector(SelectorTerm)) @@ -504,7 +504,7 @@ parse_user_annotated_sharing_pair_term(Term, SharingPair) :- parse_user_annotated_datastruct_term(Term, Datastruct) :- Term = term.functor(term.atom("cel"), [VarTerm, TypesTerm], _), - VarTerm = term.variable(GenericVar), + VarTerm = term.variable(GenericVar, _), term.coerce_var(GenericVar, ProgVar), get_list_term_arguments(TypesTerm, TypeTermsList), parse_types(TypeTermsList, ok1(Types)), diff --git a/compiler/prog_data.m b/compiler/prog_data.m index cc8215fa3..17a6a9d65 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -1056,10 +1056,16 @@ cons_constraints :: list(prog_constraint), % existential constraints cons_name :: sym_name, - cons_args :: list(constructor_arg) + cons_args :: list(constructor_arg), + cons_context :: prog_context ). -:- type constructor_arg == pair(maybe(ctor_field_name), mer_type). +:- type constructor_arg + ---> ctor_arg( + arg_field_name :: maybe(ctor_field_name), + arg_type :: mer_type, + arg_context :: prog_context + ). :- type ctor_field_name == sym_name. @@ -1949,7 +1955,7 @@ tvarset_merge_renaming_without_names(TVarSetA, TVarSetB, TVarSet, Renaming) :- :- pred convert_subst_term_to_tvar(tvar::in, term(tvar_type)::in, tvar::out) is det. -convert_subst_term_to_tvar(_, variable(TVar), TVar). +convert_subst_term_to_tvar(_, variable(TVar, _), TVar). convert_subst_term_to_tvar(_, functor(_, _, _), _) :- unexpected(this_file, "non-variable found in renaming"). diff --git a/compiler/prog_io.m b/compiler/prog_io.m index a8cbb0bee..970ef3318 100644 --- a/compiler/prog_io.m +++ b/compiler/prog_io.m @@ -2567,8 +2567,8 @@ process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :- % existentially quantified or occur in the head. list.member(Ctor, Ctors), - Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs), - assoc_list.values(CtorArgs, CtorArgTypes), + Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs, _Ctxt), + CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs), type_list_contains_var(CtorArgTypes, Var), \+ list.member(Var, ExistQVars), \+ list.member(Var, Params) @@ -2581,7 +2581,7 @@ process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :- % If we were to allow it, we would need to rename them apart.) list.member(Ctor, Ctors), - Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs), + Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs, _Ctxt), list.member(Var, ExistQVars), list.member(Var, Params) -> @@ -2593,9 +2593,9 @@ process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :- % somewhere in the constructor argument types or constraints. list.member(Ctor, Ctors), - Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs), + Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs, _Ctxt), list.member(Var, ExistQVars), - assoc_list.values(CtorArgs, CtorArgTypes), + CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs), \+ type_list_contains_var(CtorArgTypes, Var), constraint_list_get_tvars(Constraints, ConstraintTVars), \+ list.member(Var, ConstraintTVars) @@ -2608,7 +2608,7 @@ process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :- % the existential quantifiers. list.member(Ctor, Ctors), - Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs), + Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs, _Ctxt), list.member(Constraint, Constraints), Constraint = constraint(_Name, ConstraintArgs), type_list_contains_var(ConstraintArgs, Var), @@ -2650,7 +2650,7 @@ process_abstract_type_2(ok2(Functor, Params), IsSolverType, Result) :- %-----------------------------------------------------------------------------% parse_type_defn_head(ModuleName, Head, Body, Result) :- - ( Head = term.variable(_) -> + ( Head = term.variable(_, _) -> % `Head' has no term.context, so we need to get the % context from `Body'. ( Body = term.functor(_, _, Context) -> @@ -2677,7 +2677,7 @@ parse_type_defn_head_2(ok2(Name, Args), Head, Result) :- parse_type_defn_head_3(Name, Args, Head, Result) :- % Check that all the head args are variables. - ( var_list_to_term_list(Params0, Args) -> + ( term_list_to_var_list(Args, Params0) -> % Check that all the head arg variables are distinct. ( list.member(_, Params0, [Param | OtherParams]), @@ -2786,10 +2786,16 @@ convert_constructor_3(ModuleName, ExistQVars, Constraints, Term0, Term1) = Result = error1(Errors) ; Result1 = ok1(Args), - Result = ok1(ctor(ExistQVars, Constraints, F, Args)) + Ctxt = term_context(Term1), + Result = ok1(ctor(ExistQVars, Constraints, F, Args, Ctxt)) ) ). +:- func term_context(term(T)) = prog_context. + +term_context(functor(_, _, C)) = C. +term_context(variable(_, C)) = C. + %-----------------------------------------------------------------------------% % parse a `:- pred p(...)' declaration or a @@ -3488,7 +3494,7 @@ convert_inst_defn_2(error2(Errors), _, _, error1(Errors)). convert_inst_defn_2(ok2(Name, ArgTerms), Head, Body, Result) :- ( % Check that all the head args are variables. - term.var_list_to_term_list(Args, ArgTerms) + term.term_list_to_var_list(ArgTerms, Args) -> ( % Check that all the head arg variables are distinct. @@ -3552,7 +3558,7 @@ convert_abstract_inst_defn_2(error2(Errors), _, error1(Errors)). convert_abstract_inst_defn_2(ok2(Name, ArgTerms), Head, Result) :- ( % Check that all the head args are variables. - term.var_list_to_term_list(Args, ArgTerms) + term.term_list_to_var_list(ArgTerms, Args) -> ( % Check that all the head arg variables are distinct. @@ -3619,7 +3625,7 @@ convert_mode_defn_2(error2(Errors), _, _, error1(Errors)). convert_mode_defn_2(ok2(Name, ArgTerms), Head, Body, Result) :- ( % Check that all the head args are variables. - term.var_list_to_term_list(Args, ArgTerms) + term.term_list_to_var_list(ArgTerms, Args) -> ( % Check that all the head arg variables are distinct. @@ -3870,7 +3876,7 @@ parse_module_specifier(Term, Result) :- maybe1(module_name)::out) is det. parse_module_name(DefaultModuleName, Term, Result) :- - ( Term = term.variable(_) -> + ( Term = term.variable(_, _) -> dummy_term(ErrorContext), Msg = "module names starting with capital letters " ++ "must be quoted using single quotes (e.g. "":- module 'Foo'."")", @@ -4190,7 +4196,7 @@ parse_qualified_term(Term, ContainingTerm, Msg, Result) :- % Since variables don't have any term.context, if Term is % a variable, we use ContainingTerm instead (hopefully that % _will_ have a term.context). - ( Term = term.variable(_) -> + ( Term = term.variable(_, _) -> ErrorTerm0 = ContainingTerm ; ErrorTerm0 = Term @@ -4294,7 +4300,8 @@ convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) = parse_type(TypeTerm, TypeResult), ( TypeResult = ok1(Type), - Arg = MaybeFieldName - Type, + Context = term_context(TypeTerm), + Arg = ctor_arg(MaybeFieldName, Type, Context), Result0 = convert_constructor_arg_list(ModuleName, Terms), ( Result0 = error1(Errors), diff --git a/compiler/prog_io_dcg.m b/compiler/prog_io_dcg.m index 118d67749..6c8cec398 100644 --- a/compiler/prog_io_dcg.m +++ b/compiler/prog_io_dcg.m @@ -73,7 +73,7 @@ parse_dcg_clause(ModuleName, VarSet0, DCG_Head, DCG_Body, DCG_Context, parse_implicitly_qualified_term(ModuleName, DCG_Head, DCG_Body, "DCG clause head", HeadResult), process_dcg_clause(HeadResult, ProgVarSet, DCG_0_Var, DCG_Var, Body, - ProcessResult), + DCG_Context, ProcessResult), add_context(ProcessResult, DCG_Context, Result) ; MaybeBody = error1(Errors), @@ -114,8 +114,7 @@ parse_dcg_goal(Term, MaybeGoal, !VarSet, !Counter, !Var) :- ( Term = term.functor(_, _, Context) ; - Term = term.variable(_), - term.context_init(Context) + Term = term.variable(_, Context) ), % Next, parse it. ( @@ -135,7 +134,8 @@ parse_dcg_goal(Term, MaybeGoal, !VarSet, !Counter, !Var) :- % as the DCG output var from this goal, and append the DCG argument % pair to the non-terminal's argument list. new_dcg_var(!VarSet, !Counter, Var), - Args = Args0 ++ [term.variable(!.Var), term.variable(Var)], + Args = Args0 ++ + [term.variable(!.Var, Context), term.variable(Var, Context)], Goal = call_expr(SymName, Args, purity_pure) - Context, MaybeGoal = ok1(Goal), !:Var = Var @@ -147,7 +147,7 @@ parse_dcg_goal(Term, MaybeGoal, !VarSet, !Counter, !Var) :- new_dcg_var(!VarSet, !Counter, Var), term.coerce(Term, ProgTerm), Goal = call_expr(unqualified("call"), - [ProgTerm, term.variable(!.Var), term.variable(Var)], + [ProgTerm, variable(!.Var, Context), variable(Var, Context)], purity_pure) - Context, MaybeGoal = ok1(Goal), !:Var = Var @@ -257,7 +257,8 @@ parse_dcg_goal_2("promise_impure_implicit", [G], Context, MaybeGoal, parse_dcg_goal_2("[]", [], Context, MaybeGoal, !VarSet, !Counter, Var0, Var) :- % Empty list - just unify the input and output DCG args. new_dcg_var(!VarSet, !Counter, Var), - Goal = unify_expr(term.variable(Var0), term.variable(Var), purity_pure) + Goal = unify_expr( + term.variable(Var0, Context), term.variable(Var, Context), purity_pure) - Context, MaybeGoal = ok1(Goal). parse_dcg_goal_2("[|]", [X, Xs], Context, MaybeGoal, !VarSet, !Counter, @@ -267,20 +268,20 @@ parse_dcg_goal_2("[|]", [X, Xs], Context, MaybeGoal, !VarSet, !Counter, new_dcg_var(!VarSet, !Counter, Var), ConsTerm0 = term.functor(term.atom("[|]"), [X, Xs], Context), term.coerce(ConsTerm0, ConsTerm), - term_list_append_term(ConsTerm, term.variable(Var), Term), - Goal = unify_expr(term.variable(Var0), Term, purity_pure) - Context, + term_list_append_term(ConsTerm, term.variable(Var, Context), Term), + Goal = unify_expr(variable(Var0, Context), Term, purity_pure) - Context, MaybeGoal = ok1(Goal). parse_dcg_goal_2("=", [A0], Context, MaybeGoal, !VarSet, !Counter, Var, Var) :- % Call to '='/1 - unify argument with DCG input arg. term.coerce(A0, A), - Goal = unify_expr(A, term.variable(Var), purity_pure) - Context, + Goal = unify_expr(A, variable(Var, Context), purity_pure) - Context, MaybeGoal = ok1(Goal). parse_dcg_goal_2(":=", [A0], Context, MaybeGoal, !VarSet, !Counter, _Var0, Var) :- % Call to ':='/1 - unify argument with DCG output arg. new_dcg_var(!VarSet, !Counter, Var), term.coerce(A0, A), - Goal = unify_expr(A, term.variable(Var), purity_pure) - Context, + Goal = unify_expr(A, variable(Var, Context), purity_pure) - Context, MaybeGoal = ok1(Goal). parse_dcg_goal_2("if", [term.functor(term.atom("then"), [CondTerm, ThenTerm], _)], @@ -295,7 +296,7 @@ parse_dcg_goal_2("if", ( Var = Var0 -> Else = true_expr - Context ; - Unify = unify_expr(term.variable(Var), term.variable(Var0), + Unify = unify_expr(variable(Var, Context), variable(Var0, Context), purity_pure), Else = Unify - Context ), @@ -355,13 +356,15 @@ parse_dcg_goal_2(";", [ATerm, BTerm], Context, MaybeGoal, !VarSet, !Counter, Goal = disj_expr(AGoal0, BGoal0) - Context ; VarA = Var0 -> Var = VarB, - Unify = unify_expr(term.variable(Var), term.variable(VarA), + Unify = unify_expr( + term.variable(Var, Context), term.variable(VarA, Context), purity_pure), append_to_disjunct(AGoal0, Unify, Context, AGoal), Goal = disj_expr(AGoal, BGoal0) - Context ; VarB = Var0 -> Var = VarA, - Unify = unify_expr(term.variable(Var), term.variable(VarB), + Unify = unify_expr( + term.variable(Var, Context), term.variable(VarB, Context), purity_pure), append_to_disjunct(BGoal0, Unify, Context, BGoal), Goal = disj_expr(AGoal0, BGoal) - Context @@ -589,7 +592,8 @@ parse_dcg_if_then(CondTerm, ThenTerm, Context, MaybeVarsCond, MaybeThen, ( MaybeThen1 = ok1(Then1), new_dcg_var(!VarSet, !Counter, Var), - Unify = unify_expr(term.variable(Var), term.variable(Var2), + Unify = unify_expr( + term.variable(Var, Context), term.variable(Var2, Context), purity_pure), Then = conj_expr(Then1, Unify - Context) - Context, MaybeThen = ok1(Then) @@ -623,14 +627,16 @@ parse_dcg_if_then_else(CondTerm, ThenTerm, ElseTerm, Context, MaybeGoal, Else = Else1 ; VarThen = Var0 -> Var = VarElse, - Unify = unify_expr(term.variable(Var), term.variable(VarThen), + Unify = unify_expr( + term.variable(Var, Context), term.variable(VarThen, Context), purity_pure), Then = conj_expr(Then1, Unify - Context) - Context, Else = Else1 ; VarElse = Var0 -> Var = VarThen, Then = Then1, - Unify = unify_expr(term.variable(Var), term.variable(VarElse), + Unify = unify_expr( + term.variable(Var, Context), term.variable(VarElse, Context), purity_pure), Else = conj_expr(Else1, Unify - Context) - Context ; @@ -676,10 +682,10 @@ term_list_append_term(List0, Term, List) :- ). :- pred process_dcg_clause(maybe_functor::in, prog_varset::in, prog_var::in, - prog_var::in, goal::in, maybe1(item)::out) is det. + prog_var::in, goal::in, prog_context::in, maybe1(item)::out) is det. -process_dcg_clause(ok2(Name, Args0), VarSet, Var0, Var, Body, +process_dcg_clause(ok2(Name, Args0), VarSet, Var0, Var, Body, Context, ok1(item_clause(user, VarSet, predicate, Name, Args, Body))) :- list.map(term.coerce, Args0, Args1), - Args = Args1 ++ [term.variable(Var0), term.variable(Var)]. -process_dcg_clause(error2(Errors), _, _, _, _, error1(Errors)). + Args = Args1 ++ [variable(Var0, Context), variable(Var, Context)]. +process_dcg_clause(error2(Errors), _, _, _, _, _, error1(Errors)). diff --git a/compiler/prog_io_goal.m b/compiler/prog_io_goal.m index 7914258ce..6af9f52d7 100644 --- a/compiler/prog_io_goal.m +++ b/compiler/prog_io_goal.m @@ -107,8 +107,7 @@ parse_goal(Term, MaybeGoal, !VarSet) :- ( Term = term.functor(_, _, Context) ; - Term = term.variable(_), - term.context_init(Context) + Term = term.variable(_, Context) ), % We just check if it matches the appropriate pattern for one of the % builtins. If it doesn't match any of the builtins, then it's just @@ -647,7 +646,7 @@ parse_trace_params(Context, Term, MaybeComponentsTerms) :- Msg = "invalid trace goal paramater", MaybeComponentsTerms = error1([Msg - Term]) ; - Term = term.variable(_), + Term = term.variable(_, _), Msg = "expected trace goal paramater, found variable", ErrorTerm = term.functor(term.atom(""), [], Context), MaybeComponentsTerms = error1([Msg - ErrorTerm]) @@ -711,7 +710,7 @@ parse_trace_component(ErrorTerm, Term, MaybeComponentTerm) :- ( SubTerms = [SubTerm] -> ( SubTerm = term.functor(term.atom("!"), - [term.variable(Var)], _) + [term.variable(Var, _)], _) -> term.coerce_var(Var, ProgVar), Component = trace_component_maybe_io(ProgVar), @@ -737,7 +736,7 @@ parse_trace_component(ErrorTerm, Term, MaybeComponentTerm) :- SubTermA = term.functor(_, _, _), MutableErrorTerm = SubTermA ; - SubTermA = term.variable(_), + SubTermA = term.variable(_, _), MutableErrorTerm = Term ), MutableMsg = "the first argument of " ++ Atom ++ @@ -746,7 +745,7 @@ parse_trace_component(ErrorTerm, Term, MaybeComponentTerm) :- ), ( SubTermB = term.functor(term.atom("!"), - [term.variable(Var)], _) + [term.variable(Var, _)], _) -> MaybeVar = ok1(Var) ; @@ -754,7 +753,7 @@ parse_trace_component(ErrorTerm, Term, MaybeComponentTerm) :- SubTermB = term.functor(_, _, _), VarErrorTerm = SubTermB ; - SubTermB = term.variable(_), + SubTermB = term.variable(_, _), VarErrorTerm = Term ), VarMsg = "the second argument of " ++ Atom ++ @@ -789,7 +788,7 @@ parse_trace_component(ErrorTerm, Term, MaybeComponentTerm) :- MaybeComponentTerm = error1([Msg - Term]) ) ; - Term = term.variable(_), + Term = term.variable(_, _), Msg = "expected trace goal paramater, found variable", MaybeComponentTerm = error1([Msg - ErrorTerm]) ). @@ -904,7 +903,7 @@ parse_trace_compiletime(ErrorTerm, Term, MaybeCompiletime) :- MaybeCompiletime = error1([Msg - Term]) ) ; - Term = term.variable(_), + Term = term.variable(_, _), Msg = "expected compile_time paramater, found variable", MaybeCompiletime = error1([Msg - ErrorTerm]) ). @@ -956,7 +955,7 @@ parse_trace_runtime(ErrorTerm, Term, MaybeRuntime) :- MaybeRuntime = error1([Msg - Term]) ) ; - Term = term.variable(_), + Term = term.variable(_, _), Msg = "expected run_time paramater, found variable", MaybeRuntime = error1([Msg - ErrorTerm]) ). diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m index cf204e095..c25331d63 100644 --- a/compiler/prog_io_pragma.m +++ b/compiler/prog_io_pragma.m @@ -1823,7 +1823,7 @@ parse_pragma_c_code_varlist(_, [], [], no). parse_pragma_c_code_varlist(VarSet, [V|Vars], PragmaVars, Error):- ( V = term.functor(term.atom("::"), [VarTerm, ModeTerm], _), - VarTerm = term.variable(Var) + VarTerm = term.variable(Var, _) -> ( varset.search_name(VarSet, Var, VarName) -> ( convert_mode(allow_constrained_inst_var, ModeTerm, Mode0) -> @@ -2180,8 +2180,8 @@ convert_int_list(ListTerm, Result) :- :- pred convert_list(term::in, pred(term, T)::(pred(in, out) is semidet), string::in, maybe1(list(T))::out) is det. -convert_list(term.variable(V), _, UnrecognizedMsg, - error1([UnrecognizedMsg - term.variable(V)])). +convert_list(term.variable(V, C), _, UnrecognizedMsg, + error1([UnrecognizedMsg - term.variable(V, C)])). convert_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg, Result) :- ( @@ -2220,8 +2220,8 @@ convert_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg, pred(term, maybe1(T))::(pred(in, out) is semidet), string::in, maybe1(list(T))::out) is det. -convert_maybe_list(term.variable(V), _, UnrecognizedMsg, - error1([UnrecognizedMsg - term.variable(V)])). +convert_maybe_list(term.variable(V, C), _, UnrecognizedMsg, + error1([UnrecognizedMsg - term.variable(V, C)])). convert_maybe_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg, Result) :- ( @@ -2261,7 +2261,7 @@ convert_maybe_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg, convert_type_spec_pair(Term, TypeSpec) :- Term = term.functor(term.atom("="), [TypeVarTerm, SpecTypeTerm0], _), - TypeVarTerm = term.variable(TypeVar0), + TypeVarTerm = term.variable(TypeVar0, _), term.coerce_var(TypeVar0, TypeVar), parse_type(SpecTypeTerm0, ok1(SpecType)), TypeSpec = TypeVar - SpecType. diff --git a/compiler/prog_io_typeclass.m b/compiler/prog_io_typeclass.m index 0f8ad076d..7ce9f8604 100644 --- a/compiler/prog_io_typeclass.m +++ b/compiler/prog_io_typeclass.m @@ -233,7 +233,7 @@ parse_unconstrained_class(ModuleName, Name, TVarSet, Result) :- MaybeClassName = ok2(ClassName, TermVars0), list.map(term.coerce, TermVars0, TermVars), ( - term.var_list_to_term_list(Vars, TermVars), + term.term_list_to_var_list(TermVars, Vars), list.sort_and_remove_dups(TermVars, SortedTermVars), list.length(SortedTermVars) = list.length(TermVars) : int -> @@ -482,7 +482,7 @@ parse_arbitrary_constraint(ConstraintTerm, Result) :- parse_inst_constraint(Term, InstVar, Inst) :- Term = term.functor(term.atom("=<"), [Arg1, Arg2], _), - Arg1 = term.variable(InstVar0), + Arg1 = term.variable(InstVar0, _), term.coerce_var(InstVar0, InstVar), convert_inst(no_allow_constrained_inst_var, Arg2, Inst). @@ -506,7 +506,7 @@ parse_fundep(Term, Result) :- parse_fundep_2(Term, TVars) :- TypeTerm = term.coerce(Term), conjunction_to_list(TypeTerm, List), - term.var_list_to_term_list(TVars, List). + term.term_list_to_var_list(List, TVars). :- pred constraint_is_not_simple(prog_constraint::in) is semidet. diff --git a/compiler/prog_io_util.m b/compiler/prog_io_util.m index a82b3f3c4..71fbd5185 100644 --- a/compiler/prog_io_util.m +++ b/compiler/prog_io_util.m @@ -287,7 +287,7 @@ parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm, % parse_type(Term, Result) :- ( - Term = term.variable(Var0) + Term = term.variable(Var0, _) -> term.coerce_var(Var0, Var), Result = ok1(type_variable(Var, kind_star)) @@ -391,7 +391,7 @@ parse_purity_annotation(Term0, Purity, Term) :- Term = Term0 ). -unparse_type(type_variable(TVar, _), term.variable(Var)) :- +unparse_type(type_variable(TVar, _), term.variable(Var, context_init)) :- Var = term.coerce_var(TVar). unparse_type(defined_type(SymName, Args, _), Term) :- unparse_type_list(Args, ArgTerms), @@ -423,7 +423,7 @@ unparse_type(apply_n_type(TVar, Args, _), Term) :- Context = term.context_init, Var = term.coerce_var(TVar), unparse_type_list(Args, ArgTerms), - Term = term.functor(term.atom(""), [term.variable(Var) | ArgTerms], + Term = term.functor(term.atom(""), [term.variable(Var, Context) | ArgTerms], Context). unparse_type(kinded_type(_, _), _) :- unexpected(this_file, "prog_io_util: kind annotation"). @@ -522,7 +522,7 @@ convert_inst_list(AllowConstrainedInstVar, [H0 | T0], [H | T]) :- convert_inst(AllowConstrainedInstVar, H0, H), convert_inst_list(AllowConstrainedInstVar, T0, T). -convert_inst(_, term.variable(V0), inst_var(V)) :- +convert_inst(_, term.variable(V0, _), inst_var(V)) :- term.coerce_var(V0, V). convert_inst(AllowConstrainedInstVar, Term, Result) :- Term = term.functor(term.atom(Name), Args0, _Context), @@ -579,7 +579,7 @@ convert_inst(AllowConstrainedInstVar, Term, Result) :- Result) ; Name = "=<", Args0 = [VarTerm, InstTerm] -> AllowConstrainedInstVar = allow_constrained_inst_var, - VarTerm = term.variable(Var), + VarTerm = term.variable(Var, _), % Do not allow nested constrained_inst_vars. convert_inst(no_allow_constrained_inst_var, InstTerm, Inst), Result = constrained_inst_vars(set.make_singleton_set( @@ -752,14 +752,14 @@ combine_list_results(ok1(X), ok1(Xs), ok1([X | Xs])). parse_list_of_vars(term.functor(term.atom("[]"), [], _), []). parse_list_of_vars(term.functor(term.atom("[|]"), [Head, Tail], _), [V | Vs]) :- - Head = term.variable(V), + Head = term.variable(V, _), parse_list_of_vars(Tail, Vs). parse_vars(Term, MaybeVars) :- ( Term = functor(atom("[]"), [], _) -> MaybeVars = ok1([]) ; Term = functor(atom("[|]"), [Head, Tail], _) -> - ( Head = variable(V) -> + ( Head = variable(V, _) -> parse_vars(Tail, MaybeVarsTail), ( MaybeVarsTail = ok1(TailVars), @@ -784,11 +784,11 @@ parse_quantifier_vars(Term, MaybeQVars) :- ; Term = functor(atom("[|]"), [Head, Tail], _) -> ( ( - Head = functor(atom("!"), [variable(SV)], _), + Head = functor(atom("!"), [variable(SV, _)], _), HeadVars = [], HeadStateVars = [SV] ; - Head = variable(V), + Head = variable(V, _), HeadVars = [V], HeadStateVars = [] ) @@ -818,22 +818,22 @@ parse_vars_and_state_vars(Term, MaybeVars) :- ; Term = functor(atom("[|]"), [Head, Tail], _) -> ( ( - Head = functor(atom("!"), [variable(SV)], _), + Head = functor(atom("!"), [variable(SV, _)], _), HeadVars = [], HeadDotVars = [SV], HeadColonVars = [SV] ; - Head = functor(atom("!."), [variable(SV)], _), + Head = functor(atom("!."), [variable(SV, _)], _), HeadVars = [], HeadDotVars = [SV], HeadColonVars = [] ; - Head = functor(atom("!:"), [variable(SV)], _), + Head = functor(atom("!:"), [variable(SV, _)], _), HeadVars = [], HeadDotVars = [], HeadColonVars = [SV] ; - Head = variable(V), + Head = variable(V, _), HeadVars = [V], HeadDotVars = [], HeadColonVars = [] diff --git a/compiler/prog_mode.m b/compiler/prog_mode.m index 61b4393bd..af2657fbb 100644 --- a/compiler/prog_mode.m +++ b/compiler/prog_mode.m @@ -396,7 +396,7 @@ rename_apart_inst_vars_in_inst(Sub, ground(U, GI0), ground(U, GI)) :- ). rename_apart_inst_vars_in_inst(_, not_reached, not_reached). rename_apart_inst_vars_in_inst(Sub, inst_var(Var0), inst_var(Var)) :- - ( map.search(Sub, Var0, term.variable(Var1)) -> + ( map.search(Sub, Var0, term.variable(Var1, _)) -> Var = Var1 ; Var = Var0 @@ -405,7 +405,7 @@ rename_apart_inst_vars_in_inst(Sub, constrained_inst_vars(Vars0, Inst0), constrained_inst_vars(Vars, Inst)) :- rename_apart_inst_vars_in_inst(Sub, Inst0, Inst), Vars = set.map(func(Var0) = - ( map.search(Sub, Var0, term.variable(Var)) -> + ( map.search(Sub, Var0, term.variable(Var, _)) -> Var ; Var0 diff --git a/compiler/prog_type.m b/compiler/prog_type.m index 2701ffeb0..510119db3 100644 --- a/compiler/prog_type.m +++ b/compiler/prog_type.m @@ -754,7 +754,7 @@ is_builtin_dummy_argument_type("io", "state", 0). % io.state/0 is_builtin_dummy_argument_type("store", "store", 1). % store.store/1. constructor_list_represents_dummy_argument_type([Ctor], no) :- - Ctor = ctor([], [], _, []). + Ctor = ctor([], [], _, [], _). type_is_io_state(Type) :- type_to_ctor_and_args(Type, TypeCtor, []), @@ -943,7 +943,7 @@ type_constructors_are_type_info(Ctors) :- type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName, ArgType) :- Ctors = [SingleCtor], SingleCtor = ctor(ExistQVars, _Constraints, Ctor, - [MaybeArgName - ArgType]), + [ctor_arg(MaybeArgName, ArgType, _)], _Ctxt), ExistQVars = []. :- pred ctor_is_type_info(sym_name::in) is semidet. diff --git a/compiler/prog_util.m b/compiler/prog_util.m index 3b7d38385..6efabc013 100644 --- a/compiler/prog_util.m +++ b/compiler/prog_util.m @@ -469,16 +469,16 @@ rename_in_goal_expr(OldVar, NewVar, rename_in_goal_expr(OldVar, NewVar, event_expr(Name, Terms0), event_expr(Name, Terms)) :- - term.substitute_list(Terms0, OldVar, term.variable(NewVar), Terms). + term.substitute_list(Terms0, OldVar, variable(NewVar, context_init), Terms). rename_in_goal_expr(OldVar, NewVar, call_expr(SymName, Terms0, Purity), call_expr(SymName, Terms, Purity)) :- - term.substitute_list(Terms0, OldVar, term.variable(NewVar), Terms). + term.substitute_list(Terms0, OldVar, variable(NewVar, context_init), Terms). rename_in_goal_expr(OldVar, NewVar, unify_expr(TermA0, TermB0, Purity), unify_expr(TermA, TermB, Purity)) :- - term.substitute(TermA0, OldVar, term.variable(NewVar), TermA), - term.substitute(TermB0, OldVar, term.variable(NewVar), TermB). + term.substitute(TermA0, OldVar, term.variable(NewVar, context_init), TermA), + term.substitute(TermB0, OldVar, term.variable(NewVar, context_init), TermB). :- pred rename_in_trace_mutable_var(prog_var::in, prog_var::in, trace_mutable_var::in, trace_mutable_var::out) is det. @@ -779,8 +779,8 @@ substitute_vars(Vars0, Subst, Vars) :- :- func substitute_var(substitution(T), var(T)) = var(T). substitute_var(Subst, Var0) = Var :- - term.apply_substitution(term.variable(Var0), Subst, Term), - ( Term = term.variable(Var1) -> + term.apply_substitution(term.variable(Var0, context_init), Subst, Term), + ( Term = term.variable(Var1, _) -> Var = Var1 ; unexpected(this_file, "substitute_var: invalid substitution") diff --git a/compiler/recompilation.check.m b/compiler/recompilation.check.m index e3d62be88..cfe109896 100644 --- a/compiler/recompilation.check.m +++ b/compiler/recompilation.check.m @@ -1136,7 +1136,7 @@ check_type_defn_ambiguity_with_functor(_, _, parse_tree_solver_type(_, _), constructor::in, recompilation_check_info::in, recompilation_check_info::out) is det. -check_functor_ambiguities(NeedQualifier, TypeCtor, ctor(_, _, Name, Args), +check_functor_ambiguities(NeedQualifier, TypeCtor, ctor(_, _, Name, Args, _), !Info) :- TypeCtorItem = type_ctor_to_item_name(TypeCtor), ResolvedCtor = resolved_functor_constructor(TypeCtorItem), @@ -1152,9 +1152,9 @@ check_functor_ambiguities(NeedQualifier, TypeCtor, ctor(_, _, Name, Args), constructor_arg::in, recompilation_check_info::in, recompilation_check_info::out) is det. -check_field_ambiguities(_, _, no - _, !Info). -check_field_ambiguities(NeedQualifier, ResolvedCtor, yes(FieldName) - _, - !Info) :- +check_field_ambiguities(_, _, ctor_arg(no, _, _) , !Info). +check_field_ambiguities(NeedQualifier, ResolvedCtor, + ctor_arg(yes(FieldName), _, _), !Info) :- % XXX The arities to match below will need to change if we ever % allow taking the address of field access functions. field_access_function_name(get, FieldName, ExtractFuncName), diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m index 8bb2b8784..b2f5503a1 100644 --- a/compiler/recompilation.usage.m +++ b/compiler/recompilation.usage.m @@ -1068,7 +1068,7 @@ find_items_used_by_type_body(hlds_solver_type(_, _), !Info). recompilation_usage_info::in, recompilation_usage_info::out) is det. find_items_used_by_ctor(Ctor, !Info) :- - Ctor = ctor(_, Constraints, _, CtorArgs), + Ctor = ctor(_, Constraints, _, CtorArgs, _), find_items_used_by_class_constraints(Constraints, !Info), list.foldl(find_items_used_by_ctor_arg, CtorArgs, !Info). @@ -1076,7 +1076,7 @@ find_items_used_by_ctor(Ctor, !Info) :- recompilation_usage_info::in, recompilation_usage_info::out) is det. find_items_used_by_ctor_arg(CtorArg, !Info) :- - CtorArg = _ - ArgType, + ArgType = CtorArg ^ arg_type, find_items_used_by_type(ArgType, !Info). :- pred find_items_used_by_mode_defn(hlds_mode_defn::in, diff --git a/compiler/special_pred.m b/compiler/special_pred.m index 3cdfe9565..cfc2fe6e6 100644 --- a/compiler/special_pred.m +++ b/compiler/special_pred.m @@ -263,7 +263,7 @@ special_pred_for_type_needs_typecheck(ModuleInfo, SpecialPredId, Body) :- SpecialPredId \= spec_pred_init, Ctors = Body ^ du_type_ctors, list.member(Ctor, Ctors), - Ctor = ctor(ExistQTVars, _, _, _), + Ctor = ctor(ExistQTVars, _, _, _, _), ExistQTVars = [_ | _] ; SpecialPredId = spec_pred_init, diff --git a/compiler/state_var.m b/compiler/state_var.m index 5fe66fd66..76b1a511d 100644 --- a/compiler/state_var.m +++ b/compiler/state_var.m @@ -950,12 +950,12 @@ expand_bang_state_var_args(Args) = :- func expand_bang_state_var(prog_term, list(prog_term)) = list(prog_term). -expand_bang_state_var(T @ variable(_), Ts) = [T | Ts]. +expand_bang_state_var(T @ variable(_, _), Ts) = [T | Ts]. expand_bang_state_var(T @ functor(Const, Args, Ctxt), Ts) = ( Const = atom("!"), - Args = [variable(_StateVar)] + Args = [variable(_StateVar, _)] -> [functor(atom("!."), Args, Ctxt), functor(atom("!:"), Args, Ctxt) | Ts] ; @@ -1015,15 +1015,15 @@ substitute_state_var_mappings([Arg0 | Args0], [Arg | Args], !VarSet, !SInfo, substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !Specs) :- ( - Arg0 = functor(atom("!."), [variable(StateVar)], Context) + Arg0 = functor(atom("!."), [variable(StateVar, _)], Context) -> dot(Context, StateVar, Var, !VarSet, !SInfo, !Specs), - Arg = variable(Var) + Arg = variable(Var, context_init) ; - Arg0 = functor(atom("!:"), [variable(StateVar)], Context) + Arg0 = functor(atom("!:"), [variable(StateVar, _)], Context) -> colon(Context, StateVar, Var, !VarSet, !SInfo, !Specs), - Arg = variable(Var) + Arg = variable(Var, context_init) ; Arg = Arg0 ). @@ -1031,12 +1031,12 @@ substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !Specs) :- %-----------------------------------------------------------------------------% illegal_state_var_func_result(function, Args, StateVar) :- - list.last(Args, functor(atom("!"), [variable(StateVar)], _Ctxt)). + list.last(Args, functor(atom("!"), [variable(StateVar, _)], _Ctxt)). %-----------------------------------------------------------------------------% lambda_args_contain_bang_state_var([Arg | Args], StateVar) :- - ( Arg = functor(atom("!"), [variable(StateVar0)], _) -> + ( Arg = functor(atom("!"), [variable(StateVar0, _)], _) -> StateVar = StateVar0 ; lambda_args_contain_bang_state_var(Args, StateVar) diff --git a/compiler/superhomogeneous.m b/compiler/superhomogeneous.m index 7e5e4ba39..22ffb1c2c 100644 --- a/compiler/superhomogeneous.m +++ b/compiler/superhomogeneous.m @@ -307,14 +307,14 @@ do_insert_arg_unifications_with_supplied_contexts_2(Vars, Terms, ArgContexts, do_insert_arg_unification(Var, Arg, Context, ArgContext, N1, ArgUnifyConj, MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :- - ( Arg = term.variable(Var) -> + ( Arg = term.variable(Var, _) -> % Skip unifications of the form `X = X' ArgUnifyConj = [], NumAdded = 0 ; arg_context_to_unify_context(ArgContext, N1, UnifyMainContext, UnifySubContext), - do_unravel_unification(term.variable(Var), Arg, Context, + do_unravel_unification(term.variable(Var, Context), Arg, Context, UnifyMainContext, UnifySubContext, purity_pure, Goal, MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), @@ -384,14 +384,14 @@ do_append_arg_unifications_2([Var | Vars], [Arg | Args], Context, ArgContext, do_append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList, MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :- - ( Arg = term.variable(Var) -> + ( Arg = term.variable(Var, _) -> % Skip unifications of the form `X = X'. ConjList = [], NumAdded = 0 ; arg_context_to_unify_context(ArgContext, N1, UnifyMainContext, UnifySubContext), - do_unravel_unification(term.variable(Var), Arg, Context, + do_unravel_unification(term.variable(Var, Context), Arg, Context, UnifyMainContext, UnifySubContext, purity_pure, Goal, MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), @@ -418,7 +418,7 @@ do_unravel_unification(LHS0, RHS0, Context, MainContext, SubContext, Purity, ( MaybeThreshold = yes(Threshold), NumAdded > Threshold, - LHS = term.variable(X), + LHS = term.variable(X, _), ground_term(RHS) -> Goal0 = _ - GoalInfo, @@ -439,20 +439,20 @@ classify_unravel_unification(TermX, TermY, Context, MainContext, SubContext, !Specs) :- ( % `X = Y' needs no unravelling. - TermX = term.variable(X), - TermY = term.variable(Y), + TermX = term.variable(X, _), + TermY = term.variable(Y, _), make_atomic_unification(X, rhs_var(Y), Context, MainContext, SubContext, Purity, Goal, !QualInfo), NumAdded = 0 ; - TermX = term.variable(X), + TermX = term.variable(X, _), TermY = term.functor(F, Args, FunctorContext), unravel_var_functor_unification(X, F, Args, FunctorContext, Context, MainContext, SubContext, Purity, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) ; TermX = term.functor(F, Args, FunctorContext), - TermY = term.variable(Y), + TermY = term.variable(Y, _), unravel_var_functor_unification(Y, F, Args, FunctorContext, Context, MainContext, SubContext, Purity, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) @@ -465,10 +465,10 @@ classify_unravel_unification(TermX, TermY, Context, MainContext, SubContext, TermX = term.functor(_, _, _), TermY = term.functor(_, _, _), varset.new_var(!.VarSet, TmpVar, !:VarSet), - do_unravel_unification(term.variable(TmpVar), TermX, + do_unravel_unification(term.variable(TmpVar, Context), TermX, Context, MainContext, SubContext, Purity, GoalX, no, NumAddedX, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), - do_unravel_unification(term.variable(TmpVar), TermY, + do_unravel_unification(term.variable(TmpVar, Context), TermY, Context, MainContext, SubContext, Purity, GoalY, no, NumAddedY, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), goal_to_conj_list(GoalX, ConjListX), @@ -530,18 +530,18 @@ unravel_var_functor_unification(X, F, Args1, FunctorContext, report_error_in_type_qualification(GenericVarSet, Context), Errors, !Specs) ), - do_unravel_unification(term.variable(X), RVal, Context, MainContext, - SubContext, Purity, Goal, no, NumAdded, !VarSet, !ModuleInfo, - !QualInfo, !SInfo, !Specs) + do_unravel_unification(term.variable(X, Context), RVal, + Context, MainContext, SubContext, Purity, Goal, no, NumAdded, + !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) ; % Handle unification expressions. F = term.atom("@"), Args = [LVal, RVal] -> - do_unravel_unification(term.variable(X), LVal, Context, + do_unravel_unification(term.variable(X, Context), LVal, Context, MainContext, SubContext, Purity, Goal1, no, NumAdded1, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), - do_unravel_unification(term.variable(X), RVal, Context, + do_unravel_unification(term.variable(X, Context), RVal, Context, MainContext, SubContext, Purity, Goal2, no, NumAdded2, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), NumAdded = NumAdded1 + NumAdded2, @@ -603,7 +603,8 @@ unravel_var_functor_unification(X, F, Args1, FunctorContext, parse_dcg_pred_goal(GoalTerm, MaybeParsedGoal, DCG0, DCGn, !VarSet), ( MaybeParsedGoal = ok1(ParsedGoal), - Vars1 = Vars0 ++ [term.variable(DCG0), term.variable(DCGn)], + Vars1 = Vars0 ++ + [term.variable(DCG0, Context), term.variable(DCGn, Context)], build_lambda_expression(X, Purity, DCGLambdaPurity, predicate, EvalMethod, Vars1, Modes, Det, ParsedGoal, Context, MainContext, SubContext, Goal0, NumAdded, !VarSet, !ModuleInfo, !QualInfo, @@ -646,13 +647,13 @@ unravel_var_functor_unification(X, F, Args1, FunctorContext, finish_if_then_else_expr_condition(BeforeSInfo, !SInfo), - do_unravel_unification(term.variable(X), ThenTerm, + do_unravel_unification(term.variable(X, Context), ThenTerm, Context, MainContext, SubContext, Purity, ThenGoal, no, ThenAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), finish_if_then_else_expr_then_goal(StateVars, BeforeSInfo, !SInfo), - do_unravel_unification(term.variable(X), ElseTerm, + do_unravel_unification(term.variable(X, Context), ElseTerm, Context, MainContext, SubContext, Purity, ElseGoal, no, ElseAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs), @@ -1061,7 +1062,7 @@ make_fresh_arg_vars_2([Arg | Args], Vars0, Vars, !VarSet, !SInfo, !Specs) :- make_fresh_arg_var(Arg0, Var, Vars0, !VarSet, !SInfo, !Specs) :- substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !Specs), ( - Arg = term.variable(ArgVar), + Arg = term.variable(ArgVar, _), \+ list.member(ArgVar, Vars0) -> Var = ArgVar diff --git a/compiler/switch_detection.m b/compiler/switch_detection.m index cb4bbea89..6e18cfa8b 100644 --- a/compiler/switch_detection.m +++ b/compiler/switch_detection.m @@ -605,10 +605,10 @@ find_bind_var_2(Var, ProcessUnify, Goal0, Goal, !Subst, !Result, !Info, % Check whether the unification is a deconstruction unification % on either Var or on a variable aliased to Var. UnifyInfo0 = deconstruct(UnifyVar, _, _, _, _, _), - term.apply_rec_substitution(term.variable(Var), - !.Subst, term.variable(SubstVar)), - term.apply_rec_substitution(term.variable(UnifyVar), - !.Subst, term.variable(SubstUnifyVar)), + term.apply_rec_substitution(term.variable(Var, context_init), + !.Subst, term.variable(SubstVar, context_init)), + term.apply_rec_substitution(term.variable(UnifyVar, context_init), + !.Subst, term.variable(SubstUnifyVar, context_init)), SubstVar = SubstUnifyVar -> call(ProcessUnify, Var, Goal0, Goals, !Result, !Info), diff --git a/compiler/term_constr_build.m b/compiler/term_constr_build.m index 38df2b3b4..ae97cc777 100644 --- a/compiler/term_constr_build.m +++ b/compiler/term_constr_build.m @@ -1101,7 +1101,7 @@ find_deconstruct_fail_bound(unify(_, _, _, Kind, _), Info, Polyhedron) :- "find_deconstruct_fail_bound/3: non cons cons_id.") ), FindComplement = (pred(Ctor::in) is semidet :- - Ctor = ctor(_, _, SymName, Args), + Ctor = ctor(_, _, SymName, Args, _), list.length(Args, Arity), not ( SymName = ConsName, @@ -1155,7 +1155,7 @@ bounds_on_var(Norm, ModuleInfo, TypeCtor, Var, Constructors, Polyhedron) :- :- func lower_bound(functor_info, module_info, type_ctor, constructor) = int. lower_bound(Norm, Module, TypeCtor, Constructor) = LowerBound :- - Constructor = ctor(_, _, SymName, Args), + Constructor = ctor(_, _, SymName, Args, _), Arity = list.length(Args), ConsId = cons(SymName, Arity), LowerBound = functor_lower_bound(Norm, TypeCtor, ConsId, Module). @@ -1179,8 +1179,9 @@ upper_bound_constraints(Norm, Module, Var, TypeCtor, Ctors, Constraints) :- % finite size but I'm not sure that it's worth it. % FindUpperBound = (pred(Ctor::in, !.B::in, !:B::out) is semidet :- - Ctor = ctor(_, _, SymName, Args), - all [Arg] (list.member(Arg, Args) => zero_size_type(Module, snd(Arg))), + Ctor = ctor(_, _, SymName, Args, _), + all [Arg] (list.member(Arg, Args) => + zero_size_type(Module, Arg ^ arg_type)), Arity = list.length(Args), ConsId = cons(SymName, Arity), Bound = functor_lower_bound(Norm, TypeCtor, ConsId, Module), diff --git a/compiler/term_norm.m b/compiler/term_norm.m index 0cd77dc3c..c3a2f71bd 100644 --- a/compiler/term_norm.m +++ b/compiler/term_norm.m @@ -181,7 +181,7 @@ find_weights_for_type(TypeCtor - TypeDefn, !Weights) :- % of counted arguments. find_weights_for_cons(TypeCtor, Params, Ctor, !Weights) :- - Ctor = ctor(_ExistQVars, _Constraints, SymName, Args), + Ctor = ctor(_ExistQVars, _Constraints, SymName, Args, _), list.length(Args, Arity), ( Arity > 0 -> find_and_count_nonrec_args(Args, TypeCtor, Params, @@ -226,7 +226,7 @@ find_and_count_nonrec_args([Arg | Args], Id, Params, NonRecArgs, ArgInfo) :- list(type_param)::in) is semidet. is_arg_recursive(Arg, TypeCtor, Params) :- - Arg = _Name - ArgType, + ArgType = Arg ^ arg_type, type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeArgs), TypeCtor = ArgTypeCtor, prog_type.type_list_to_var_list(ArgTypeArgs, ArgTypeParams), diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m index adbfe74f6..d1d24632f 100644 --- a/compiler/type_ctor_info.m +++ b/compiler/type_ctor_info.m @@ -601,7 +601,7 @@ make_enum_details(Ctors, ConsTagMap, ReserveTag, EqualityAxioms, Details) :- make_enum_functors([], _, _, []). make_enum_functors([Functor | Functors], NextOrdinal0, ConsTagMap, [EnumFunctor | EnumFunctors]) :- - Functor = ctor(ExistTvars, Constraints, SymName, FunctorArgs), + Functor = ctor(ExistTvars, Constraints, SymName, FunctorArgs, _Context), expect(unify(ExistTvars, []), this_file, "existential arguments in functor in enum"), expect(unify(Constraints, []), this_file, @@ -695,7 +695,7 @@ make_du_details(Ctors, ConsTagMap, TypeArity, EqualityAxioms, ModuleInfo, make_maybe_res_functors([], _, _, _, _, []). make_maybe_res_functors([Functor | Functors], NextOrdinal, ConsTagMap, TypeArity, ModuleInfo, [MaybeResFunctor | MaybeResFunctors]) :- - Functor = ctor(ExistTvars, Constraints, SymName, ConstructorArgs), + Functor = ctor(ExistTvars, Constraints, SymName, ConstructorArgs, _Context), list.length(ConstructorArgs, Arity), FunctorName = unqualify_name(SymName), ConsId = make_cons_id_from_qualified_sym_name(SymName, ConstructorArgs), @@ -774,7 +774,7 @@ process_cons_tag(ConsTag, ConsRep) :- du_arg_info::out) is det. generate_du_arg_info(NumUnivTvars, ExistTvars, ConstructorArg, ArgInfo) :- - ConstructorArg = MaybeArgSymName - ArgType, + ConstructorArg = ctor_arg(MaybeArgSymName, ArgType, _Ctxt), ( MaybeArgSymName = yes(SymName), ArgName = unqualify_name(SymName), diff --git a/compiler/type_util.m b/compiler/type_util.m index 610ce3f8f..240f1f15c 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -315,6 +315,7 @@ :- import_module int. :- import_module map. :- import_module pair. +:- import_module term. %-----------------------------------------------------------------------------% @@ -608,9 +609,11 @@ type_constructors(Type, ModuleInfo, Constructors) :- % Tuples are never existentially typed. ExistQVars = [], ClassConstraints = [], - CtorArgs = list.map((func(ArgType) = no - ArgType), TypeArgs), + Context = term.context_init, + CtorArgs = list.map( + (func(ArgType) = ctor_arg(no, ArgType, Context)), TypeArgs), Constructors = [ctor(ExistQVars, ClassConstraints, unqualified("{}"), - CtorArgs)] + CtorArgs, Context)] ; module_info_get_type_table(ModuleInfo, TypeTable), map.search(TypeTable, TypeCtor, TypeDefn), @@ -646,17 +649,18 @@ substitute_type_args_2(Subst, [Ctor0 | Ctors0], [Ctor | Ctors]) :- % 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), + Ctor0 = ctor(ExistQVars, Constraints, Name, Args0, Ctxt), substitute_type_args_3(Subst, Args0, Args), substitute_type_args_2(Subst, Ctors0, Ctors), - Ctor = ctor(ExistQVars, Constraints, Name, Args). + Ctor = ctor(ExistQVars, Constraints, Name, Args, Ctxt). :- pred substitute_type_args_3(tsubst::in, list(constructor_arg)::in, list(constructor_arg)::out) is det. substitute_type_args_3(_, [], []). -substitute_type_args_3(Subst, [Name - Arg0 | Args0], [Name - Arg | Args]) :- - apply_subst_to_type(Subst, Arg0, Arg), +substitute_type_args_3(Subst, [Arg0 | Args0], [Arg | Args]) :- + apply_subst_to_type(Subst, Arg0 ^ arg_type, ArgType), + Arg = Arg0 ^ arg_type := ArgType, substitute_type_args_3(Subst, Args0, Args). %-----------------------------------------------------------------------------% @@ -732,7 +736,7 @@ get_cons_id_arg_types_2(EQVarAction, ModuleInfo, VarType, ConsId, ArgTypes) :- ), map.from_corresponding_lists(TypeParams, TypeArgs, TSubst), - assoc_list.values(Args, ArgTypes0), + ArgTypes0 = list.map(func(C) = C ^ arg_type, Args), apply_subst_to_type_list(TSubst, ArgTypes0, ArgTypes) ; ArgTypes = [] @@ -760,7 +764,7 @@ cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :- hlds_data.get_type_defn_tparams(TypeDefn, TypeParams), map.from_corresponding_lists(TypeParams, TypeArgs, TSubst), - assoc_list.values(Args, ArgTypes0), + ArgTypes0 = list.map(func(C) = C ^ arg_type, Args), apply_subst_to_type_list(TSubst, ArgTypes0, ArgTypes). is_existq_cons(ModuleInfo, VarType, ConsId) :- @@ -804,7 +808,7 @@ get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn) :- get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :- is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn), ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, _, _), - assoc_list.values(Args, ArgTypes), + ArgTypes = list.map(func(C) = C ^ arg_type, Args), module_info_get_type_table(ModuleInfo, Types), type_to_ctor_and_args(VarType, TypeCtor, _), map.lookup(Types, TypeCtor, TypeDefn), diff --git a/compiler/typecheck.m b/compiler/typecheck.m index 9e205a71e..a94a25c87 100644 --- a/compiler/typecheck.m +++ b/compiler/typecheck.m @@ -2292,7 +2292,7 @@ get_cons_stuff(ConsDefn, TypeAssign0, _Info, ConsType, ArgTypes, TypeAssign) :- apply_substitution_to_var_list(Vars0, RenameSubst, Vars) :- term.var_list_to_term_list(Vars0, Terms0), term.apply_substitution_to_list(Terms0, RenameSubst, Terms), - term.term_list_to_var_list(Terms, Vars). + Vars = term.term_list_to_var_list(Terms). :- pred apply_var_renaming_to_var_list(list(var(T))::in, map(var(T), var(T))::in, list(var(T))::out) is det. @@ -3025,7 +3025,7 @@ convert_cons_defn_list(Info, GoalPath, Action, [X | Xs], [Y | Ys]) :- convert_cons_defn(Info, GoalPath, Action, HLDS_ConsDefn, ConsTypeInfo) :- HLDS_ConsDefn = hlds_cons_defn(ExistQVars0, ExistProgConstraints, Args, TypeCtor, _), - assoc_list.values(Args, ArgTypes), + ArgTypes = list.map(func(C) = C ^ arg_type, Args), typecheck_info_get_types(Info, Types), map.lookup(Types, TypeCtor, TypeDefn), hlds_data.get_type_defn_tvarset(TypeDefn, ConsTypeVarSet), diff --git a/compiler/typecheck_errors.m b/compiler/typecheck_errors.m index f4c4b154c..a55e6baaf 100644 --- a/compiler/typecheck_errors.m +++ b/compiler/typecheck_errors.m @@ -1787,7 +1787,8 @@ maybe_add_existential_quantifier(HeadTypeParams, !Term) :- make_list_term([]) = term.functor(term.atom("[]"), [], term.context_init). make_list_term([Var | Vars]) = term.functor(term.atom("[|]"), - [term.variable(Var), make_list_term(Vars)], term.context_init). + [term.variable(Var, context_init), make_list_term(Vars)], + term.context_init). %-----------------------------------------------------------------------------% diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m index 6b8fdd0a8..0d7717c8b 100644 --- a/compiler/unify_proc.m +++ b/compiler/unify_proc.m @@ -511,10 +511,11 @@ add_lazily_generated_unify_pred(TypeCtor, PredId, !ModuleInfo) :- ExistQVars = [], ClassConstraints = [], - MakeUnamedField = (func(ArgType) = no - ArgType), + MakeUnamedField = (func(ArgType) = ctor_arg(no, ArgType, Context)), CtorArgs = list.map(MakeUnamedField, TupleArgTypes), - Ctor = ctor(ExistQVars, ClassConstraints, CtorSymName, CtorArgs), + Ctor = ctor(ExistQVars, + ClassConstraints, CtorSymName, CtorArgs, Context), CtorSymName = unqualified("{}"), ConsId = cons(CtorSymName, TupleArity), @@ -1283,7 +1284,7 @@ quantify_clause_body(HeadVars, Goal0, Context, Clause, !Info) :- generate_du_unify_clauses([], _X, _Y, _Context, [], !Info). generate_du_unify_clauses([Ctor | Ctors], X, Y, Context, [Clause | Clauses], !Info) :- - Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes), + Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes, _Ctxt), list.length(ArgTypes, FunctorArity), FunctorConsId = cons(FunctorName, FunctorArity), ( @@ -1360,7 +1361,7 @@ can_compare_constants_as_ints(Info) = CanCompareAsInt :- generate_du_index_clauses([], _X, _Index, _Context, _N, [], !Info). generate_du_index_clauses([Ctor | Ctors], X, Index, Context, N, [Clause | Clauses], !Info) :- - Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes), + Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes, _Ctxt), list.length(ArgTypes, FunctorArity), FunctorConsId = cons(FunctorName, FunctorArity), make_fresh_vars(ArgTypes, ExistQTVars, ArgVars, !Info), @@ -1662,7 +1663,7 @@ generate_compare_cases([Ctor | Ctors], R, X, Y, Context, [Case | Cases], hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_case(Ctor, R, X, Y, Context, Kind, Case, !Info) :- - Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes), + Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes, _Ctxt), list.length(ArgTypes, FunctorArity), FunctorConsId = cons(FunctorName, FunctorArity), ( @@ -1708,8 +1709,8 @@ generate_compare_case(Ctor, R, X, Y, Context, Kind, Case, !Info) :- generate_asymmetric_compare_case(Ctor1, Ctor2, CompareOp, R, X, Y, Context, Case, !Info) :- - Ctor1 = ctor(ExistQTVars1, _Constraints1, FunctorName1, ArgTypes1), - Ctor2 = ctor(ExistQTVars2, _Constraints2, FunctorName2, ArgTypes2), + Ctor1 = ctor(ExistQTVars1, _Constraints1, FunctorName1, ArgTypes1, _Ctxt1), + Ctor2 = ctor(ExistQTVars2, _Constraints2, FunctorName2, ArgTypes2, _Ctxt2), list.length(ArgTypes1, FunctorArity1), list.length(ArgTypes2, FunctorArity2), FunctorConsId1 = cons(FunctorName1, FunctorArity1), @@ -1773,11 +1774,13 @@ compare_args(ArgTypes, ExistQTVars, Xs, Ys, R, Context, Goal, !Info) :- compare_args_2([], _, [], [], R, Context, Return_Equal, !Info) :- generate_return_equal(R, Context, Return_Equal). -compare_args_2([_Name - Type | ArgTypes], ExistQTVars, [X | Xs], [Y | Ys], R, +compare_args_2([Arg | ArgTypes], ExistQTVars, [X | Xs], [Y | Ys], R, Context, Goal, !Info) :- goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), + Type = Arg ^ arg_type, + % When comparing existentially typed arguments, the arguments may have % different types; in that case, rather than just comparing them, % which would be a type error, we call `typed_compare', which is a builtin @@ -1906,7 +1909,7 @@ make_fresh_vars_from_types([Type | Types], [Var | Vars], !Info) :- make_fresh_vars(CtorArgs, ExistQTVars, Vars, !Info) :- ( ExistQTVars = [], - assoc_list.values(CtorArgs, ArgTypes), + ArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs), make_fresh_vars_from_types(ArgTypes, Vars, !Info) ; ExistQTVars = [_ | _], @@ -1939,8 +1942,9 @@ unify_var_lists(ArgTypes, ExistQVars, Vars1, Vars2, Goal, !Info) :- unify_proc_info::in, unify_proc_info::out) is semidet. unify_var_lists_2([], _, [], [], [], !Info). -unify_var_lists_2([_Name - Type | ArgTypes], ExistQTVars, [X | Xs], [Y | Ys], +unify_var_lists_2([Arg | ArgTypes], ExistQTVars, [X | Xs], [Y | Ys], [Goal | Goals], !Info) :- + Type = Arg ^ arg_type, term.context_init(Context), ( info_get_module_info(!.Info, ModuleInfo), diff --git a/compiler/untupling.m b/compiler/untupling.m index 29d1cffc6..8fba0b32e 100644 --- a/compiler/untupling.m +++ b/compiler/untupling.m @@ -754,7 +754,7 @@ expand_type(Type, ContainerTypes, TypeTable, Expansion) :- -> Arity = list.length(SingleCtorArgs), ConsId = cons(SingleCtorName, Arity), - ExpandedTypes = list.map(snd, SingleCtorArgs), + ExpandedTypes = list.map(func(C) = C ^ arg_type, SingleCtorArgs), Expansion = expansion(ConsId, ExpandedTypes) ; Expansion = no_expansion diff --git a/compiler/unused_imports.m b/compiler/unused_imports.m index ff9ba83e5..ca85138c0 100644 --- a/compiler/unused_imports.m +++ b/compiler/unused_imports.m @@ -218,12 +218,13 @@ type_used_modules(_TypeCtor, TypeDefn, !UsedModules) :- :- pred ctor_used_modules(item_visibility::in, constructor::in, used_modules::in, used_modules::out) is det. -ctor_used_modules(Visibility, ctor(_, Constraints, _, Args), !UsedModules) :- +ctor_used_modules(Visibility, + ctor(_, Constraints, _, Args, _), !UsedModules) :- list.foldl(prog_constraint_used_module(Visibility), Constraints, !UsedModules), list.foldl( - (pred(_ - Arg::in, !.M::in, !:M::out) is det :- - mer_type_used_modules(Visibility, Arg, !M) + (pred(Arg::in, !.M::in, !:M::out) is det :- + mer_type_used_modules(Visibility, Arg ^ arg_type, !M) ), Args, !UsedModules). :- pred prog_constraint_used_module(item_visibility::in, prog_constraint::in, diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m new file mode 100644 index 000000000..47685f87b --- /dev/null +++ b/compiler/xml_documentation.m @@ -0,0 +1,452 @@ +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% +% Copyright (C) 2006 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. +%-----------------------------------------------------------------------------% +% +% Module: xml_documentation.m +% Main authors: petdr. +% +% This module outputs an XML representation of a module, +% which can then be transformed by a stylesheet into some other +% documentation format. +% +%-----------------------------------------------------------------------------% + +:- module check_hlds.xml_documentation. + +:- interface. + +:- import_module hlds. +:- import_module hlds.hlds_module. + +:- import_module io. + + % + % Output a representation of the module in XML which can be used + % to document the module. + % +:- pred xml_documentation(module_info::in, io::di, io::uo) is det. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- import_module hlds.hlds_data. +:- import_module hlds.hlds_pred. +:- import_module libs. +:- import_module libs.compiler_util. +:- import_module mdbcomp. +:- import_module mdbcomp.prim_data. +:- import_module parse_tree. +:- import_module parse_tree.error_util. +:- import_module parse_tree.modules. +:- import_module parse_tree.prog_data. +:- import_module parse_tree.source_file_map. + +:- import_module bool. +:- import_module char. +:- import_module int. +:- import_module list. +:- import_module map. +:- import_module maybe. +:- import_module pair. +:- import_module string. +:- import_module svmap. +:- import_module term. +:- import_module term_to_xml. +:- import_module varset. + + % + % Record all the locations of comments in a file. + % +:- type comments + ---> comments( + % For each line record what is on the line. + line_types :: map(int, line_type) + ). + +:- type line_type + % A line containing only whitespace. + ---> blank + + % A line containing just a comment. + ; comment(string) + + % A line which contains both a comment and code. + ; code_and_comment(string) + + % A line containing code. + ; code + . + +%-----------------------------------------------------------------------------% + +xml_documentation(ModuleInfo, !IO) :- + module_info_get_name(ModuleInfo, ModuleName), + module_name_to_file_name(ModuleName, ".xml", no, FileName, !IO), + + lookup_module_source_file(ModuleName, SrcFileName, !IO), + io.open_input(SrcFileName, SrcResult, !IO), + ( + SrcResult = ok(SrcStream), + build_comments(SrcStream, comments(map.init), Comments, !IO), + + io.open_output(FileName, OpenResult, !IO), + ( + OpenResult = ok(Stream), + ModuleInfoXmlDoc = module_info_xml_doc(Comments, ModuleInfo), + write_xml_doc(Stream, ModuleInfoXmlDoc, !IO) + ; + OpenResult = error(Err), + unable_to_open_file(FileName, Err, !IO) + ) + ; + SrcResult = error(SrcErr), + unable_to_open_file(SrcFileName, SrcErr, !IO) + ). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + + % + % Given the input_stream build the comments datastructure which + % represents this stream. + % +:- pred build_comments(io.input_stream::in, comments::in, comments::out, + io::di, io::uo) is det. + +build_comments(S, comments(!.C), comments(!:C), !IO) :- + io.get_line_number(S, LineNumber, !IO), + io.read_line(S, LineResult, !IO), + ( + LineResult = ok(Line), + svmap.set(LineNumber, line_type(Line), !C), + build_comments(S, comments(!.C), comments(!:C), !IO) + ; + LineResult = eof, + true + ; + LineResult = error(E), + % XXX we should recover more gracefully from this error. + unexpected("xml_documentation.m", io.error_message(E)) + ). + + % + % Given a list of characters representing one line + % return the type of the line. + % + % Note this predicate is pretty stupid at the moment. + % It only recognizes lines which contains % comments. + % It also is confused by % characters in strings, etc. etc. + % +:- func line_type(list(character)) = line_type. + +line_type(Line) = LineType :- + list.takewhile(char.is_whitespace, Line, _WhiteSpace, Rest), + list.takewhile(is_not_comment_char, Rest, Decl, Comment), + ( Rest = [] -> + LineType = blank + ; Comment = [_ | _] -> + ( Decl = [], + LineType = comment(string.from_char_list(Comment)) + ; Decl = [_ | _], + LineType = code_and_comment(string.from_char_list(Comment)) + ) + ; + LineType = code + ). + +:- pred is_not_comment_char(char::in) is semidet. + +is_not_comment_char(C) :- + C \= '%'. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +% Comment selection strategies + + % + % Get the XML representation of the comment associated + % with the given prog_context. + % +:- func comment(comments, prog_context) = xml. + +comment(Comments, Context) = + elem("comment", [], [cdata(get_comment(Comments, Context))]). + + % + % Get the comment string associated with the given prog_context. + % +:- func get_comment(comments, prog_context) = string. + +get_comment(Comments, context(_, Line)) = + % + % XXX at a later date this hard-coded strategy should + % be made more flexible. What I imagine is that the + % user would pass a string saying in what order + % they wish to search for comments. + % + ( comment_on_current_line(Comments, Line, C) -> + C + ; comment_directly_above(Comments, Line, C) -> + C + ; + "" + ). + +%-----------------------------------------------------------------------------% + + % + % Succeeds if the current line has a comment. + % The comment is extended with all the lines following + % the current line which just contain a comment. + % +:- pred comment_on_current_line(comments::in, int::in, string::out) is semidet. + +comment_on_current_line(Comments, Line, Comment) :- + map.search(Comments ^ line_types, Line, code_and_comment(Comment0)), + RestComment = get_comment_forwards(Comments, Line + 1), + Comment = Comment0 ++ RestComment. + + % + % Succeeds if the comment is directly above the current line. + % The comment above ends when we find a line above the current + % line which doesn't just contain a comment. + % +:- pred comment_directly_above(comments::in, int::in, string::out) is semidet. + +comment_directly_above(Comments, Line, Comment) :- + map.search(Comments ^ line_types, Line - 1, comment(_)), + Comment = get_comment_backwards(Comments, Line - 1). + + % + % Return the string which represents the comment starting at the given + % line. The comment ends when a line which is not a plain comment line + % is found. + % +:- func get_comment_forwards(comments, int) = string. + +get_comment_forwards(Comments, Line) = Comment :- + LineType = map.lookup(Comments ^ line_types, Line), + ( + LineType = comment(CurrentComment), + CommentBelow = get_comment_backwards(Comments, Line + 1), + Comment = CurrentComment ++ CommentBelow + ; + ( LineType = blank + ; LineType = code + ; LineType = code_and_comment(_) + ), + Comment = "" + ). + + % + % Return the string which represents the comment ending at the given line. + % The comment extends backwards until the the line above the given + % line is not a comment only line. + % +:- func get_comment_backwards(comments, int) = string. + +get_comment_backwards(Comments, Line) = Comment :- + LineType = map.lookup(Comments ^ line_types, Line), + ( + LineType = comment(CurrentComment), + CommentAbove = get_comment_backwards(Comments, Line - 1), + Comment = CommentAbove ++ CurrentComment + ; + ( LineType = blank + ; LineType = code + ; LineType = code_and_comment(_) + ), + Comment = "" + ). + + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- type module_info_xml_doc + ---> module_info_xml_doc(comments, module_info). + +:- instance xmlable(module_info_xml_doc) where [ + (to_xml(module_info_xml_doc(Comments, ModuleInfo)) = Xml :- + module_info_get_type_table(ModuleInfo, TypeTable), + map.foldl(type_documentation(Comments), TypeTable, [], TypeXmls), + TypeXml = elem("types", [], TypeXmls), + Xml = elem("module", [], [TypeXml]) + ) +]. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + + % + % Output the documentation of one type. + % +:- pred type_documentation(comments::in, type_ctor::in, hlds_type_defn::in, + list(xml)::in, list(xml)::out) is det. + +type_documentation(C, type_ctor(TypeName, TypeArity), TypeDefn, !Xmls) :- + get_type_defn_status(TypeDefn, ImportStatus), + + ( status_defined_in_this_module(ImportStatus) = yes -> + get_type_defn_body(TypeDefn, TypeBody), + get_type_defn_tvarset(TypeDefn, TVarset), + get_type_defn_context(TypeDefn, Context), + + XmlComment = comment(C, Context), + + Tag = type_xml_tag(TypeBody), + Id = attr("id", sym_name_and_arity_to_id("type", TypeName, TypeArity)), + Children = [XmlComment, prog_context(Context) | + type_body(C, TVarset, TypeBody)], + Xml = elem(Tag, [Id], Children), + + !:Xmls = [Xml | !.Xmls] + ; + true + ). + +:- func type_xml_tag(hlds_type_body) = string. + +type_xml_tag(hlds_du_type(_, _, _, _, _, _)) = "du_type". +type_xml_tag(hlds_eqv_type(_)) = "eqv_type". +type_xml_tag(hlds_foreign_type(_)) = "foreign_type". +type_xml_tag(hlds_solver_type(_, _)) = "solver_type". +type_xml_tag(hlds_abstract_type(_)) = "abstract_type". + +:- func type_body(comments, tvarset, hlds_type_body) = list(xml). + +type_body(C, TVarset, hlds_du_type(Ctors, _, _, _, _, _)) = Xml :- + Xml = [xml_list("constructors", constructor(C, TVarset), Ctors)]. + + % XXX TODO +type_body(_, _, hlds_eqv_type(_)) = [nyi("hlds_eqv_type")]. +type_body(_, _, hlds_foreign_type(_)) = [nyi("hlds_foreign_type")]. +type_body(_, _, hlds_solver_type(_, _)) = [nyi("hlds_solver_type")]. +type_body(_, _, hlds_abstract_type(_)) = [nyi("hlds_abstract_type")]. + + +:- func constructor(comments, tvarset, constructor) = xml. + +constructor(C, TVarset, + ctor(_Exist, _Constraints, Name, Args, Context)) = Xml :- + Id = attr("id", sym_name_and_arity_to_id("cons", Name, length(Args))), + XmlName = name(Name), + XmlComment = comment(C, Context), + XmlContext = prog_context(Context), + XmlArgs = [xml_list("args", constructor_arg(C, TVarset), Args)], + Xml = elem("constructor", [Id], + [XmlName, XmlComment, XmlContext | XmlArgs]). + +:- func constructor_arg(comments, tvarset, constructor_arg) = xml. + +constructor_arg(C, TVarset, ctor_arg(MaybeFieldName, Type, Context)) = Xml :- + XmlType = elem("type", [], [mer_type(TVarset, Type)]), + Comment = comment(C, Context), + XmlContext = prog_context(Context), + ( + MaybeFieldName = yes(FieldName), + Id = attr("Id", sym_name_to_id("field", FieldName)), + XmlMaybeFieldName = [elem("field", [Id], [name(FieldName)])] + ; + MaybeFieldName = no, + XmlMaybeFieldName = [] + ), + + Xml = elem("arg", [], [XmlType, Comment, XmlContext | XmlMaybeFieldName]). + +:- func mer_type(tvarset, mer_type) = xml. + +mer_type(TVarset, type_variable(TVar, _)) = Xml :- + TVarName = varset.lookup_name(TVarset, TVar), + Xml = tagged_string("type_variable", TVarName). +mer_type(TVarset, defined_type(TypeName, Args, _)) = Xml :- + Ref = attr("ref", sym_name_and_arity_to_id("type", TypeName, length(Args))), + XmlName = name(TypeName), + XmlArgs = xml_list("args", mer_type(TVarset), Args), + Xml = elem("type", [Ref], [XmlName, XmlArgs]). +mer_type(_, builtin_type(builtin_type_int)) = elem("int", [], []). +mer_type(_, builtin_type(builtin_type_float)) = elem("float", [], []). +mer_type(_, builtin_type(builtin_type_string)) = elem("string", [], []). +mer_type(_, builtin_type(builtin_type_character)) = elem("character", [], []). +mer_type(_, higher_order_type(_, _, _, _)) = nyi("higher_order_type"). +mer_type(_, tuple_type(_, _)) = nyi("tuple_type"). +mer_type(_, apply_n_type(_, _, _)) = nyi("apply_n_type"). +mer_type(_, kinded_type(_, _)) = nyi("kinded_type"). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- func name(sym_name) = xml. + +name(unqualified(Name)) = tagged_string("unqualified", Name). +name(qualified(Module, Name)) = + elem("qualified", [], [ + tagged_string("module", sym_name_to_string(Module)), + tagged_string("name", Name)]). + +%-----------------------------------------------------------------------------% + +:- func prog_context(prog_context) = xml. + +prog_context(context(FileName, LineNumber)) = + elem("context", [], [ + tagged_string("filename", FileName), + tagged_int("line", LineNumber)]). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + + % + % sym_name_to_id(P, S) converts the sym_name, S, into + % a string with prefix, P, prefixed to the generated name. + % +:- func sym_name_to_id(string, sym_name) = string. + +sym_name_to_id(Prefix, Name) = prefixed_sym_name(Prefix, Name). + + % + % sym_name_to_id(P, S, A) converts the sym_name, S, with + % arity, A, into a string with prefix, P, prefixed to the + % generated name. + % +:- func sym_name_and_arity_to_id(string, sym_name, int) = string. + +sym_name_and_arity_to_id(Prefix, Name, Arity) = + prefixed_sym_name(Prefix, Name) ++ "/" ++ int_to_string(Arity). + +:- func prefixed_sym_name(string, sym_name) = string. + +prefixed_sym_name(Prefix, Name) = Prefix ++ "." ++ sym_name_to_string(Name). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- func tagged_string(string, string) = xml. + +tagged_string(E, S) = elem(E, [], [data(S)]). + +:- func tagged_int(string, int) = xml. + +tagged_int(E, I) = elem(E, [], [data(int_to_string(I))]). + +%-----------------------------------------------------------------------------% + +:- func xml_list(string, func(T) = xml, list(T)) = xml. + +xml_list(Tag, F, L) = elem(Tag, [], list.map(F, L)). + +%-----------------------------------------------------------------------------% + +:- func nyi(string) = xml. + +nyi(Tag) = tagged_string(Tag, "Not yet implemented!"). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% diff --git a/doc/user_guide.texi b/doc/user_guide.texi index 3ecafe172..834a63c7e 100644 --- a/doc/user_guide.texi +++ b/doc/user_guide.texi @@ -6007,6 +6007,14 @@ because a @samp{.trans_opt} file may depend on other a @samp{.opt} file can only hold information derived directly from the corresponding @samp{.m} file. +@sp 1 +@item --make-xml-documentation +@findex --make-xml-documentation +Output an XML representation of all the declarations in the module +into the `.xml' file. +This XML file can then be transformed via a XSL transform into +another documentation format. + @sp 1 @item -P @itemx --pretty-print diff --git a/library/parser.m b/library/parser.m index 60a9d7a86..69bfb2f91 100644 --- a/library/parser.m +++ b/library/parser.m @@ -491,17 +491,17 @@ parse_rest(MaxPriority, TermKind, LeftPriority, LeftTerm, Term, !PS) :- parse_backquoted_operator(Qualifier, OpName, VariableTerm, !PS) :- parser_get_token_context(Token, Context, !PS), + get_term_context(!.PS, Context, TermContext), ( Token = variable(VariableOp), Qualifier = no, OpName = "", add_var(VariableOp, Var, !PS), - VariableTerm = [variable(Var)] + VariableTerm = [variable(Var, TermContext)] ; Token = name(OpName0), VariableTerm = [], - get_term_context(!.PS, Context, OpCtxt0), - parse_backquoted_operator_2(no, Qualifier, OpCtxt0, OpName0, OpName, + parse_backquoted_operator_2(no, Qualifier, TermContext, OpName0, OpName, !PS) ). @@ -597,9 +597,10 @@ parse_simple_term_2(name(Atom), Context, Prec, Term, !PS) :- Term = ok(term.functor(term.atom(Atom), [], TermContext)) ). -parse_simple_term_2(variable(VarName), _, _, Term, !PS) :- +parse_simple_term_2(variable(VarName), Context, _, Term, !PS) :- add_var(VarName, Var, !PS), - Term = ok(term.variable(Var)). + get_term_context(!.PS, Context, TermContext), + Term = ok(term.variable(Var, TermContext)). parse_simple_term_2(integer(Int), Context, _, Term, !PS) :- get_term_context(!.PS, Context, TermContext), diff --git a/library/term.m b/library/term.m index b0d3959be..ba80df519 100644 --- a/library/term.m +++ b/library/term.m @@ -36,7 +36,8 @@ term.context ) ; variable( - var(T) + var(T), + term.context ). :- type const @@ -399,15 +400,16 @@ % Abort (call error/1) if the list contains any non-variables. % :- func term_list_to_var_list(list(term(T))) = list(var(T)). -:- pred term_list_to_var_list(list(term(T))::in, list(var(T))::out) is det. + + % Convert a list of terms which are all vars into a list of vars. + % +:- pred term_list_to_var_list(list(term(T))::in, list(var(T))::out) is semidet. % Convert a list of terms which are all vars into a list of vars % (or vice versa). % :- func var_list_to_term_list(list(var(T))) = list(term(T)). -:- pred var_list_to_term_list(list(var(T)), list(term(T))). -:- mode var_list_to_term_list(in, out) is det. -:- mode var_list_to_term_list(out, in) is semidet. +:- pred var_list_to_term_list(list(var(T))::in, list(term(T))::out) is det. %-----------------------------------------------------------------------------% @@ -497,7 +499,7 @@ try_term_to_univ(Term, Type, Result) :- type_desc::in, term_to_type_context::in, term_to_type_result(univ, T)::out) is det. -try_term_to_univ_2(variable(Var), _Type, Context, +try_term_to_univ_2(variable(Var, _), _Type, Context, error(mode_error(Var, Context))). try_term_to_univ_2(Term, Type, Context, Result) :- Term = functor(Functor, ArgTerms, TermContext), @@ -782,7 +784,7 @@ vars(Term, Vars) :- vars_list(Terms, Vars) :- vars_2_list(Terms, [], Vars). -vars_2(variable(Var), !Vars) :- +vars_2(variable(Var, _), !Vars) :- !:Vars = [Var | !.Vars]. vars_2(functor(_, Args, _), !Vars) :- vars_2_list(Args, !Vars). @@ -797,7 +799,7 @@ vars_2_list([Term | Terms], !Vars) :- %-----------------------------------------------------------------------------% -contains_var(variable(Var), Var). +contains_var(variable(Var, _), Var). contains_var(functor(_, Args, _), Var) :- contains_var_list(Args, Var). @@ -815,7 +817,7 @@ context_init(File, LineNumber, context(File, LineNumber)). %-----------------------------------------------------------------------------% -unify_term(variable(X), variable(Y), !Bindings) :- +unify_term(variable(X, _), VarY @ variable(Y, _), !Bindings) :- ( map.search(!.Bindings, X, BindingOfX) -> ( map.search(!.Bindings, Y, BindingOfY) -> % Both X and Y already have bindings - just unify the terms @@ -824,7 +826,7 @@ unify_term(variable(X), variable(Y), !Bindings) :- ; % Y is a variable which hasn't been bound yet. apply_rec_substitution(BindingOfX, !.Bindings, SubstBindingOfX), - ( SubstBindingOfX = variable(Y) -> + ( SubstBindingOfX = variable(Y, _) -> true ; \+ occurs(SubstBindingOfX, Y, !.Bindings), @@ -835,7 +837,7 @@ unify_term(variable(X), variable(Y), !Bindings) :- ( map.search(!.Bindings, Y, BindingOfY) -> % X is a variable which hasn't been bound yet apply_rec_substitution(BindingOfY, !.Bindings, SubstBindingOfY), - ( SubstBindingOfY = variable(X) -> + ( SubstBindingOfY = variable(X, _) -> true ; \+ occurs(SubstBindingOfY, X, !.Bindings), @@ -847,12 +849,12 @@ unify_term(variable(X), variable(Y), !Bindings) :- ( X = Y -> true ; - map.set(!.Bindings, X, variable(Y), !:Bindings) + map.set(!.Bindings, X, VarY, !:Bindings) ) ) ). -unify_term(term.variable(X), term.functor(F, As, C), !Bindings) :- +unify_term(term.variable(X, _), term.functor(F, As, C), !Bindings) :- ( map.search(!.Bindings, X, BindingOfX) -> unify_term(BindingOfX, functor(F, As, C), !Bindings) ; @@ -860,7 +862,7 @@ unify_term(term.variable(X), term.functor(F, As, C), !Bindings) :- map.set(!.Bindings, X, functor(F, As, C), !:Bindings) ). -unify_term(functor(F, As, C), variable(X), !Bindings) :- +unify_term(functor(F, As, C), variable(X, _), !Bindings) :- ( map.search(!.Bindings, X, BindingOfX) -> unify_term(functor(F, As, C), BindingOfX, !Bindings) ; @@ -876,7 +878,8 @@ unify_term_list([X | Xs], [Y | Ys], !Bindings) :- unify_term(X, Y, !Bindings), unify_term_list(Xs, Ys, !Bindings). -unify_term_dont_bind(variable(X), variable(Y), BoundVars, !Bindings) :- +unify_term_dont_bind(variable(X, _), VarY @ variable(Y, _), + BoundVars, !Bindings) :- ( list.member(Y, BoundVars) -> unify_term_bound_var(X, Y, BoundVars, !Bindings) ; list.member(X, BoundVars) -> @@ -889,7 +892,7 @@ unify_term_dont_bind(variable(X), variable(Y), BoundVars, !Bindings) :- ; apply_rec_substitution(BindingOfX, !.Bindings, SubstBindingOfX), % Y is a variable which hasn't been bound yet. - ( SubstBindingOfX = variable(Y) -> + ( SubstBindingOfX = variable(Y, _) -> true ; \+ occurs(SubstBindingOfX, Y, !.Bindings), @@ -900,7 +903,7 @@ unify_term_dont_bind(variable(X), variable(Y), BoundVars, !Bindings) :- ( map.search(!.Bindings, Y, BindingOfY) -> apply_rec_substitution(BindingOfY, !.Bindings, SubstBindingOfY), % X is a variable which hasn't been bound yet. - ( SubstBindingOfY = variable(X) -> + ( SubstBindingOfY = variable(X, _) -> true ; \+ occurs(SubstBindingOfY, X, !.Bindings), @@ -911,12 +914,12 @@ unify_term_dont_bind(variable(X), variable(Y), BoundVars, !Bindings) :- ( X = Y -> true ; - svmap.det_insert(X, variable(Y), !Bindings) + svmap.det_insert(X, VarY, !Bindings) ) ) ). -unify_term_dont_bind(variable(X), functor(F, As, C), BoundVars, !Bindings) :- +unify_term_dont_bind(variable(X, _), functor(F, As, C), BoundVars, !Bindings) :- ( map.search(!.Bindings, X, BindingOfX) -> unify_term_dont_bind(BindingOfX, functor(F, As, C), BoundVars, !Bindings) @@ -926,7 +929,7 @@ unify_term_dont_bind(variable(X), functor(F, As, C), BoundVars, !Bindings) :- svmap.det_insert(X, functor(F, As, C), !Bindings) ). -unify_term_dont_bind(functor(F, As, C), variable(X), BoundVars, !Bindings) :- +unify_term_dont_bind(functor(F, As, C), variable(X, _), BoundVars, !Bindings) :- ( map.search(!.Bindings, X, BindingOfX) -> unify_term_dont_bind(functor(F, As, C), BindingOfX, BoundVars, !Bindings) @@ -959,14 +962,14 @@ unify_term_list_dont_bind([X | Xs], [Y | Ys], BoundVars, !Bindings) :- unify_term_bound_var(Var, BoundVar, BoundVars, !Bindings) :- ( map.search(!.Bindings, Var, BindingOfVar) -> - BindingOfVar = variable(Var2), + BindingOfVar = variable(Var2, _), unify_term_bound_var(Var2, BoundVar, BoundVars, !Bindings) ; ( Var = BoundVar -> true ; \+ list.member(Var, BoundVars), - svmap.det_insert(Var, variable(BoundVar), !Bindings) + svmap.det_insert(Var, variable(BoundVar, context_init), !Bindings) ) ). @@ -979,7 +982,7 @@ list_subsumes(Terms1, Terms2, Subst) :- %-----------------------------------------------------------------------------% -occurs(variable(X), Y, Bindings) :- +occurs(variable(X, _), Y, Bindings) :- ( X = Y -> true ; @@ -998,11 +1001,11 @@ occurs_list([Term | Terms], Y, Bindings) :- %-----------------------------------------------------------------------------% -substitute(variable(Var), SearchVar, Replacement, Term) :- +substitute(V @ variable(Var, _), SearchVar, Replacement, Term) :- ( Var = SearchVar -> Term = Replacement ; - Term = variable(Var) + Term = V ). substitute(functor(Name, Args0, Context), Var, Replacement, functor(Name, Args, Context)) :- @@ -1039,12 +1042,12 @@ substitute_corresponding_2([S | Ss], [R | Rs], !Subst) :- %-----------------------------------------------------------------------------% -apply_rec_substitution(variable(Var), Substitution, Term) :- +apply_rec_substitution(V @ variable(Var, _), Substitution, Term) :- ( map.search(Substitution, Var, Replacement) -> % Recursively apply the substition to the replacement. apply_rec_substitution(Replacement, Substitution, Term) ; - Term = variable(Var) + Term = V ). apply_rec_substitution(functor(Name, Args0, Context), Substitution, functor(Name, Args, Context)) :- @@ -1058,11 +1061,11 @@ apply_rec_substitution_to_list([Term0 | Terms0], Substitution, %-----------------------------------------------------------------------------% -apply_substitution(variable(Var), Substitution, Term) :- +apply_substitution(V @ variable(Var, _), Substitution, Term) :- ( map.search(Substitution, Var, Replacement) -> Term = Replacement ; - Term = variable(Var) + Term = V ). apply_substitution(functor(Name, Args0, Context), Substitution, functor(Name, Args, Context)) :- @@ -1108,7 +1111,8 @@ var_supply_max_var(var_supply(V)) = var(V). relabel_variable(functor(Const, Terms0, Cont), OldVar, NewVar, functor(Const, Terms, Cont)) :- relabel_variables(Terms0, OldVar, NewVar, Terms). -relabel_variable(variable(Var0), OldVar, NewVar, variable(Var)) :- +relabel_variable(variable(Var0, Context), + OldVar, NewVar, variable(Var, Context)) :- ( Var0 = OldVar -> Var = NewVar ; @@ -1123,8 +1127,8 @@ relabel_variables([Term0|Terms0], OldVar, NewVar, [Term|Terms]):- apply_variable_renaming(functor(Const, Args0, Cont), Renaming, functor(Const, Args, Cont)) :- apply_variable_renaming_to_list(Args0, Renaming, Args). -apply_variable_renaming(variable(Var0), Renaming, - variable(Var)) :- +apply_variable_renaming(variable(Var0, Context), Renaming, + variable(Var, Context)) :- apply_variable_renaming_to_var(Renaming, Var0, Var). apply_variable_renaming_to_list([], _, []). @@ -1146,20 +1150,17 @@ apply_variable_renaming_to_vars(Renaming, [Var0 | Vars0], [Var | Vars]) :- %-----------------------------------------------------------------------------% -term_list_to_var_list(Terms, Vars) :- - ( var_list_to_term_list(Vars0, Terms) -> - Vars = Vars0 - ; - error("term.term_list_to_var_list") - ). +term_list_to_var_list([], []). +term_list_to_var_list([variable(Var, _) | Terms], [Var | Vars]) :- + term_list_to_var_list(Terms, Vars). var_list_to_term_list([], []). -var_list_to_term_list([Var | Vars], [variable(Var) | Terms]) :- +var_list_to_term_list([Var | Vars], [variable(Var, context_init) | Terms]) :- var_list_to_term_list(Vars, Terms). %-----------------------------------------------------------------------------% -is_ground_in_bindings(variable(V), Bindings) :- +is_ground_in_bindings(variable(V, _), Bindings) :- map.search(Bindings, V, Binding), is_ground_in_bindings(Binding, Bindings). is_ground_in_bindings(functor(_, Args, _), Bindings) :- @@ -1288,7 +1289,11 @@ context_init(S, N) = C :- context_init(S, N, C). term_list_to_var_list(Ts) = Vs :- - term_list_to_var_list(Ts, Vs). + ( term_list_to_var_list(Ts, Vs0) -> + Vs = Vs0 + ; + error("term.term_list_to_var_list: not all vars") + ). var_list_to_term_list(Vs) = Ts :- var_list_to_term_list(Vs, Ts). diff --git a/library/term_io.m b/library/term_io.m index 58ead630c..e1af122d2 100644 --- a/library/term_io.m +++ b/library/term_io.m @@ -291,7 +291,7 @@ term_io.write_arg_term(Ops, Term, !VarSet, !N, !IO) :- varset(T)::in, varset(T)::out, int::in, int::out, io::di, io::uo) is det <= op_table(Ops). -term_io.write_term_3(Ops, term.variable(Id), _, !VarSet, !N, !IO) :- +term_io.write_term_3(Ops, term.variable(Id, _), _, !VarSet, !N, !IO) :- term_io.write_variable_2(Ops, Id, !VarSet, !N, !IO). term_io.write_term_3(Ops, term.functor(Functor, Args, _), Priority, !VarSet, !N, !IO) :- @@ -328,7 +328,7 @@ term_io.write_term_3(Ops, term.functor(Functor, Args, _), Priority, % gets parsed as ''(Var, Arg). When writing it out, we want to use % the nice syntax. Functor = term.atom(""), - Args = [term.variable(Var), FirstArg | OtherArgs] + Args = [term.variable(Var, _), FirstArg | OtherArgs] -> term_io.write_variable_2(Ops, Var, !VarSet, !N, !IO), io.write_char('(', !IO), @@ -432,7 +432,7 @@ term_io.write_term_3(Ops, term.functor(Functor, Args, _), Priority, term_io.write_list_tail(Ops, Term, !VarSet, !N, !IO) :- ( - Term = term.variable(Id), + Term = term.variable(Id, _), varset.search_var(!.VarSet, Id, Val) -> term_io.write_list_tail(Ops, Val, !VarSet, !N, !IO) diff --git a/library/varset.m b/library/varset.m index 1dd3c5790..908e4910f 100644 --- a/library/varset.m +++ b/library/varset.m @@ -498,7 +498,7 @@ varset.merge_subst_2(IncludeNames, N, Max, Names, Values, !VarSet, !Subst) :- ; true ), - map.set(!.Subst, VarN, term.variable(VarId), !:Subst), + map.set(!.Subst, VarN, term.variable(VarId, context_init), !:Subst), varset.merge_subst_2(IncludeNames, N1, Max, Names, Values, !VarSet, !Subst) ).