mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-16 18:03:36 +00:00
Code Issues Projects Releases Wiki Activity
Files
b357a3dadcdf29c8d8ca184d65f7634a1a94de36
mercury/compiler/parse_item.m
Zoltan Somogyi ffb963b30f Add code to write parse trees to a string. 
Traditionally, we always wrote out parse trees (of .intN files, for example)
to a file. However, we have also supported being able to write out *parts*
of parse trees to strings, because that ability is useful e.g.

- in error messages, printing the code that the error message is about,
- when debugging.

We are considering a use case which requires the ability to write out
the *whole* parse tree of a .intN file to a string. That use case is
comparing whether the old and new versions of a .intN file are identical
or not, because we want to update the actual .intN file only if they
differ. (Updating the .intN file if they are identical could trigger
the unnecessary recompilation of an unbounded number of other modules.)

Previously, we have done this comparison by writing out the new parse tree
to an .intN.tmp file, and compared it to the .intN file. It should be simpler
and quite possibly faster to

- read in the old .intN file as a string
- convert the new parse tree to a string
- compare the two strings
- write out the new string if and only if it differs from the old string.

This should be especially so if we can open the .intN file in read-write mode,
so the file would need to be opened just once, in step one, even if we do
need to write out the new parse tree in step four.

compiler/parse_tree_out.m:
    Add functions to convert parse_tree_int[0123]s to strings.

    To avoid having to reimplement all the code that currently writes
    out those parse trees, convert the current predicates that always do I/O
    into predicates that use the methods of the existing pt_output type class,
    which, depending on the selected instance, can either do I/O or can build
    up a string. This conversion has already been done for the constructs
    that make up some parts of those parse trees; this diff extends the
    conversion to every construct that is part of parse trees listed above.

    As part of our existing conventions, predicates that have been
    generalized in this way have the "output" or "write" in their names
    replaced with "format".

    We also perform this generalization for the predicates that write out
    parse_tree_srcs and parse_tree_module_srcs, because doing so requires
    almost no extra code.

compiler/parse_item.m:
compiler/parse_tree_out_clause.m:
compiler/parse_tree_out_info.m:
compiler/parse_tree_out_inst.m:
compiler/parse_tree_out_misc.m:
compiler/parse_tree_out_pragma.m:
compiler/parse_tree_out_pred_decl.m:
compiler/parse_tree_out_type_repn.m:
compiler/prog_ctgc.m:
    Perform the generalization discussed above, both on predicates
    that write out Mercury constructs, and on some auxiliary predicates.

    In a few cases, the generalized versions already existed but were private,
    in which case this diff just exports them.

    In a few cases, rename predicates to avoid ambiguities.

compiler/add_clause.m:
compiler/hlds_out_goal.m:
compiler/hlds_out_pred.m:
compiler/hlds_out_type_table.m:
compiler/hlds_out_typeclass_table.m:
compiler/intermod.m:
compiler/intermod_analysis.m:
    Conform to the changes above.
2023-11-01 19:53:40 +11:00

