:- module test_op.

% synopsis: Shows the canonical output of a parsed term as defined by
%           various operators.  Allows op/3 declarations as well.

% author:   Douglas M. Auclair (DMA)
% date:     January 5, 2006

:- interface.
:- import_module io.

:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module exception, int, list, map, ops, parser, require.
:- import_module std_util, string, term, term_io, varset, write_canonical.

:- type op_map == map(pair(string, category), op_info).
:- type mercury_op_map ---> mercury_op_map(table, op_map).
:- instance op_table(mercury_op_map).
:- pred init_mercury_op_map(table::in, mercury_op_map::out) is det.

% We expose the op info so we may add information as we encounter op/3
% directives. This means we must also expose the category type.

:- type op_info ---> op_info(specifier, priority).

:- func op_specifier_from_string(string) = specifier.
:- func op_category_from_specifier(specifier) = category.

op_specifier_from_string(String) = Specifier :-
	specifier_from_string(String, Spec) ->
	  Specifier = Spec
	  ;
	  error("Unknown op specifier: " ++ String).

:- pred specifier_from_string(string::in, specifier::out) is semidet.

specifier_from_string("fx", fx).
specifier_from_string("fy", fy).
specifier_from_string("xf", xf).
specifier_from_string("yf", yf).
specifier_from_string("xfx", xfx).
specifier_from_string("yfx", yfx).
specifier_from_string("xfy", xfy).
specifier_from_string("fxx", fxx).
specifier_from_string("fyx", fyx).
specifier_from_string("fxy", fxy).

op_category_from_specifier(fx) = before.
op_category_from_specifier(fy) = before.
op_category_from_specifier(xf) = after.
op_category_from_specifier(yf) = after.
op_category_from_specifier(xfx) = after.
op_category_from_specifier(yfx) = after.
op_category_from_specifier(xfy) = after.
op_category_from_specifier(fxx) = before.
op_category_from_specifier(fyx) = before.
op_category_from_specifier(fxy) = before.

init_mercury_op_map(Table, mercury_op_map(Table, map.init)).

:- pred lookup_info(op_map::in, pair(string, category)::in,
		    priority::out, class::out) is semidet.
lookup_info(Ops, Op - Cat, Priority, Class) :-
	search(Ops, Op - Cat, op_info(Specifier, Priority)),
	op_specifier_to_class(Specifier, Class).

:- instance op_table(mercury_op_map) where [
	(lookup_infix_op(mercury_op_map(Table, Ops), Op, Pri, Left, Right) :-
	    lookup_infix_op(Table, Op, P0, L0, R0) ->
	        Pri = P0,
	        Left = L0,
	        Right = R0
	    ;
	    lookup_info(Ops, Op - after, Pri, infix(Left, Right))),
	(lookup_operator_term(mercury_op_map(Table, _), Pri, Left, Right) :-
	    lookup_operator_term(Table, Pri, Left, Right)),
	(lookup_prefix_op(mercury_op_map(Table, Ops), Op, Pri, After) :-
	    lookup_prefix_op(Table, Op, P0, A0) ->
	        Pri = P0,
	        After = A0
	    ;
	    lookup_info(Ops, Op - before, Pri, prefix(After))),
	(lookup_binary_prefix_op(mercury_op_map(Table, Ops), Op, Pri,
				 Left, Right) :-
	    lookup_binary_prefix_op(Table, Op, P0, L0, R0) ->
	        Pri = P0,
	        Left = L0,
	        Right = R0
	    ;
	    lookup_info(Ops, Op - before, Pri, binary_prefix(Left, Right))),
	(lookup_postfix_op(mercury_op_map(Table, Ops), Op, Pri, Before) :-
	    lookup_postfix_op(Table, Op, P0, B0) ->
	        Pri = P0,
	        Before = B0
	    ;
	    lookup_info(Ops, Op - after, Pri, postfix(Before))),
	(lookup_op(mercury_op_map(Table, Ops), Op) :-
	    lookup_op(Table, Op)
	;
	    search(Ops, Op - before, _)
	;
	    search(Ops, Op - after, _)),
	(max_priority(mercury_op_map(Table, _)) = max_priority(Table)),
	(arg_priority(mercury_op_map(Table, _)) = arg_priority(Table))
].
%-----------------------------------------------------------------------------%

main(!IO) :-
  init_mercury_op_map(init_mercury_op_table, Map),
  intro(!IO),
  gopher_it(Map, !IO).

:- pred intro(state::di, state::uo) is det.

intro -->
  print("test_op.  Enter an op/3 declaration in the following manner:\n"),
  print("\n    :- op(Priority, Specification, Operator).\n\n"),
  print("where Priority is a number (lower is tighter)\n"),
  print("      Specification is 'xfx', 'fy', 'xf' or whatever\n"),
  print("      and Operator is the atom, e.g:\n\n"),
  print("   :- op(800, xfx, plays).\n"),
  print("   :- op(200, fy, the).\n\n"),
  print("Test the operators with a term, terminated with a full stop...\n\n"),
  print("   david plays the lyre.\n\n"),
  print("...which shows the canonical form:\n\n"),
  print("   plays(david, the(lyre)).\n\n").

:- pred gopher_it(mercury_op_map::in, state::di, state::uo) is det.

gopher_it(Map) -->
    write_string("test_op> "),
    flush_output,
    parser.read_term_with_op_table(Map, Res),
    rez_it(Map, Res).

:- pred rez_it(mercury_op_map, read_term(generic), state, state).
:- mode rez_it(in, in, di, uo) is det.

rez_it(Map, error(Msg, _Line)) -->
  format("%s\n", [s(Msg)]),
  gopher_it(Map).
rez_it(_, eof) --> write_string("\nOkay; ciao for now!\n").
rez_it(Ops, term(_VarSet, Term)) -->
  { Term = functor(atom(":-"),
	           [functor(atom("op"),
		            [functor(integer(Priority), [], _),
			     functor(atom(Specification), [], _),
			     functor(atom(Op), [], _)], _)], _) } ->
    { Spec = op_specifier_from_string(Specification),
      Ops = mercury_op_map(T, Map),
      det_insert(Map, Op - op_category_from_specifier(Spec),
	         op_info(Spec, Priority), Map1) },
    format("Added the '%s' operator.\n", [s(Op)]),
    gopher_it(mercury_op_map(T, Map1))
  ;
    write_canonical(Term),
    nl,
    gopher_it(Ops).