2248 lines
90 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2014, 2016-2019 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% This module handles the top level parsing of items.
%
%---------------------------------------------------------------------------%
:- module parse_tree.parse_item.
:- interface.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.error_spec.
:- import_module parse_tree.maybe_error.
:- import_module parse_tree.parse_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
:- import_module maybe.
:- import_module term.
:- import_module varset.
% parse_item_or_marker(ModuleName, VarSet, Term, SeqNum,
% MaybeItemOrMarker):
%
% Parse Term as either an item or sequence of items, or as a marker for
% the start or end of a module, the start of a module section,
% or a new source file.
%
% If Term represents an item (or more than one), bind MaybeItemOrMarker
% to the parsed item(s), having qualified the appropriate parts of the item
% with ModuleName as the module name. If Term represents a marker, include
% its details in MaybeItemOrMarker. Include SeqNum as the sequence number
% in both cases.
%
% If the parsing attempt is unsuccessful, bind MaybeItemOrMarker
% to an error1() wrapped around an appropriate set of error messages.
%
:- pred parse_item_or_marker(module_name::in, varset::in, term::in,
item_seq_num::in, maybe1(item_or_marker)::out) is det.
% parse_clause_term(MaybeDefaultModuleName, VarSet, Term, SeqNum,
% MaybeItemOrMarker):
%
% The part of parse_item_or_marker that parses clauses. Implicit
% qualification happens only if the caller passes a module name
% in the first argument.
%
% Exported for use by parse_class.m.
%
:- pred parse_clause_term(maybe(module_name)::in, varset::in, term::in,
item_seq_num::in, maybe1(item_clause_info)::out) is det.
% parse_class_decl(ModuleName, VarSet, Term, MaybeClassDecl):
%
% Parse Term as a declaration that may appear in the body of a
% typeclass declaration. If successful, bind MaybeClassDecl to the
% parsed item, otherwise bind it to an appropriate error message.
% Qualify appropriate parts of the declaration with ModuleName
% as the module name.
%
% Exported for use by parse_class.m.
%
:- pred parse_class_decl(module_name::in, varset::in, term::in,
maybe1(class_decl)::out) is det.
%---------------------------------------------------------------------------%
% This type specifies whether the declaration we are attempting to parse
% occurs inside a typeclass declaration or not.
% XXX possibly we should also include the identity of the typeclass
% involved in the case where parsing the class head succeeds.
%
:- type decl_in_class
---> decl_is_in_class
; decl_is_not_in_class.
%---------------------------------------------------------------------------%
:- type var_term_kind
---> vtk_type_decl_pred(decl_in_class)
; vtk_type_decl_func(decl_in_class)
; vtk_mode_decl_pred(decl_in_class)
; vtk_mode_decl_func(decl_in_class)
; vtk_class_decl
; vtk_instance_decl
; vtk_clause_pred
; vtk_clause_func.
% The term parser turns "X(a, b)" into "`'(X, a, b)".
%
% Check whether Term is the result of this transformation,
% and if yes, return an error message that reflects what
% the term was supposed to be.
%
% Exported for use by parse_class.m.
%
:- pred is_the_name_a_variable(varset::in, var_term_kind::in, term::in,
error_spec::out) is semidet.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module libs.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.parse_class.
:- import_module parse_tree.parse_dcg_goal.
:- import_module parse_tree.parse_goal.
:- import_module parse_tree.parse_inst_mode_defn.
:- import_module parse_tree.parse_inst_mode_name.
:- import_module parse_tree.parse_mutable.
:- import_module parse_tree.parse_pragma.
:- import_module parse_tree.parse_sym_name.
:- import_module parse_tree.parse_tree_out_clause.
:- import_module parse_tree.parse_tree_out_term.
:- import_module parse_tree.parse_type_defn.
:- import_module parse_tree.parse_type_name.
:- import_module parse_tree.parse_type_repn.
:- import_module parse_tree.parse_util.
:- import_module parse_tree.parse_vars.
:- import_module parse_tree.prog_mode.
:- import_module recompilation.
:- import_module recompilation.version.
:- import_module bool.
:- import_module cord.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module one_or_more.
:- import_module pretty_printer.
:- import_module string.
:- import_module term_int.
%---------------------------------------------------------------------------%
parse_item_or_marker(ModuleName, VarSet, Term, SeqNum, MaybeIOM) :-
( if Term = term.functor(term.atom(":-"), [DeclTerm], _DeclContext) then
parse_decl_term_item_or_marker(ModuleName, VarSet, DeclTerm,
SeqNum, MaybeIOM)
else
parse_clause_term(yes(ModuleName), VarSet, Term, SeqNum, MaybeClause),
(
MaybeClause = ok1(ItemClause),
MaybeIOM = ok1(iom_item(item_clause(ItemClause)))
;
MaybeClause = error1(Specs),
MaybeIOM = error1(Specs)
)
).
%---------------------------------------------------------------------------%
:- pred parse_decl_term_item_or_marker(module_name::in, varset::in, term::in,
item_seq_num::in, maybe1(item_or_marker)::out) is det.
:- pragma inline(pred(parse_decl_term_item_or_marker/5)).
parse_decl_term_item_or_marker(ModuleName, VarSet, DeclTerm,
SeqNum, MaybeIOM) :-
( if DeclTerm = term.functor(term.atom(Functor), ArgTerms, Context) then
( if
parse_decl_item_or_marker(ModuleName, VarSet, Functor, ArgTerms,
decl_is_not_in_class, Context, SeqNum, MaybeIOMPrime)
then
MaybeIOM = MaybeIOMPrime
else
Spec = decl_functor_is_not_valid(Functor, Context),
MaybeIOM = error1([Spec])
)
else
Spec = decl_is_not_an_atom(VarSet, DeclTerm),
MaybeIOM = error1([Spec])
).
:- func decl_is_not_an_atom(varset, term) = error_spec.
decl_is_not_an_atom(VarSet, Term) = Spec :-
TermStr = mercury_term_to_string_vs(VarSet, print_name_only, Term),
Context = get_term_context(Term),
Pieces = [words("Error:"), quote(TermStr),
words("is not a valid declaration."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces).
:- func decl_functor_is_not_valid(string, prog_context) = error_spec.
decl_functor_is_not_valid(Functor, Context) = Spec :-
Pieces = [words("Error:"), quote(Functor),
words("is not a valid declaration type."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces).
%---------------------------------------------------------------------------%
:- pred parse_decl_item_or_marker(module_name::in, varset::in,
string::in, list(term)::in, decl_in_class::in, prog_context::in,
item_seq_num::in, maybe1(item_or_marker)::out) is semidet.
parse_decl_item_or_marker(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, MaybeIOM) :-
require_switch_arms_det [Functor]
(
Functor = "module",
parse_module_marker(ArgTerms, Context, SeqNum, MaybeIOM)
;
Functor = "end_module",
parse_end_module_marker(ArgTerms, Context, SeqNum, MaybeIOM)
;
( Functor = "interface", Section = ms_interface
; Functor = "implementation", Section = ms_implementation
),
parse_section_marker(Functor, ArgTerms, Context, SeqNum,
Section, MaybeIOM)
;
( Functor = "include_module", IIU = iiu_include_module
; Functor = "import_module", IIU = iiu_import_module
; Functor = "use_module", IIU = iiu_use_module
),
parse_incl_imp_use_items(ModuleName, VarSet, Functor, ArgTerms,
Context, SeqNum, IIU, MaybeIOM)
;
Functor = "version_numbers",
parse_version_numbers_marker(ModuleName, Functor, ArgTerms,
Context, SeqNum, MaybeIOM)
;
Functor = "type",
parse_type_defn_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
non_solver_type, MaybeIOM)
;
Functor = "solver",
parse_solver_type_defn_item(ModuleName, VarSet, ArgTerms,
Context, SeqNum, MaybeIOM)
;
Functor = "type_representation",
parse_type_repn_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
Functor = "inst",
parse_inst_defn_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
Functor = "abstract_inst",
parse_abstract_inst_defn_item(ModuleName, VarSet, ArgTerms, Context,
SeqNum, MaybeIOM)
;
Functor = "mode",
parse_mode_defn_or_decl_item(ModuleName, VarSet, ArgTerms,
IsInClass, Context, SeqNum, allow_mode_decl_and_defn, [], MaybeIOM)
;
Functor = "abstract_mode",
parse_abstract_mode_defn_item(ModuleName, VarSet, ArgTerms, Context,
SeqNum, MaybeIOM)
;
( Functor = "pred", PredOrFunc = pf_predicate
; Functor = "func", PredOrFunc = pf_function
),
parse_pred_or_func_decl_item(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, PredOrFunc, [], [], MaybeIOM)
;
( Functor = "some", QuantType = quant_type_exist
; Functor = "all", QuantType = quant_type_univ
),
parse_quant_attr(ModuleName, VarSet, Functor, ArgTerms, IsInClass,
Context, SeqNum, QuantType, cord.init, cord.init, MaybeIOM)
;
( Functor = "=>", QuantType = quant_type_exist
; Functor = "<=", QuantType = quant_type_univ
),
parse_constraint_attr(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, QuantType, cord.init, cord.init,
MaybeIOM)
;
( Functor = "impure", Purity = purity_impure
; Functor = "semipure", Purity = purity_semipure
),
parse_purity_attr(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, Purity, cord.init, cord.init, MaybeIOM)
;
Functor = "promise",
parse_promise_item(VarSet, ArgTerms, Context, SeqNum, MaybeIOM)
% The supported form of promise_ex declarations is
% ":- all [Vars] promise_ex Goal", and it is parsed by
% parse_attr_decl_item_or_marker.
%
% ;
% ( Functor = "promise_exclusive", PromiseType = promise_type_exclusive
% ; Functor = "promise_exhaustive", PromiseType = promise_type_exhaustive
% ; Functor = "promise_exclusive_exhaustive",
% PromiseType = promise_type_exclusive_exhaustive
% ),
% UnivQuantVars = [],
% parse_promise_ex_item(VarSet, Functor, ArgTerms, Context, SeqNum,
% PromiseType, UnivQuantVars, MaybeIOM)
;
Functor = "typeclass",
parse_typeclass_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
Functor = "instance",
parse_instance_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
( Functor = "initialise"
; Functor = "initialize"
),
parse_initialise_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
( Functor = "finalise"
; Functor = "finalize"
),
parse_finalise_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
Functor = "mutable",
parse_mutable_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
MaybeIOM)
;
Functor = "pragma",
parse_pragma(ModuleName, VarSet, ArgTerms, Context, SeqNum, MaybeIOM)
).
:- pred parse_attr_decl_item_or_marker(module_name::in, varset::in,
string::in, list(term)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
cord(purity_attr)::in, cord(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is semidet.
parse_attr_decl_item_or_marker(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, PurityAttrs0, QuantConstrAttrs0,
MaybeIOM) :-
% By coincidence, the kinds of items that may have purity,
% quantification and/or constraint attributes on them, i.e.
% the set item_pred_decl and item_mode_decl, is exactly the
% set of items that may appear in class method specifications.
%
% A variant of the commented-out code below should help implement
% quantification for these kinds of promise declarations, but enabling it
% would break the above coincidence, requiring extra checks in
% parse_class_decl.
require_switch_arms_det [Functor]
(
Functor = "mode",
parse_mode_defn_or_decl_item(ModuleName, VarSet, ArgTerms,
IsInClass, Context, SeqNum, allow_mode_decl_only,
cord.list(QuantConstrAttrs0), MaybeIOM0),
( if cord.is_empty(PurityAttrs0) then
MaybeIOM = MaybeIOM0
else
Pieces = [words("Error: purity annotations"),
words("are not allowed on mode declarations."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, Context, Pieces),
(
MaybeIOM0 = ok1(_),
MaybeIOM = error1([Spec])
;
MaybeIOM0 = error1(Specs0),
MaybeIOM = error1([Spec | Specs0])
)
)
;
( Functor = "pred", PredOrFunc = pf_predicate
; Functor = "func", PredOrFunc = pf_function
),
parse_pred_or_func_decl_item(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, PredOrFunc,
cord.list(PurityAttrs0), cord.list(QuantConstrAttrs0), MaybeIOM)
;
( Functor = "some", QuantType = quant_type_exist
; Functor = "all", QuantType = quant_type_univ
),
parse_quant_attr(ModuleName, VarSet, Functor, ArgTerms, IsInClass,
Context, SeqNum, QuantType, PurityAttrs0, QuantConstrAttrs0,
MaybeIOM)
;
( Functor = "=>", QuantType = quant_type_exist
; Functor = "<=", QuantType = quant_type_univ
),
parse_constraint_attr(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, QuantType, PurityAttrs0,
QuantConstrAttrs0, MaybeIOM)
;
( Functor = "impure", Purity = purity_impure
; Functor = "semipure", Purity = purity_semipure
),
parse_purity_attr(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, Purity, PurityAttrs0,
QuantConstrAttrs0, MaybeIOM)
;
( Functor = "promise_exclusive", PromiseType = promise_type_exclusive
; Functor = "promise_exhaustive", PromiseType = promise_type_exhaustive
; Functor = "promise_exclusive_exhaustive",
PromiseType = promise_type_exclusive_exhaustive
),
parse_promise_ex_item(VarSet, Functor, ArgTerms, Context, SeqNum,
PromiseType, PurityAttrs0, QuantConstrAttrs0, MaybeIOM)
).
%---------------------------------------------------------------------------%
:- pragma inline(pred(parse_clause_term/5)).
parse_clause_term(MaybeModuleName, VarSet, Term, SeqNum, MaybeClause) :-
( if
Term = term.functor(term.atom("-->"), [DCGHeadTerm, DCGBodyTerm],
DCGContext)
then
% Term is a DCG clause.
parse_dcg_clause(MaybeModuleName, VarSet, DCGHeadTerm, DCGBodyTerm,
DCGContext, SeqNum, MaybeClause)
else
% Term is a clause; either a fact or a rule.
( if
Term = term.functor(term.atom(":-"),
[HeadTermPrime, BodyTermPrime], TermContext)
then
% Term is a rule.
HeadTerm = HeadTermPrime,
BodyTerm = BodyTermPrime,
ClauseContext = TermContext
else
% Term is a fact.
HeadTerm = Term,
ClauseContext = get_term_context(HeadTerm),
BodyTerm = term.functor(term.atom("true"), [], ClauseContext)
),
parse_clause(MaybeModuleName, VarSet, HeadTerm, BodyTerm,
ClauseContext, SeqNum, MaybeClause)
).
parse_class_decl(ModuleName, VarSet, Term, MaybeClassMethod) :-
TermContext = get_term_context(Term),
parse_attributed_decl(ModuleName, VarSet, Term, decl_is_in_class,
TermContext, item_no_seq_num, cord.init, cord.init, MaybeIOM),
(
MaybeIOM = error1(Specs),
MaybeClassMethod = error1(Specs)
;
MaybeIOM = ok1(IOM),
( if IOM = iom_item(item_pred_decl(ItemPredDecl)) then
ItemPredDecl = item_pred_decl_info(Name, PorF, ArgDecls,
WithType, WithInst, MaybeDetism, _Origin,
TypeVarSet, InstVarSet, ExistQVars, Purity,
Constraints, Context, _SeqNum),
PredOrFuncInfo = class_pred_or_func_info(Name, PorF, ArgDecls,
WithType, WithInst, MaybeDetism, TypeVarSet, InstVarSet,
ExistQVars, Purity, Constraints, Context),
ClassDecl = class_decl_pred_or_func(PredOrFuncInfo),
MaybeClassMethod = ok1(ClassDecl)
else if IOM = iom_item(item_mode_decl(ItemModeDecl)) then
ItemModeDecl = item_mode_decl_info(Name, MaybePorF, ArgModes,
WithInst, MaybeDetism, InstVarSet, Context, _SeqNum),
ModeInfo = class_mode_info(Name, MaybePorF, ArgModes,
WithInst, MaybeDetism, InstVarSet, Context),
ClassDecl = class_decl_mode(ModeInfo),
MaybeClassMethod = ok1(ClassDecl)
else
Pieces = [words("Error: only pred, func and mode declarations"),
words("are allowed in class interfaces."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, TermContext, Pieces),
MaybeClassMethod = error1([Spec])
)
).
%-----------------------------------------------------------------------------e
:- type purity_attr
---> purity_attr(purity).
:- type quantifier_type
---> quant_type_exist
; quant_type_univ.
:- type quant_constr_attr
---> qca_quant_vars(quantifier_type, term)
; qca_constraint(quantifier_type, term).
:- pred parse_quant_attr(module_name::in, varset::in,
string::in, list(term)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
quantifier_type::in, cord(purity_attr)::in, cord(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_quant_attr(ModuleName, VarSet, Functor, ArgTerms, IsInClass, Context,
SeqNum, QuantType, !.PurityAttrs, !.QuantConstrAttrs, MaybeIOM) :-
(
ArgTerms = [VarsTerm, SubTerm],
QuantAttr = qca_quant_vars(QuantType, VarsTerm),
!:QuantConstrAttrs = cord.snoc(!.QuantConstrAttrs, QuantAttr),
parse_attributed_decl(ModuleName, VarSet, SubTerm, IsInClass, Context,
SeqNum, !.PurityAttrs, !.QuantConstrAttrs, MaybeIOM)
;
( ArgTerms = []
; ArgTerms = [_]
; ArgTerms = [_, _, _ | _]
),
Pieces = [words("Error: the keyword"), quote(Functor),
words("may appear in declarations"),
words("only to denote the quantification"),
words("of a list of variables."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
:- pred check_quant_vars(cord(format_piece)::in, varset::in,
quantifier_type::in, term::in, maybe1(list(var))::out) is det.
check_quant_vars(InitContextPieces, VarSet, QuantType, VarsTerm, MaybeVars) :-
% Both versions of VarContextPieces should be statically allocated terms.
(
QuantType = quant_type_exist,
VarsContextPieces = [lower_case_next_if_not_first,
words("In first argument of"), quote("some"), suffix(":"), nl]
;
QuantType = quant_type_univ,
VarsContextPieces = [lower_case_next_if_not_first,
words("In first argument of"), quote("all"), suffix(":"), nl]
),
ContextPieces = InitContextPieces ++ cord.from_list(VarsContextPieces),
parse_possibly_repeated_vars(VarsTerm, VarSet, ContextPieces, MaybeVars).
:- pred parse_constraint_attr(module_name::in, varset::in,
string::in, list(term)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
quantifier_type::in, cord(purity_attr)::in, cord(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_constraint_attr(ModuleName, VarSet, Functor, ArgTerms, IsInClass,
Context, SeqNum, QuantType, !.PurityAttrs, !.QuantConstrAttrs,
MaybeIOM) :-
(
ArgTerms = [SubTerm, ConstraintsTerm],
ConstrAttr = qca_constraint(QuantType, ConstraintsTerm),
!:QuantConstrAttrs = cord.snoc(!.QuantConstrAttrs, ConstrAttr),
parse_attributed_decl(ModuleName, VarSet, SubTerm, IsInClass, Context,
SeqNum, !.PurityAttrs, !.QuantConstrAttrs, MaybeIOM)
;
( ArgTerms = []
; ArgTerms = [_]
; ArgTerms = [_, _, _ | _]
),
Pieces = [words("Error: the symbol"), quote(Functor),
words("may appear in declarations only to introduce"),
words("a constraint or a conjunction of constraints."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_purity_attr(module_name::in, varset::in,
string::in, list(term)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
purity::in, cord(purity_attr)::in, cord(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_purity_attr(ModuleName, VarSet, Functor, ArgTerms, IsInClass,
Context, SeqNum, Purity, !.PurityAttrs, !.QuantConstrAttrs,
MaybeIOM) :-
(
ArgTerms = [SubTerm],
PurityAttr = purity_attr(Purity),
!:PurityAttrs = cord.snoc(!.PurityAttrs, PurityAttr),
parse_attributed_decl(ModuleName, VarSet, SubTerm, IsInClass, Context,
SeqNum, !.PurityAttrs, !.QuantConstrAttrs, MaybeIOM)
;
( ArgTerms = []
; ArgTerms = [_, _ | _]
),
Pieces = [words("Error: the symbol"), quote(Functor),
words("may appear only as an annotation"),
words("in front of a predicate or function declaration."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_attributed_decl(module_name::in, varset::in, term::in,
decl_in_class::in, prog_context::in, item_seq_num::in,
cord(purity_attr)::in, cord(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_attributed_decl(ModuleName, VarSet, Term, IsInClass, _Context, SeqNum,
!.PurityAttrs, !.QuantConstrAttrs, MaybeIOM) :-
( if Term = term.functor(term.atom(Functor), ArgTerms, FunctorContext) then
( if
parse_attr_decl_item_or_marker(ModuleName, VarSet,
Functor, ArgTerms, IsInClass, FunctorContext, SeqNum,
!.PurityAttrs, !.QuantConstrAttrs, MaybeIOMPrime)
then
MaybeIOM = MaybeIOMPrime
else
Spec = decl_functor_is_not_valid(Functor, FunctorContext),
MaybeIOM = error1([Spec])
)
else
Spec = decl_is_not_an_atom(VarSet, Term),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_module_marker(list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_module_marker(ArgTerms, Context, SeqNum, MaybeIOM) :-
( if
ArgTerms = [ModuleNameTerm],
try_parse_symbol_name(ModuleNameTerm, ModuleName)
then
Marker = iom_marker_module_start(ModuleName, Context, SeqNum),
MaybeIOM = ok1(Marker)
else
Pieces = [words("Error: a"), decl("module"), words("declaration"),
words("should have just one argument,"),
words("which should be a module name."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_end_module_marker(list(term)::in, prog_context::in,
item_seq_num::in, maybe1(item_or_marker)::out) is det.
parse_end_module_marker(ArgTerms, Context, SeqNum, MaybeIOM) :-
( if
ArgTerms = [ModuleNameTerm],
try_parse_symbol_name(ModuleNameTerm, ModuleName)
then
Marker = iom_marker_module_end(ModuleName, Context, SeqNum),
MaybeIOM = ok1(Marker)
else
Pieces = [words("Error: an"), decl("end_module"), words("declaration"),
words("should have just one argument,"),
words("which should be a module name."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_section_marker(string::in, list(term)::in,
prog_context::in, item_seq_num::in, module_section::in,
maybe1(item_or_marker)::out) is det.
parse_section_marker(Functor, ArgTerms, Context, SeqNum, Section, MaybeIOM) :-
(
ArgTerms = [],
Marker = iom_marker_section(Section, Context, SeqNum),
MaybeIOM = ok1(Marker)
;
ArgTerms = [_ | _],
Pieces = [words("Error: an"), decl(Functor), words("declaration"),
words("should have no arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- type incl_imp_use
---> iiu_include_module
; iiu_import_module
; iiu_use_module.
:- pred parse_incl_imp_use_items(module_name::in, varset::in,
string::in, list(term)::in, prog_context::in, item_seq_num::in,
incl_imp_use::in, maybe1(item_or_marker)::out) is det.
parse_incl_imp_use_items(ModuleName, VarSet, Functor, ArgTerms, Context,
SeqNum, IIU, MaybeIOM) :-
(
IIU = iiu_include_module,
Parser = parse_implicitly_qualified_module_name(ModuleName, VarSet)
;
( IIU = iiu_import_module
; IIU = iiu_use_module
),
Parser = parse_module_name(VarSet)
),
(
ArgTerms = [ModuleNamesTerm],
parse_comma_separated_one_or_more(Parser, ModuleNamesTerm,
MaybeModuleNames),
(
MaybeModuleNames = ok1(ModuleNames),
ModuleNames = one_or_more(HeadModuleName, TailModuleNames),
(
IIU = iiu_include_module,
make_item_include(Context, SeqNum,
HeadModuleName, HeadIncl),
list.map(make_item_include(Context, SeqNum),
TailModuleNames, TailIncls),
IOM = iom_marker_include(one_or_more(HeadIncl, TailIncls))
;
IIU = iiu_import_module,
make_item_avail_import(Context, SeqNum,
HeadModuleName, HeadImport),
list.map(make_item_avail_import(Context, SeqNum),
TailModuleNames, TailImports),
IOM = iom_marker_avail(one_or_more(HeadImport, TailImports))
;
IIU = iiu_use_module,
make_item_avail_use(Context, SeqNum,
HeadModuleName, HeadUse),
list.map(make_item_avail_use(Context, SeqNum),
TailModuleNames, TailUses),
IOM = iom_marker_avail(one_or_more(HeadUse, TailUses))
),
MaybeIOM = ok1(IOM)
;
MaybeModuleNames = error1(Specs),
MaybeIOM = error1(Specs)
)
;
( ArgTerms = []
; ArgTerms = [_, _ | _]
),
(
( IIU = iiu_include_module
; IIU = iiu_import_module
),
Article = "an"
;
IIU = iiu_use_module,
Article = "a"
),
Pieces = [words("Error:"), words(Article), decl(Functor),
words("declaration"), words("should have just one argument,"),
words("which should be a list of one or more module names."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
:- pred make_item_include(prog_context::in, item_seq_num::in, module_name::in,
item_include::out) is det.
make_item_include(Context, SeqNum, ModuleName, Incl) :-
Incl = item_include(ModuleName, Context, SeqNum).
:- pred make_item_avail_import(prog_context::in, item_seq_num::in,
module_name::in, item_avail::out) is det.
make_item_avail_import(Context, SeqNum, ModuleName, Avail) :-
AvailImportInfo = avail_import_info(ModuleName, Context, SeqNum),
Avail = avail_import(AvailImportInfo).
:- pred make_item_avail_use(prog_context::in, item_seq_num::in,
module_name::in, item_avail::out) is det.
make_item_avail_use(Context, SeqNum, ModuleName, Avail) :-
AvailUseInfo = avail_use_info(ModuleName, Context, SeqNum),
Avail = avail_use(AvailUseInfo).
%---------------------------------------------------------------------------%
:- type maybe_allow_mode_defn
---> allow_mode_decl_and_defn
; allow_mode_decl_only.
:- pred parse_mode_defn_or_decl_item(module_name::in, varset::in,
list(term)::in, decl_in_class::in,
prog_context::in, item_seq_num::in, maybe_allow_mode_defn::in,
list(quant_constr_attr)::in, maybe1(item_or_marker)::out) is det.
parse_mode_defn_or_decl_item(ModuleName, VarSet, ArgTerms, IsInClass, Context,
SeqNum, AllowModeDefn, QuantConstrAttrs, MaybeIOM) :-
(
ArgTerms = [SubTerm],
( if
SubTerm = term.functor(term.atom("=="), [HeadTerm, BodyTerm], _),
% If AllowModeDefn = allow_mode_decl_only, then we expect SubTerm
% to a mode declaration, so we have to parse it that way,
% even if that yields nothing but error messages.
AllowModeDefn = allow_mode_decl_and_defn
then
% This is the definition of a mode.
parse_mode_defn(ModuleName, VarSet, HeadTerm, BodyTerm,
Context, SeqNum, MaybeIOM)
else
% This is the declaration of one mode of a predicate or function.
parse_mode_decl(ModuleName, VarSet, SubTerm, IsInClass, Context,
SeqNum, QuantConstrAttrs, MaybeIOM)
)
;
( ArgTerms = []
; ArgTerms = [_, _ | _]
),
Pieces = [words("Error: a"), decl("mode"), words("declaration"),
words("should have just one argument,"),
words("which should be either the definition of a mode,"),
words("or the declaration of one mode"),
words("of a predicate or function."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_version_numbers_marker(module_name::in,
string::in, list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_version_numbers_marker(ModuleName, Functor, ArgTerms,
Context, _SeqNum, MaybeIOM) :-
(
ArgTerms = [VNTerm, ModuleNameTerm, VersionNumbersTerm],
( if term_int.decimal_term_to_int(VNTerm, VN) then
( if VN = module_item_version_numbers_version_number then
( if
try_parse_symbol_name(ModuleNameTerm, ModuleName)
then
recompilation.version.parse_module_item_version_numbers(
VersionNumbersTerm, MaybeVersionNumbers),
(
MaybeVersionNumbers = ok1(VersionNumbers),
IOM = iom_marker_version_numbers(VersionNumbers),
MaybeIOM = ok1(IOM)
;
MaybeVersionNumbers = error1(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: invalid module name in"),
decl("version_numbers"), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(ModuleNameTerm), Pieces),
MaybeIOM = error1([Spec])
)
else
Pieces = [words("Error: the interface file"),
words("was created by an obsolete compiler,"),
words("so it must be rebuilt."), nl],
Spec = conditional_spec($pred, warn_smart_recompilation, yes,
severity_error, phase_term_to_parse_tree,
[simplest_msg(Context, Pieces)]),
MaybeIOM = ok1(iom_handled_error([Spec]))
)
else
Pieces = [words("Error: invalid version number in"),
decl("version_numbers"), suffix("."), nl],
VersionNumberContext = get_term_context(VersionNumbersTerm),
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, VersionNumberContext, Pieces),
MaybeIOM = error1([Spec])
)
;
( ArgTerms = []
; ArgTerms = [_]
; ArgTerms = [_, _]
; ArgTerms = [_, _, _, _ | _]
),
Pieces = [words("Error: a"), decl(Functor), words("declaration"),
words("should have exactly three arguments,"),
words("which should be a version number,"),
words("a module name, and a tuple containing maps"),
words("from item ids to timestamps."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- pred parse_clause(maybe(module_name)::in, varset::in, term::in, term::in,
term.context::in, item_seq_num::in, maybe1(item_clause_info)::out) is det.
parse_clause(MaybeModuleName, VarSet0, HeadTerm, BodyTerm0, Context, SeqNum,
MaybeClause) :-
varset.coerce(VarSet0, ProgVarSet0),
GoalContextPieces = cord.init,
trace [compile_time(flag("print_parse_goal_input")),
runtime(env("PRINT_PARSE_GOAL_INPUT")), io(!IO)]
(
io.stderr_stream(StdErr, !IO),
io.nl(StdErr, !IO),
write_doc(StdErr, pretty_printer.format(BodyTerm0), !IO),
io.nl(StdErr, !IO)
),
parse_goal(BodyTerm0, GoalContextPieces, MaybeBodyGoal,
ProgVarSet0, ProgVarSet),
varset.coerce(ProgVarSet, VarSet),
( if
HeadTerm = term.functor(term.atom("="),
[FuncHeadTerm0, FuncResultTerm0], _),
FuncHeadTerm = desugar_field_access(FuncHeadTerm0)
then
MaybeFuncResultTerm = yes(FuncResultTerm0),
( if
is_the_name_a_variable(VarSet0, vtk_clause_func, FuncHeadTerm,
Spec)
then
MaybeFunctor = error2([Spec])
else
HeadContextPieces =
cord.from_list([words("In equation head:"), nl]),
(
MaybeModuleName = no,
parse_sym_name_and_args(VarSet,
HeadContextPieces, FuncHeadTerm, MaybeFunctor)
;
MaybeModuleName = yes(ModuleName),
parse_implicitly_qualified_sym_name_and_args(ModuleName,
VarSet, HeadContextPieces, FuncHeadTerm, MaybeFunctor)
)
)
else
MaybeFuncResultTerm = no,
( if
is_the_name_a_variable(VarSet0, vtk_clause_pred, HeadTerm, Spec)
then
MaybeFunctor = error2([Spec])
else
HeadContextPieces =
cord.from_list([words("In clause head:"), nl]),
(
MaybeModuleName = no,
parse_sym_name_and_args(VarSet,
HeadContextPieces, HeadTerm, MaybeFunctor)
;
MaybeModuleName = yes(ModuleName),
parse_implicitly_qualified_sym_name_and_args(ModuleName,
VarSet, HeadContextPieces, HeadTerm, MaybeFunctor)
)
)
),
(
MaybeFunctor = ok2(SymName, ArgTerms0),
(
MaybeFuncResultTerm = yes(FuncResultTerm),
PredOrFunc = pf_function,
ArgTerms = ArgTerms0 ++ [FuncResultTerm]
;
MaybeFuncResultTerm = no,
PredOrFunc = pf_predicate,
ArgTerms = ArgTerms0
),
list.map(term.coerce, ArgTerms, ProgArgTerms),
trace [compile_time(flag("print_parse_goal_output")),
runtime(env("PRINT_PARSE_GOAL_OUTPUT")), io(!IO)]
(
io.stderr_stream(StdErr, !IO),
( if
unqualify_name(SymName) = "pred_you_want_to_debug"
then
(
MaybeBodyGoal = ok2(Goal, _),
io.nl(StdErr, !IO),
io.format(StdErr, "parsed %s/%d:\n",
[s(sym_name_to_string(SymName)),
i(list.length(ProgArgTerms))], !IO),
mercury_format_goal(StdErr, ProgVarSet, 0, Goal, !IO),
io.nl(StdErr, !IO)
;
MaybeBodyGoal = error2(_),
io.format(StdErr, "parsing %s/%d failed\n",
[s(sym_name_to_string(SymName)),
i(list.length(ProgArgTerms))], !IO)
)
else
true
)
),
ItemClause = item_clause_info(PredOrFunc, SymName, ProgArgTerms,
ProgVarSet, MaybeBodyGoal, Context, SeqNum),
MaybeClause = ok1(ItemClause)
;
MaybeFunctor = error2(FunctorSpecs),
Specs = FunctorSpecs ++ get_any_errors_warnings2(MaybeBodyGoal),
MaybeClause = error1(Specs)
).
%---------------------------------------------------------------------------%
%
% Parsing ":- pred" and ":- func" declarations.
%
% parse_pred_or_func_decl parses a predicate or function declaration.
%
:- pred parse_pred_or_func_decl_item(module_name::in, varset::in,
string::in, list(term)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
pred_or_func::in, list(purity_attr)::in, list(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_pred_or_func_decl_item(ModuleName, VarSet, Functor, ArgTerms,
IsInClass, Context, SeqNum, PredOrFunc, PurityAttrs, QuantConstrAttrs,
MaybeIOM) :-
(
ArgTerms = [Term],
(
IsInClass = decl_is_in_class,
PredOrFuncDeclPieces = [words("type class"), p_or_f(PredOrFunc),
words("method declaration:"), nl]
;
IsInClass = decl_is_not_in_class,
PredOrFuncDeclPieces =
[p_or_f(PredOrFunc), words("declaration:"), nl]
),
DetismContextPieces =
cord.from_list([words("In")] ++ PredOrFuncDeclPieces),
parse_determinism_suffix(VarSet, DetismContextPieces, Term,
BeforeDetismTerm, MaybeMaybeDetism),
WithInstContextPieces = cord.from_list([
words("In the"), quote("with_inst"), words("annotation of a")] ++
PredOrFuncDeclPieces),
parse_with_inst_suffix(VarSet, WithInstContextPieces,
BeforeDetismTerm, BeforeWithInstTerm, MaybeWithInst),
parse_with_type_suffix(VarSet, BeforeWithInstTerm, BeforeWithTypeTerm,
MaybeWithType),
BaseTerm = BeforeWithTypeTerm,
( if
MaybeMaybeDetism = ok1(MaybeDetism),
MaybeWithInst = ok1(WithInst),
MaybeWithType = ok1(WithType)
then
( if
WithInst = yes(_),
MaybeDetism = yes(_)
then
Pieces = [words("Error:"), quote("with_inst"),
words("and determinism both specified."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(BaseTerm), Pieces),
MaybeIOM = error1([Spec])
else if
WithInst = yes(_),
WithType = no
then
Pieces = [words("Error:"), quote("with_inst"),
words("specified"), words("without"),
quote("with_type"), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(BaseTerm), Pieces),
MaybeIOM = error1([Spec])
else
( if
% Function declarations with `with_type` annotations
% have the same form as predicate declarations.
PredOrFunc = pf_function,
WithType = no
then
parse_func_decl_base(ModuleName, VarSet,
BaseTerm, MaybeDetism, IsInClass,
Context, SeqNum, PurityAttrs, QuantConstrAttrs,
MaybeIOM)
else
parse_pred_decl_base(PredOrFunc, ModuleName, VarSet,
BaseTerm, WithType, WithInst, MaybeDetism,
IsInClass, Context, SeqNum, PurityAttrs,
QuantConstrAttrs, MaybeIOM)
)
)
else
Specs = get_any_errors1(MaybeMaybeDetism)
++ get_any_errors1(MaybeWithInst)
++ get_any_errors1(MaybeWithType),
MaybeIOM = error1(Specs)
)
;
( ArgTerms = []
; ArgTerms = [_, _ | _]
),
% Should we mention the determinism? It is allowed only
% in predicate declarations that specify the modes, so the
% wording required would probably be more confusing than helpful.
Pieces = [words("Error: a"), decl(Functor), words("declaration"),
words("should have just one argument,"),
words("which should specify the types and maybe the modes"),
words("of the arguments of a"), words(Functor), suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
% parse a `:- pred p(...)' declaration or a
% `:- func f(...) `with_type` t' declaration
%
:- pred parse_pred_decl_base(pred_or_func::in, module_name::in, varset::in,
term::in, maybe(mer_type)::in, maybe(mer_inst)::in,
maybe(determinism)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
list(purity_attr)::in, list(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_pred_decl_base(PredOrFunc, ModuleName, VarSet, PredTypeTerm,
WithType, WithInst, MaybeDet, IsInClass, Context, SeqNum,
PurityAttrs, QuantConstrAttrs, MaybeIOM) :-
ContextPieces = cord.singleton(words("In")) ++
cord.from_list(pred_or_func_decl_pieces(PredOrFunc)) ++
cord.from_list([suffix(":"), nl]),
get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet,
QuantConstrAttrs, ContextPieces, MaybeExistClassInstContext),
get_purity_from_attrs(Context, PurityAttrs, MaybePurity),
( if
MaybeExistClassInstContext =
ok3(ExistQVars, Constraints, InstConstraints),
MaybePurity = ok1(Purity)
then
% The term parser turns "X(a, b)" into "`'(X, a, b)".
( if
is_the_name_a_variable(VarSet, vtk_type_decl_pred(IsInClass),
PredTypeTerm, Spec)
then
MaybeIOM = error1([Spec])
else
parse_implicitly_qualified_sym_name_and_args(ModuleName,
VarSet, ContextPieces, PredTypeTerm, MaybePredNameAndArgs),
(
MaybePredNameAndArgs = error2(Specs),
MaybeIOM = error1(Specs)
;
MaybePredNameAndArgs = ok2(Functor, ArgTerms),
ArgContextFunc =
( func(ArgNum) = ContextPieces ++
cord.from_list([words("in the"), nth_fixed(ArgNum),
words("argument:"), nl])
),
parse_type_and_modes(constrain_some_inst_vars(InstConstraints),
dont_require_tm_mode, wnhii_pred_arg, VarSet,
ArgContextFunc, ArgTerms, 1, TypesAndModes, [], TMSpecs),
check_type_and_mode_list_is_consistent(TypesAndModes, no,
get_term_context(PredTypeTerm), MaybeTypeModeListKind),
( if
TMSpecs = [],
MaybeTypeModeListKind = ok1(_)
then
( if
WithInst = yes(_),
TypesAndModes = [type_only(_) | _]
then
Pieces = [words("Error:"), quote("with_inst"),
words("specified without argument modes."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(PredTypeTerm), Pieces),
MaybeIOM = error1([Spec])
else if
WithInst = no,
WithType = yes(_),
TypesAndModes = [type_and_mode(_, _) | _]
then
Pieces = [words("Error: arguments have modes but"),
quote("with_inst"), words("not specified."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(PredTypeTerm), Pieces),
MaybeIOM = error1([Spec])
else
varset.coerce(VarSet, TypeVarSet),
varset.coerce(VarSet, InstVarSet),
inconsistent_constrained_inst_vars_in_type_and_modes(
TypesAndModes, InconsistentVars),
report_inconsistent_constrained_inst_vars(
in_pred_or_func_decl_desc(PredOrFunc),
get_term_context(PredTypeTerm),
InstVarSet, InconsistentVars,
MaybeInconsistentSpec),
(
MaybeInconsistentSpec = no,
Origin = item_origin_user,
ItemPredDecl = item_pred_decl_info(Functor,
PredOrFunc, TypesAndModes, WithType, WithInst,
MaybeDet, Origin, TypeVarSet, InstVarSet,
ExistQVars, Purity, Constraints,
Context, SeqNum),
Item = item_pred_decl(ItemPredDecl),
MaybeIOM = ok1(iom_item(Item))
;
MaybeInconsistentSpec = yes(Spec),
MaybeIOM = error1([Spec])
)
)
else
Specs = TMSpecs ++ get_any_errors1(MaybeTypeModeListKind),
MaybeIOM = error1(Specs)
)
)
)
else
Specs = get_any_errors1(MaybePurity) ++
get_any_errors3(MaybeExistClassInstContext),
MaybeIOM = error1(Specs)
).
% Parse a `:- func p(...)' declaration *without* a with_type clause.
%
:- pred parse_func_decl_base(module_name::in, varset::in, term::in,
maybe(determinism)::in, decl_in_class::in,
prog_context::in, item_seq_num::in,
list(purity_attr)::in, list(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_func_decl_base(ModuleName, VarSet, Term, MaybeDet, IsInClass, Context,
SeqNum, PurityAttrs, QuantConstrAttrs, MaybeIOM) :-
ContextPieces = cord.from_list([words("In"), decl("func"),
words("declaration:"), nl]),
get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet,
QuantConstrAttrs, ContextPieces, MaybeContext),
(
MaybeContext = error3(Specs),
MaybeIOM = error1(Specs)
;
MaybeContext = ok3(ExistQVars, Constraints, InstConstraints),
( if
Term = term.functor(term.atom("="),
[MaybeSugaredFuncTerm, ReturnTerm], _)
then
% The term parser turns "X(a, b)" into "`'(X, a, b)".
( if
is_the_name_a_variable(VarSet, vtk_type_decl_func(IsInClass),
MaybeSugaredFuncTerm, Spec)
then
MaybeIOM = error1([Spec])
else
FuncTerm = desugar_field_access(MaybeSugaredFuncTerm),
parse_implicitly_qualified_sym_name_and_args(ModuleName,
VarSet, ContextPieces, FuncTerm, MaybeFuncNameAndArgs),
(
MaybeFuncNameAndArgs = error2(Specs),
MaybeIOM = error1(Specs)
;
MaybeFuncNameAndArgs = ok2(FuncName, ArgTerms),
ArgContextFunc =
( func(ArgNum) = ContextPieces ++
cord.from_list([words("in the"), nth_fixed(ArgNum),
words("argument:"), nl])
),
parse_type_and_modes(
constrain_some_inst_vars(InstConstraints),
dont_require_tm_mode, wnhii_func_arg,
VarSet, ArgContextFunc, ArgTerms, 1,
ArgTypesAndModes, [], ArgTMSpecs),
RetContextPieces = ContextPieces ++
cord.from_list([words("in the return value:"), nl]),
parse_type_and_mode(
constrain_some_inst_vars(InstConstraints),
dont_require_tm_mode, wnhii_func_return_arg,
VarSet, RetContextPieces, ReturnTerm,
MaybeRetTypeAndMode),
( if
ArgTMSpecs = [],
MaybeRetTypeAndMode = ok1(RetTypeAndMode)
then
% We use an auxiliary predicate because the code is
% just too deeply indented here.
parse_func_decl_base_2(FuncName,
ArgTypesAndModes, RetTypeAndMode,
FuncTerm, Term, VarSet, MaybeDet,
ExistQVars, Constraints, Context, SeqNum,
PurityAttrs, MaybeIOM)
else
Specs =
ArgTMSpecs ++ get_any_errors1(MaybeRetTypeAndMode),
MaybeIOM = error1(Specs)
)
)
)
else
Pieces = [words("Error:"), quote("="), words("expected in"),
decl("func"), words("declaration."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(Term), Pieces),
MaybeIOM = error1([Spec])
)
).
:- pred parse_func_decl_base_2(sym_name::in, list(type_and_mode)::in,
type_and_mode::in, term::in, term::in, varset::in, maybe(determinism)::in,
existq_tvars::in, prog_constraints::in,
prog_context::in, item_seq_num::in,
list(purity_attr)::in, maybe1(item_or_marker)::out) is det.
parse_func_decl_base_2(FuncName, Args, ReturnArg, FuncTerm, Term,
VarSet, MaybeDetism, ExistQVars, Constraints, Context, SeqNum,
PurityAttrs, MaybeIOM) :-
check_type_and_mode_list_is_consistent(Args, yes(ReturnArg),
get_term_context(FuncTerm), MaybeTypeModeListKind),
get_purity_from_attrs(Context, PurityAttrs, MaybePurity),
( if
MaybeTypeModeListKind = ok1(_),
MaybePurity = ok1(Purity)
then
varset.coerce(VarSet, TVarSet),
varset.coerce(VarSet, IVarSet),
AllArgs = Args ++ [ReturnArg],
inconsistent_constrained_inst_vars_in_type_and_modes(AllArgs,
InconsistentVars),
report_inconsistent_constrained_inst_vars("in function declaration",
get_term_context(Term),
IVarSet, InconsistentVars, MaybeInconsistentSpec),
(
MaybeInconsistentSpec = no,
Origin = item_origin_user,
ItemPredDecl = item_pred_decl_info(FuncName, pf_function, AllArgs,
no, no, MaybeDetism, Origin, TVarSet, IVarSet, ExistQVars,
Purity, Constraints, Context, SeqNum),
Item = item_pred_decl(ItemPredDecl),
MaybeIOM = ok1(iom_item(Item))
;
MaybeInconsistentSpec = yes(Spec),
MaybeIOM = error1([Spec])
)
else
Specs = get_any_errors1(MaybeTypeModeListKind)
++ get_any_errors1(MaybePurity),
MaybeIOM = error1(Specs)
).
:- type type_mode_list_kind
---> tml_no_arguments
% There are zero arguments.
; tml_all_types_have_modes
% There are some arguments, and they all have modes.
; tml_no_types_have_modes.
% There are some arguments, and none have modes.
% Verify that among the arguments of a :- pred or :- func declaration,
% either all arguments specify a mode or none of them do. If some do
% and some don't, return an error message that identifies the argument
% positions that are missing modes. (If some argument positions have
% modes, then the programmer probably intended for all of them to have
% modes.)
%
:- pred check_type_and_mode_list_is_consistent(list(type_and_mode)::in,
maybe(type_and_mode)::in, term.context::in,
maybe1(type_mode_list_kind)::out) is det.
check_type_and_mode_list_is_consistent(TypesAndModes, MaybeRetTypeAndMode,
Context, MaybeKind) :-
classify_type_and_mode_list(1, TypesAndModes,
WithModeArgNums0, WithoutModeArgNums0),
(
MaybeRetTypeAndMode = no,
WithModeArgNums = WithModeArgNums0,
WithoutModeArgNums = WithoutModeArgNums0
;
MaybeRetTypeAndMode = yes(RetTypeAndMode),
(
RetTypeAndMode = type_only(_),
WithModeArgNums = WithModeArgNums0,
WithoutModeArgNums = WithoutModeArgNums0 ++ [-1]
;
RetTypeAndMode = type_and_mode(_, _),
WithModeArgNums = WithModeArgNums0 ++ [-1],
WithoutModeArgNums = WithoutModeArgNums0
)
),
(
WithModeArgNums = [],
WithoutModeArgNums = [],
% No arguments; no possibility of inconsistency.
MaybeKind = ok1(tml_no_arguments)
;
WithModeArgNums = [],
WithoutModeArgNums = [_ | _],
% No arguments have modes; no inconsistency.
MaybeKind = ok1(tml_no_types_have_modes)
;
WithModeArgNums = [_ | _],
WithoutModeArgNums = [],
% All arguments have modes; no inconsistency.
MaybeKind = ok1(tml_all_types_have_modes)
;
WithModeArgNums = [_ | _],
WithoutModeArgNums = [FirstWithout | RestWithout],
% Some arguments have modes and some don't, which is inconsistent.
(
RestWithout = [],
IdPieces = [words("The argument without a mode is the"),
wrap_nth(dont_add_the_prefix, FirstWithout), suffix("."), nl]
;
RestWithout = [_ | _],
% If the return value is one of the arguments without a mode,
% then the "the" prefix before "return value" will come *after*
% at least one argument number, to give a message such as
% "The arguments without modes are the second and the return
% value.".
WithoutArgNumPieces =
list.map(wrap_nth(add_the_prefix), WithoutModeArgNums),
WithoutArgNumsPieces =
component_list_to_pieces("and", WithoutArgNumPieces),
IdPieces = [words("The arguments without modes are the") |
WithoutArgNumsPieces] ++ [suffix("."), nl]
),
Pieces = [words("Error: some but not all arguments have modes."), nl
| IdPieces],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeKind = error1([Spec])
).
:- pred classify_type_and_mode_list(int::in, list(type_and_mode)::in,
list(int)::out, list(int)::out) is det.
classify_type_and_mode_list(_, [], [], []).
classify_type_and_mode_list(ArgNum, [Head | Tail],
WithModeArgNums, WithoutModeArgNums) :-
classify_type_and_mode_list(ArgNum + 1, Tail,
WithModeArgNums0, WithoutModeArgNums0),
(
Head = type_only(_),
WithModeArgNums = WithModeArgNums0,
WithoutModeArgNums = [ArgNum | WithoutModeArgNums0]
;
Head = type_and_mode(_, _),
WithModeArgNums = [ArgNum | WithModeArgNums0],
WithoutModeArgNums = WithoutModeArgNums0
).
:- type maybe_add_the_prefix
---> dont_add_the_prefix
; add_the_prefix.
:- func wrap_nth(maybe_add_the_prefix, int) = format_piece.
wrap_nth(MaybeAddPredix, ArgNum) = Component :-
( if ArgNum < 0 then
(
MaybeAddPredix = dont_add_the_prefix,
Component = words("return value")
;
MaybeAddPredix = add_the_prefix,
Component = words("the return value")
)
else
Component = nth_fixed(ArgNum)
).
%---------------------------------------------------------------------------%
%
% Parsing mode declarations for predicates and functions.
%
:- pred parse_mode_decl(module_name::in, varset::in, term::in,
decl_in_class::in, prog_context::in, item_seq_num::in,
list(quant_constr_attr)::in, maybe1(item_or_marker)::out) is det.
parse_mode_decl(ModuleName, VarSet, Term, IsInClass, Context, SeqNum,
QuantConstrAttrs, MaybeIOM) :-
(
IsInClass = decl_is_in_class,
DeclWords = words("type class method mode")
;
IsInClass = decl_is_not_in_class,
DeclWords = words("mode")
),
DetismContextPieces = cord.from_list([
words("In"), DeclWords, words("declaration:")
]),
parse_determinism_suffix(VarSet, DetismContextPieces, Term,
BeforeDetismTerm, MaybeMaybeDetism),
WithInstContextPieces = cord.from_list([
words("In the"), quote("with_inst"), words("annotation of a"),
DeclWords, words("declaration:")]),
parse_with_inst_suffix(VarSet, WithInstContextPieces, BeforeDetismTerm,
BeforeWithInstTerm, MaybeWithInst),
BaseTerm = BeforeWithInstTerm,
( if
MaybeMaybeDetism = ok1(MaybeDetism),
MaybeWithInst = ok1(WithInst)
then
( if
MaybeDetism = yes(_),
WithInst = yes(_)
then
Pieces = [words("Error:"), quote("with_inst"),
words("and determinism both specified."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(Term), Pieces),
MaybeIOM = error1([Spec])
else
parse_mode_decl_base(ModuleName, VarSet, BaseTerm, IsInClass,
Context, SeqNum, WithInst, MaybeDetism, QuantConstrAttrs,
MaybeIOM)
)
else
Specs = get_any_errors1(MaybeMaybeDetism)
++ get_any_errors1(MaybeWithInst),
MaybeIOM = error1(Specs)
).
:- pred parse_mode_decl_base(module_name::in, varset::in, term::in,
decl_in_class::in, prog_context::in, item_seq_num::in,
maybe(mer_inst)::in, maybe(determinism)::in, list(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_mode_decl_base(ModuleName, VarSet, Term, IsInClass, Context, SeqNum,
WithInst, MaybeDet, QuantConstrAttrs, MaybeIOM) :-
( if
WithInst = no,
Term = term.functor(term.atom("="),
[MaybeSugaredFuncTerm, ReturnTypeTerm], _)
then
% The term parser turns "X(a, b)" into "`'(X, a, b)".
( if
is_the_name_a_variable(VarSet, vtk_mode_decl_func(IsInClass),
MaybeSugaredFuncTerm, Spec)
then
MaybeIOM = error1([Spec])
else
FuncTerm = desugar_field_access(MaybeSugaredFuncTerm),
ContextPieces = cord.from_list([words("In function"), decl("mode"),
words("declaration:"), nl]),
parse_implicitly_qualified_sym_name_and_args(ModuleName,
VarSet, ContextPieces, FuncTerm, MaybeFunctorArgs),
(
MaybeFunctorArgs = error2(Specs),
MaybeIOM = error1(Specs)
;
MaybeFunctorArgs = ok2(Functor, ArgTerms),
parse_func_mode_decl(Functor, ArgTerms, ModuleName,
ReturnTypeTerm, Term, VarSet, MaybeDet, Context, SeqNum,
QuantConstrAttrs, MaybeIOM)
)
)
else
% The term parser turns "X(a, b)" into "`'(X, a, b)".
( if
is_the_name_a_variable(VarSet, vtk_mode_decl_pred(IsInClass),
Term, Spec)
then
MaybeIOM = error1([Spec])
else
ContextPieces = cord.from_list([words("In"), decl("mode"),
words("declaration:"), nl]),
parse_implicitly_qualified_sym_name_and_args(ModuleName,
VarSet, ContextPieces, Term, MaybeFunctorArgs),
(
MaybeFunctorArgs = error2(Specs),
MaybeIOM = error1(Specs)
;
MaybeFunctorArgs = ok2(Functor, ArgTerms),
parse_pred_mode_decl(Functor, ArgTerms, ModuleName, Term,
VarSet, WithInst, MaybeDet,
Context, SeqNum, QuantConstrAttrs, MaybeIOM)
)
)
).
:- pred parse_pred_mode_decl(sym_name::in, list(term)::in, module_name::in,
term::in, varset::in, maybe(mer_inst)::in, maybe(determinism)::in,
prog_context::in, item_seq_num::in, list(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_pred_mode_decl(Functor, ArgTerms, ModuleName, PredModeTerm, VarSet,
WithInst, MaybeDet, Context, SeqNum, QuantConstrAttrs, MaybeIOM) :-
ArgContextPieces = cord.from_list(
[words("In the mode declaration of the predicate"),
unqual_sym_name(Functor), suffix(":"), nl]),
parse_modes(allow_constrained_inst_var, VarSet, ArgContextPieces,
ArgTerms, MaybeArgModes0),
ContextPieces = cord.from_list([words("In predicate"), decl("mode"),
words("declaration:"), nl]),
get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet,
QuantConstrAttrs, ContextPieces, MaybeConstraints),
( if
MaybeArgModes0 = ok1(ArgModes0),
MaybeConstraints = ok3(_, _, InstConstraints)
then
list.map(constrain_inst_vars_in_mode_sub(InstConstraints),
ArgModes0, ArgModes),
varset.coerce(VarSet, InstVarSet),
inconsistent_constrained_inst_vars_in_modes(ArgModes,
InconsistentVars),
report_inconsistent_constrained_inst_vars(
"in predicate mode declaration", get_term_context(PredModeTerm),
InstVarSet, InconsistentVars, MaybeInconsistentSpec),
(
MaybeInconsistentSpec = no,
(
WithInst = no,
MaybePredOrFunc = yes(pf_predicate)
;
WithInst = yes(_),
% We don't know whether it is a predicate or a function
% until we expand out the inst.
MaybePredOrFunc = no
),
ItemModeDecl = item_mode_decl_info(Functor, MaybePredOrFunc,
ArgModes, WithInst, MaybeDet, InstVarSet, Context, SeqNum),
Item = item_mode_decl(ItemModeDecl),
MaybeIOM = ok1(iom_item(Item))
;
MaybeInconsistentSpec = yes(Spec),
MaybeIOM = error1([Spec])
)
else
Specs = get_any_errors1(MaybeArgModes0)
++ get_any_errors3(MaybeConstraints),
MaybeIOM = error1(Specs)
).
:- pred parse_func_mode_decl(sym_name::in, list(term)::in, module_name::in,
term::in, term::in, varset::in, maybe(determinism)::in,
prog_context::in, item_seq_num::in, list(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_func_mode_decl(Functor, ArgTerms, ModuleName, RetModeTerm, FullTerm,
VarSet, MaybeDetism, Context, SeqNum, QuantConstrAttrs, MaybeIOM) :-
ArgContextPieces = cord.from_list(
[words("In the mode declaration of the function"),
unqual_sym_name(Functor), suffix(":"), nl]),
parse_modes(allow_constrained_inst_var, VarSet, ArgContextPieces,
ArgTerms, MaybeArgModes0),
RetContextPieces = cord.from_list([words("In the return value"),
words("of the mode declaration of the function"),
unqual_sym_name(Functor), suffix(":"), nl]),
parse_mode(allow_constrained_inst_var, VarSet, RetContextPieces,
RetModeTerm, MaybeRetMode0),
QuantContextPieces = cord.from_list([words("In function"), decl("mode"),
words("declaration:"), nl]),
get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet,
QuantConstrAttrs, QuantContextPieces, MaybeConstraints),
( if
MaybeArgModes0 = ok1(ArgModes0),
MaybeRetMode0 = ok1(RetMode0),
MaybeConstraints = ok3(_, _, InstConstraints)
then
list.map(constrain_inst_vars_in_mode_sub(InstConstraints),
ArgModes0, ArgModes),
constrain_inst_vars_in_mode_sub(InstConstraints,
RetMode0, RetMode),
varset.coerce(VarSet, InstVarSet),
ArgReturnModes = ArgModes ++ [RetMode],
inconsistent_constrained_inst_vars_in_modes(ArgReturnModes,
InconsistentVars),
report_inconsistent_constrained_inst_vars(
"in function mode declaration", get_term_context(FullTerm),
InstVarSet, InconsistentVars, MaybeInconsistentSpec),
(
MaybeInconsistentSpec = no,
ItemModeDecl = item_mode_decl_info(Functor,
yes(pf_function), ArgReturnModes, no, MaybeDetism,
InstVarSet, Context, SeqNum),
Item = item_mode_decl(ItemModeDecl),
MaybeIOM = ok1(iom_item(Item))
;
MaybeInconsistentSpec = yes(Spec),
MaybeIOM = error1([Spec])
)
else
Specs = get_any_errors1(MaybeArgModes0)
++ get_any_errors1(MaybeRetMode0)
++ get_any_errors3(MaybeConstraints),
MaybeIOM = error1(Specs)
).
%---------------------------------------------------------------------------%
:- pred get_purity_from_attrs(prog_context::in, list(purity_attr)::in,
maybe1(purity)::out) is det.
get_purity_from_attrs(_Context, [], ok1(purity_pure)).
get_purity_from_attrs(Context, [PurityAttr | PurityAttrs], MaybePurity) :-
PurityAttr = purity_attr(Purity),
(
PurityAttrs = [],
MaybePurity = ok1(Purity)
;
PurityAttrs = [_ | _],
Pieces = [words("Error: duplicate purity annotations"),
words("are not allowed."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybePurity = error1([Spec])
).
%---------------------------------------------------------------------------%
% We could perhaps get rid of some code duplication between here and
% parse_class.m?
% XXX This documentation is out of date.
% get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet,
% QuantConstrAttrs, ContextPieces, MaybeExistClassInstContext):
%
% Parse type quantifiers, type class constraints and inst constraints
% from the attributes in QuantConstrAttrs.
%
% In the absence of any errors, return MaybeExistClassInstContext
% as a triple of ExistQVars, ClassConstraints, and InstConstraints,
% with ExistQVars listing the existentially quantified variables,
% ClassConstraints listing both the universal and existential type
% class constraints, and InstConstraints mapping each inst variable
% to the (smallest) constraint containing them.
% XXX The "smallest" part of that is almost certainly bug.
%
:- pred get_class_context_and_inst_constraints_from_attrs(module_name::in,
varset::in, list(quant_constr_attr)::in, cord(format_piece)::in,
maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det.
get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet,
QuantConstrAttrs, ContextPieces, MaybeExistClassInstContext) :-
% When we reach here, QuantConstrAttrs contains declaration attributes
% in the outermost to innermost order.
%
% Constraints and quantifiers should occur in the following order,
% outermost to innermost:
%
% operator precedence
% -------- ----------
% 1. universal quantifiers all 550
% 2. existential quantifiers some 550
% 3. universal constraints <= 580
% 4. existential constraints => 580 [*]
% 5. the decl itself pred or func 700
%
% [*] Note that the semantic meaning of `=>' is not quite the same
% as implication; logically speaking it's more like conjunction.
% Oh well, at least it has the right precedence.
%
% In theory it could make sense to allow the order of 2 & 3 to be
% swapped, or (in the case of multiple constraints & multiple
% quantifiers) to allow arbitrary interleaving of 2 & 3, but in
% practice it seems there would be little benefit in allowing that
% flexibility, so we don't.
%
% NOTE We do NOT check that the order above is actually followed.
%
% Universal quantification is the default, so we just ignore
% universal quantifiers. (XXX It might be a good idea to check that
% any universally quantified type variables (a) do actually occur SOMEWHERE
% in the type declaration, and (2) are not also existentially quantified.
% If either of these checks fail, we should issue an error message.)
get_class_context_and_inst_constraints_loop(ModuleName, VarSet,
QuantConstrAttrs, ContextPieces, [], Specs,
cord.init, _UnivQVarsCord, cord.init, ExistQVarsCord,
cord.init, UnivClassConstraints, map.init, UnivInstConstraints,
cord.init, ExistClassConstraints, map.init, ExistInstConstraints),
ExistQVars0 = cord.list(ExistQVarsCord),
list.map(term.coerce_var, ExistQVars0, ExistQVars),
(
Specs = [],
ClassConstraints = constraints(
cord.list(UnivClassConstraints),
cord.list(ExistClassConstraints)),
InstConstraints =
map.old_merge(UnivInstConstraints, ExistInstConstraints),
MaybeExistClassInstContext = ok3(ExistQVars, ClassConstraints,
InstConstraints)
;
Specs = [_ | _],
MaybeExistClassInstContext = error3(Specs)
).
:- pred get_class_context_and_inst_constraints_loop(module_name::in,
varset::in, list(quant_constr_attr)::in, cord(format_piece)::in,
list(error_spec)::in, list(error_spec)::out,
cord(var)::in, cord(var)::out, cord(var)::in, cord(var)::out,
cord(prog_constraint)::in, cord(prog_constraint)::out,
inst_var_sub::in, inst_var_sub::out,
cord(prog_constraint)::in, cord(prog_constraint)::out,
inst_var_sub::in, inst_var_sub::out) is det.
get_class_context_and_inst_constraints_loop(_ModuleName, _VarSet,
[], _ContextPieces, !Specs, !UnivQVars, !ExistQVars,
!UnivClassConstraints, !UnivInstConstraints,
!ExistvClassConstraints, !ExistvInstConstraints).
get_class_context_and_inst_constraints_loop(ModuleName, VarSet,
[QuantConstrAttr | QuantConstrAttrs], ContextPieces, !Specs,
!UnivQVars, !ExistQVars,
!UnivClassConstraints, !UnivInstConstraints,
!ExistClassConstraints, !ExistInstConstraints) :-
(
QuantConstrAttr = qca_quant_vars(QuantType, VarsTerm),
check_quant_vars(ContextPieces, VarSet, QuantType, VarsTerm,
MaybeVars),
(
MaybeVars = error1(VarsSpecs),
!:Specs = VarsSpecs ++ !.Specs
;
MaybeVars = ok1(Vars),
(
QuantType = quant_type_exist,
!:ExistQVars = !.ExistQVars ++ cord.from_list(Vars)
;
QuantType = quant_type_univ,
!:UnivQVars = !.UnivQVars ++ cord.from_list(Vars)
)
)
;
QuantConstrAttr = qca_constraint(QuantType, ConstraintsTerm),
parse_class_and_inst_constraints(ModuleName, VarSet, ConstraintsTerm,
MaybeConstraints),
(
MaybeConstraints = error2(ConstraintSpecs),
!:Specs = ConstraintSpecs ++ !.Specs
;
MaybeConstraints = ok2(ClassConstraints, InstConstraint),
(
QuantType = quant_type_exist,
!:ExistClassConstraints = !.ExistClassConstraints ++
cord.from_list(ClassConstraints),
!:ExistInstConstraints =
map.old_merge(!.ExistInstConstraints, InstConstraint)
;
QuantType = quant_type_univ,
!:UnivClassConstraints = !.UnivClassConstraints ++
cord.from_list(ClassConstraints),
!:UnivInstConstraints =
map.old_merge(!.UnivInstConstraints, InstConstraint)
)
)
),
get_class_context_and_inst_constraints_loop(ModuleName, VarSet,
QuantConstrAttrs, ContextPieces, !Specs, !UnivQVars, !ExistQVars,
!UnivClassConstraints, !UnivInstConstraints,
!ExistClassConstraints, !ExistInstConstraints).
%---------------------------------------------------------------------------%
:- pred parse_promise_item(varset::in, list(term)::in,
prog_context::in, item_seq_num::in, maybe1(item_or_marker)::out) is det.
parse_promise_item(VarSet, ArgTerms, Context, SeqNum, MaybeIOM) :-
( if ArgTerms = [Term] then
varset.coerce(VarSet, ProgVarSet0),
ContextPieces = cord.init,
parse_goal(Term, ContextPieces, MaybeGoal0, ProgVarSet0, ProgVarSet),
(
MaybeGoal0 = ok2(Goal0, GoalWarningSpecs),
(
GoalWarningSpecs = [],
( if
Goal0 = quant_expr(quant_all, quant_ordinary_vars, _,
UnivVars0, AllGoal)
then
UnivVars0 = UnivVars,
Goal = AllGoal
else
UnivVars = [],
Goal = Goal0
),
ItemPromise = item_promise_info(promise_type_true, Goal,
ProgVarSet, UnivVars, Context, SeqNum),
Item = item_promise(ItemPromise),
MaybeIOM = ok1(iom_item(Item))
;
GoalWarningSpecs = [_ | _],
% We *could* try to preserve any warnings for code
% inside Goal0, and add the promise to the parse tree
% for later addition to the HLDS even in the presence
% of such warnings, but there doesn't seem to be any point
% in doing that, because at the moment, the only kind
% of construct that generates warning_specs is a
% disable_warnings scope, and those should NOT be appearing
% in any promise.
MaybeIOM = error1(GoalWarningSpecs)
)
;
MaybeGoal0 = error2(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), decl("promise"), words("declaration"),
words("should have just one argument,"),
words("which should be a goal."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_promise_ex_item(varset::in, string::in, list(term)::in,
prog_context::in, item_seq_num::in, promise_type::in,
cord(purity_attr)::in, cord(quant_constr_attr)::in,
maybe1(item_or_marker)::out) is det.
parse_promise_ex_item(VarSet, Functor, ArgTerms, Context, SeqNum,
PromiseType, PurityAttrCord, QuantConstrAttrCord, MaybeIOM) :-
( if ArgTerms = [Term] then
PurityAttrs = cord.list(PurityAttrCord),
(
PurityAttrs = [],
PuritySpecs = []
;
PurityAttrs = [_ | _],
PurityPieces =
[words("Error: a"), decl(Functor), words("declaration"),
words("may not have a purity attribute."), nl],
PuritySpec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, Context, PurityPieces),
PuritySpecs = [PuritySpec]
),
QuantConstrAttrs = cord.list(QuantConstrAttrCord),
ContextPieces = cord.from_list([words("In"), words(Functor),
words("declaration:"), nl]),
( if
QuantConstrAttrs = [QuantConstrAttr],
QuantConstrAttr = qca_quant_vars(quant_type_univ, VarsTerm)
then
check_quant_vars(ContextPieces, VarSet, quant_type_univ, VarsTerm,
MaybeUnivVars)
else
UnivVarsPieces =
[words("Error: a"), decl(Functor), words("declaration"),
words("must have the form"),
quote(":- all [<vars>] " ++ Functor ++ " ( <disjunction> )"),
suffix("."), nl],
UnivVarsSpec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, Context, UnivVarsPieces),
MaybeUnivVars = error1([UnivVarsSpec])
),
varset.coerce(VarSet, ProgVarSet0),
parse_goal(Term, ContextPieces, MaybeGoal0, ProgVarSet0, ProgVarSet),
( if
PuritySpecs = [],
MaybeUnivVars = ok1(UnivVars),
MaybeGoal0 = ok2(Goal, GoalWarningSpecs),
% We *could* try to preserve any warnings for code inside Goal,
% and add the promise to the parse tree for later addition
% to the HLDS even in the presence of such warnings, but
% there doesn't seem to be any point in doing that, because
% at the moment, the only kind of construct that generates
% warning_specs is a disable_warnings scope, and those
% should NOT be appearing in any promise.
GoalWarningSpecs = []
then
UnivProgVars = list.map(term.coerce_var, UnivVars),
ItemPromise = item_promise_info(PromiseType, Goal, ProgVarSet,
UnivProgVars, Context, SeqNum),
Item = item_promise(ItemPromise),
MaybeIOM = ok1(iom_item(Item))
else
( MaybeGoal0 = ok2(_, GoalSpecs)
; MaybeGoal0 = error2(GoalSpecs)
),
Specs = PuritySpecs ++ get_any_errors1(MaybeUnivVars) ++ GoalSpecs,
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), decl(Functor), words("declaration"),
words("should have just one argument,"),
words("which should be a goal."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
% parse_determinism_suffix(VarSet, ContextPieces, BodyTerm,
% BeforeDetismTerm, MaybeMaybeDetism):
%
% Look for a suffix of the form "is <detism>" in Term. If we find one,
% bind MaybeMaybeDetism to ok1(yes()) wrapped around the determinism,
% and bind BeforeDetismTerm to the other part of Term. If we don't
% find, one, then bind MaybeMaybeDetism to ok1(no).
%
:- pred parse_determinism_suffix(varset::in, cord(format_piece)::in,
term::in, term::out, maybe1(maybe(determinism))::out) is det.
parse_determinism_suffix(VarSet, ContextPieces, Term, BeforeDetismTerm,
MaybeMaybeDetism) :-
( if
Term = term.functor(term.atom("is"), Args, _),
Args = [BeforeDetismTermPrime, DetismTerm]
then
BeforeDetismTerm = BeforeDetismTermPrime,
( if
DetismTerm = term.functor(term.atom(DetismFunctor), [], _),
standard_det(DetismFunctor, Detism)
then
MaybeMaybeDetism = ok1(yes(Detism))
else
DetismTermStr = describe_error_term(VarSet, DetismTerm),
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
words("Error: invalid determinism category"),
quote(DetismTermStr), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(DetismTerm), Pieces),
MaybeMaybeDetism = error1([Spec])
)
else
BeforeDetismTerm = Term,
MaybeMaybeDetism = ok1(no)
).
% Process the `with_type type` suffix part of a declaration.
%
:- pred parse_with_type_suffix(varset::in, term::in,
term::out, maybe1(maybe(mer_type))::out) is det.
parse_with_type_suffix(VarSet, Term, BeforeWithTypeTerm, MaybeWithType) :-
( if
Term = term.functor(TypeQualifier,
[BeforeWithTypeTermPrime, TypeTerm], _),
( TypeQualifier = term.atom("with_type")
; TypeQualifier = term.atom(":")
)
then
BeforeWithTypeTerm = BeforeWithTypeTermPrime,
ContextPieces = cord.from_list([words("In"), quote("with_type"),
words("annotation:"), nl]),
parse_type(no_allow_ho_inst_info(wnhii_type_qual),
VarSet, ContextPieces, TypeTerm, MaybeType),
(
MaybeType = ok1(Type),
MaybeWithType = ok1(yes(Type))
;
MaybeType = error1(Specs),
MaybeWithType = error1(Specs)
)
else
BeforeWithTypeTerm = Term,
MaybeWithType = ok1(no)
).
% Process the `with_inst inst` suffix part of a declaration.
%
:- pred parse_with_inst_suffix(varset::in, cord(format_piece)::in,
term::in, term::out, maybe1(maybe(mer_inst))::out) is det.
parse_with_inst_suffix(VarSet, ContextPieces, Term,
BeforeWithInstTerm, MaybeWithInst) :-
( if
Term = term.functor(term.atom("with_inst"),
[BeforeWithInstTermPrime, InstTerm], _)
then
BeforeWithInstTerm = BeforeWithInstTermPrime,
parse_inst(allow_constrained_inst_var, VarSet, ContextPieces,
InstTerm, MaybeInst),
(
MaybeInst = ok1(Inst),
MaybeWithInst = ok1(yes(Inst))
;
MaybeInst = error1(Specs),
MaybeWithInst = error1(Specs)
)
else
BeforeWithInstTerm = Term,
MaybeWithInst = ok1(no)
).
%---------------------------------------------------------------------------%
% Perform one of the following field-access syntax rewrites if possible:
%
% A ^ f(B, ...) ---> f(B, ..., A)
% (A ^ f(B, ...) := X) ---> 'f :='(B, ..., A, X)
%
:- func desugar_field_access(term) = term.
desugar_field_access(Term) = DesugaredTerm :-
( if
Term = functor(atom("^"), [A, RHS], Context),
RHS = functor(atom(FieldName), Bs, _)
then
DesugaredTerm = functor(atom(FieldName), Bs ++ [A], Context)
else if
Term = functor(atom(":="), [LHS, X], _),
LHS = functor(atom("^"), [A, RHS], Context),
RHS = functor(atom(FieldName), Bs, _)
then
FunctionName = FieldName ++ " :=",
DesugaredTerm = functor(atom(FunctionName), Bs ++ [A, X], Context)
else
DesugaredTerm = Term
).
%---------------------------------------------------------------------------%
% A ModuleName is just an sym_name.
%
:- pred parse_module_name(varset::in, term::in,
maybe1(module_name)::out) is det.
parse_module_name(VarSet, Term, MaybeModuleName) :-
parse_symbol_name(VarSet, Term, MaybeModuleName).
% A ModuleName is an implicitly-quantified sym_name.
%
% We check for module names starting with capital letters as a special
% case, so that we can report a better error message for that case.
%
:- pred parse_implicitly_qualified_module_name(module_name::in,
varset::in, term::in, maybe1(module_name)::out) is det.
parse_implicitly_qualified_module_name(DefaultModuleName, VarSet, Term,
MaybeModule) :-
(
Term = term.variable(_, Context),
Pieces = [words("Error: module names starting with capital letters"),
words("must be quoted using single quotes"),
words("(e.g. "":- module 'Foo'."")."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeModule = error1([Spec])
;
Term = term.functor(_, _, _),
parse_implicitly_qualified_symbol_name(DefaultModuleName, VarSet,
Term, MaybeModule)
).
%---------------------------------------------------------------------------%
is_the_name_a_variable(VarSet, Kind, Term, Spec) :-
( if Term = term.functor(term.atom(""), ArgTerms, TermContext) then
( if
ArgTerms = [ArgTerm1 | _],
ArgTerm1 = term.variable(_, _)
then
VarStr = describe_error_term(VarSet, ArgTerm1),
VarPieces = [words("such as"), quote(VarStr)]
else
VarPieces = []
),
require_complete_switch [Kind]
(
Kind = vtk_type_decl_pred(IsInClass),
(
IsInClass = decl_is_not_in_class,
WhatPieces = [words("a predicate")]
;
IsInClass = decl_is_in_class,
WhatPieces = [words("a type class predicate method")]
)
;
Kind = vtk_type_decl_func(IsInClass),
(
IsInClass = decl_is_not_in_class,
WhatPieces = [words("a function")]
;
IsInClass = decl_is_in_class,
WhatPieces = [words("a type class function method")]
)
;
Kind = vtk_mode_decl_pred(IsInClass),
(
IsInClass = decl_is_not_in_class,
WhatPieces = [words("a mode for a predicate")]
;
IsInClass = decl_is_in_class,
WhatPieces =
[words("a mode for a type class predicate method")]
)
;
Kind = vtk_mode_decl_func(IsInClass),
(
IsInClass = decl_is_not_in_class,
WhatPieces = [words("a mode for a function")]
;
IsInClass = decl_is_in_class,
WhatPieces = [words("a mode for a type class function method")]
)
;
Kind = vtk_class_decl,
WhatPieces = [words("a type class")]
;
Kind = vtk_instance_decl,
WhatPieces = [words("an instance for a type class")]
;
Kind = vtk_clause_pred,
WhatPieces = [words("a clause for a predicate")]
;
Kind = vtk_clause_func,
WhatPieces = [words("a clause for a function")]
),
Pieces = [words("Error: you cannot declare")] ++ WhatPieces ++
[words("whose name is a variable")] ++ VarPieces ++
[suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
TermContext, Pieces)
else
fail
).
%---------------------------------------------------------------------------%
:- func in_pred_or_func_decl_desc(pred_or_func) = string.
in_pred_or_func_decl_desc(pf_function) = "in function declaration".
in_pred_or_func_decl_desc(pf_predicate) = "in predicate declaration".
:- func pred_or_func_decl_pieces(pred_or_func) = list(format_piece).
pred_or_func_decl_pieces(pf_function) =
[decl("func"), words("declaration")].
pred_or_func_decl_pieces(pf_predicate) =
[decl("pred"), words("declaration")].
%---------------------------------------------------------------------------%
%
% You can uncomment this section for debugging.
%
% :- interface.
%
% :- pred write_item_to_stream(io.text_output_stream::in, item::in,
% io::di, io::uo) is det.
%
% :- pred write_item_to_stdout(item::in, io::di, io::uo) is det.
%
% :- pred write_items_to_file(string::in, list(item)::in, io::di, io::uo)
% is det.
%
% :- implementation.
%
% :- import_module pretty_printer.
%
% write_item_to_stream(Stream, Item, !IO) :-
% write_doc(Stream, format(Item), !IO),
% io.nl(Stream, !IO).
%
% write_item_to_stdout(Item, !IO) :-
% write_item_to_stream(io.stdout_stream, Item, !IO).
%
% write_items_to_file(FileName, Items, !IO) :-
% io.open_output(FileName, Result, !IO),
% (
% Result = ok(Stream),
% list.foldl(write_item_to_stream(Stream), Items, !IO)
% ;
% Result = error(_)
% ).
%---------------------------------------------------------------------------%
:- end_module parse_tree.parse_item.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink