yap-6.3/swi/library/prolog_colour.pl

/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@cs.vu.nl
    WWW:           http://www.swi-prolog.org/projects/xpce/
    Copyright (C): 1985-2011, University of Amsterdam
			      VU University Amsterdam

    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

    As a special exception, if you link this library with other files,
    compiled with a Free Software compiler, to produce an executable, this
    library does not by itself cause the resulting executable to be covered
    by the GNU General Public License. This exception does not however
    invalidate any other reasons why the executable file might be covered by
    the GNU General Public License.
*/


:- module(prolog_colour,
	  [ prolog_colourise_stream/3,	% +Stream, +SourceID, :ColourItem
	    prolog_colourise_term/4,	% +Stream, +SourceID, :ColourItem, +Options
	    syntax_colour/2,		% +Class, -Attributes
	    syntax_message//1		% +Class
	  ]).
:- use_module(library(prolog_xref)).
:- use_module(library(predicate_options)).
:- use_module(library(prolog_source)).
:- use_module(library(lists)).
:- use_module(library(operators)).
:- use_module(library(debug)).
:- use_module(library(edit)).
:- use_module(library(error)).
:- use_module(library(option)).
:- use_module(library(record)).
:- if(exists_source(library(pce_meta))).
:- use_module(library(pce_meta)).
:- endif.

:- meta_predicate
	prolog_colourise_stream(+, +, 3),
	prolog_colourise_term(+, +, 3, +).

:- predicate_options(prolog_colourise_term/4, 4,
		     [ subterm_positions(-any)
		     ]).

/** <module> Prolog syntax colouring support.
@ingroup swi

This module defines reusable code to colourise Prolog source.

@tbd: The one-term version
*/


:- multifile
	style/2,			% +ColourClass, -Attributes
	message//1,			% +ColourClass
	term_colours/2,			% +SourceTerm, -ColourSpec
	goal_colours/2,			% +Goal, -ColourSpec
	directive_colours/2,		% +Goal, -ColourSpec
	goal_classification/2.		% +Goal, -Class


:- record
	colour_state(source_id,
		     closure,
		     singletons).

%%	prolog_colourise_stream(+Stream, +SourceID, :ColourItem) is det.
%
%	Determine colour fragments for the data   on Stream. SourceID is
%	the  canonical  identifier  of  the  input    as  known  to  the
%	cross-referencer, i.e., as created using xref_source(SourceID).
%
%	ColourItem is a closure  that  is   called  for  each identified
%	fragment with three additional arguments:
%
%	  * The syntactical category
%	  * Start position (character offset) of the fragment
%	  * Length of the fragment (in characters).

prolog_colourise_stream(Fd, SourceId, ColourItem) :-
	make_colour_state([ source_id(SourceId),
			    closure(ColourItem)
			  ],
			  TB),
	setup_call_cleanup(
	    save_settings(State),
	    colourise_stream(Fd, TB),
	    restore_settings(State)).

colourise_stream(Fd, TB) :-
	(   peek_char(Fd, #)		% skip #! script line
	->  skip(Fd, 10)
	;   true
	),
	repeat,
	    '$set_source_module'(SM, SM),
	    character_count(Fd, Start),
	    catch(read_term(Fd, Term,
			    [ subterm_positions(TermPos),
			      singletons(Singletons),
			      module(SM),
			      comments(Comments)
			    ]),
		  E,
		  read_error(E, TB, Fd, Start)),
	    fix_operators(Term, TB),
	    colour_state_singletons(TB, Singletons),
	    (	colourise_term(Term, TB, TermPos, Comments)
	    ->	true
	    ;	arg(1, TermPos, From),
	        print_message(warning,
			      format('Failed to colourise ~p at index ~d~n',
				     [Term, From]))
	    ),
	    Term == end_of_file, !.

save_settings(state(Style, Esc)) :-
	push_operators([]),
	current_prolog_flag(character_escapes, Esc),
	'$style_check'(Style, Style).

restore_settings(state(Style, Esc)) :-
	set_prolog_flag(character_escapes, Esc),
	'$style_check'(_, Style),
	pop_operators.

%%	read_error(+Error, +TB, +Stream, +Start) is failure.
%
%	If this is a syntax error, create a syntax-error fragment.

read_error(Error, TB, Stream, Start) :-
	(   Error = error(syntax_error(Id), stream(_S, _Line, _LinePos, CharNo))
	->  message_to_string(error(syntax_error(Id), _), Msg),
	    character_count(Stream, End),
	    show_syntax_error(TB, CharNo:Msg, Start-End),
	    fail
	;   throw(Error)
	).

%%	colour_item(+Class, +TB, +Pos) is det.

colour_item(Class, TB, Pos) :-
	arg(1, Pos, Start),
	arg(2, Pos, End),
	Len is End - Start,
	colour_state_closure(TB, Closure),
	call(Closure, Class, Start, Len).


%%	safe_push_op(+Prec, +Type, :Name)
%
%	Define operators into the default source module and register
%	them to be undone by pop_operators/0.

safe_push_op(P, T, N0) :-
	(   N0 = _:_
	->  N = N0
	;   '$set_source_module'(M, M),
	    N = M:N0
	),
	push_op(P, T, N),
	debug(colour, ':- ~w.', [op(P,T,N)]).

%%	fix_operators(+Term, +Src) is det.
%
%	Fix flags that affect the  syntax,   such  as operators and some
%	style checking options. Src is the  canonical source as required
%	by the cross-referencer.

fix_operators((:- Directive), Src) :-
	catch(process_directive(Directive, Src), _, true), !.
fix_operators(_, _).

process_directive(style_check(X), _) :- !,
	style_check(X).
process_directive(op(P,T,N), _) :- !,
	safe_push_op(P, T, N).
process_directive(module(_Name, Export), _) :- !,
	forall(member(op(P,A,N), Export),
	       safe_push_op(P,A,N)).
process_directive(use_module(Spec), Src) :- !,
	catch(process_use_module(Spec, Src), _, true).
process_directive(Directive, Src) :-
	prolog_source:expand((:-Directive), Src, _).

%%	process_use_module(+Imports, +Src)
%
%	Get the exported operators from the referenced files.

process_use_module([], _) :- !.
process_use_module([H|T], Src) :- !,
	process_use_module(H, Src),
	process_use_module(T, Src).
process_use_module(File, Src) :-
	(   xref_public_list(File, _Path, Public, Src)
	->  forall(member(op(P,T,N), Public),
		   safe_push_op(P,T,N))
	;   true
	).

%%	prolog_colourise_term(+Stream, +SourceID, :ColourItem, +Options)
%
%	Colourise    the    next     term      on     Stream.     Unlike
%	prolog_colourise_stream/3, this predicate assumes  it is reading
%	a single term rather than the   entire stream. This implies that
%	it cannot adjust syntax according to directives that preceed it.
%
%	Options:
%
%	  * subterm_positions(-TermPos)
%	  Return complete term-layout.  If an error is read, this is a
%	  term error_position(StartClause, EndClause, ErrorPos)

prolog_colourise_term(Stream, SourceId, ColourItem, Options) :-
	make_colour_state([ source_id(SourceId),
			    closure(ColourItem)
			  ],
			  TB),
	option(subterm_positions(TermPos), Options, _),
	findall(Op, xref_op(SourceId, Op), Ops),
	character_count(Stream, Start),
	read_source_term_at_location(
	    Stream, Term,
	    [ module(prolog_colour),
	      operators(Ops),
	      error(Error),
	      subterm_positions(TermPos),
	      singletons(Singletons),
	      comments(Comments)
	    ]),
	(   var(Error)
	->  colour_state_singletons(TB, Singletons),
	    colour_item(range, TB, TermPos),		% Call to allow clearing
	    colourise_term(Term, TB, TermPos, Comments)
	;   character_count(Stream, End),
	    TermPos = error_position(Start, End, Pos),
	    colour_item(range, TB, TermPos),
	    show_syntax_error(TB, Error, Start-End),
	    Error = Pos:_Message
	).

show_syntax_error(TB, Pos:Message, Range) :-
	End is Pos + 1,
	colour_item(syntax_error(Message, Range), TB, Pos-End).


singleton(Var, TB) :-
	colour_state_singletons(TB, Singletons),
	member_var(Var, Singletons).

member_var(V, [_=V2|_]) :-
	V == V2, !.
member_var(V, [_|T]) :-
	member_var(V, T).

%%	colourise_term(+Term, +TB, +Termpos, +Comments)

colourise_term(Term, TB, TermPos, Comments) :-
	colourise_comments(Comments, TB),
	colourise_term(Term, TB, TermPos).

colourise_comments(-, _).
colourise_comments([], _).
colourise_comments([H|T], TB) :-
	colourise_comment(H, TB),
	colourise_comments(T, TB).

colourise_comment(Pos-Comment, TB) :-
	stream_position_data(char_count, Pos, Start),
	string_length(Comment, Len),
	End is Start + Len + 1,
	colour_item(comment, TB, Start-End).

colourise_term(Term, TB, Pos) :-
	term_colours(Term, FuncSpec-ArgSpecs), !,
	Pos = term_position(_,_,FF,FT,ArgPos),
	specified_item(FuncSpec, Term, TB, FF-FT),
	specified_items(ArgSpecs, Term, TB, ArgPos).
colourise_term((Head :- Body), TB,
	       term_position(F,T,FF,FT,[HP,BP])) :- !,
	colour_item(clause,	    TB,	F-T),
	colour_item(neck(clause),   TB,	FF-FT),
	colourise_clause_head(Head, TB,	HP),
	colourise_body(Body, Head,  TB,	BP).
colourise_term((Head --> Body), TB,			% TBD: expansion!
	       term_position(F,T,FF,FT,[HP,BP])) :- !,
	colour_item(grammar_rule,	TB, F-T),
	colour_item(neck(grammar_rule),	TB, FF-FT),
	colourise_extended_head(Head, 2, TB, HP),
	colourise_dcg(Body, Head,	TB, BP).
colourise_term(:->(Head, Body), TB,
	       term_position(F,T,FF,FT,[HP,BP])) :- !,
	colour_item(method,		TB, F-T),
	colour_item(neck(method(send)),	TB, FF-FT),
	colour_method_head(send(Head),	TB, HP),
	colourise_method_body(Body,	TB, BP).
colourise_term(:<-(Head, Body), TB,
	       term_position(F,T,FF,FT,[HP,BP])) :- !,
	colour_item(method,	       TB, F-T),
	colour_item(neck(method(get)), TB, FF-FT),
	colour_method_head(get(Head),  TB, HP),
	colourise_method_body(Body,    TB, BP).
colourise_term((:- Directive), TB, Pos) :- !,
	colour_item(directive, TB, Pos),
	arg(5, Pos, [ArgPos]),
	colourise_directive(Directive, TB, ArgPos).
colourise_term((?- Directive), TB, Pos) :- !,
	colourise_term((:- Directive), TB, Pos).
colourise_term(end_of_file, _, _) :- !.
colourise_term(Fact, TB, Pos) :- !,
	colour_item(clause, TB,	Pos),
	colourise_clause_head(Fact, TB, Pos).

%%	colourise_extended_head(+Head, +ExtraArgs, +TB, +Pos) is det.
%
%	Colourise a clause-head that  is   extended  by  term_expansion,
%	getting ExtraArgs more  arguments  (e.g.,   DCGs  add  two  more
%	arguments.

colourise_extended_head(Head, N, TB, Pos) :-
	extend(Head, N, TheHead),
	colourise_clause_head(TheHead, TB, Pos).

extend(M:Head, N, M:ExtHead) :-
	nonvar(Head), !,
	extend(Head, N, ExtHead).
extend(Head, N, ExtHead) :-
	callable(Head), !,
	Head =.. List,
	length(Extra, N),
	append(List, Extra, List1),
	ExtHead =.. List1.
extend(Head, _, Head).


colourise_clause_head(Head, TB, Pos) :-
	head_colours(Head, ClassSpec-ArgSpecs), !,
	functor_position(Pos, FPos, ArgPos),
	(   ClassSpec == classify
	->  classify_head(TB, Head, Class)
	;   Class = ClassSpec
	),
	colour_item(head(Class), TB, FPos),
	specified_items(ArgSpecs, Head, TB, ArgPos).
colourise_clause_head(Head, TB, Pos) :-
	functor_position(Pos, FPos, _),
	classify_head(TB, Head, Class),
	colour_item(head(Class), TB, FPos),
	colourise_term_args(Head, TB, Pos).

%	colourise_extern_head(+Head, +Module, +TB, +Pos)
%
%	Colourise the head specified as Module:Head. Normally used for
%	adding clauses to multifile predicates in other modules.

colourise_extern_head(Head, M, TB, Pos) :-
	functor_position(Pos, FPos, _),
	colour_item(head(extern(M)), TB, FPos),
	colourise_term_args(Head, TB, Pos).

colour_method_head(SGHead, TB, Pos) :-
	arg(1, SGHead, Head),
	functor(SGHead, SG, _),
	functor_position(Pos, FPos, _),
	colour_item(method(SG), TB, FPos),
	colourise_term_args(Head, TB, Pos).

%	functor_position(+Term, -FunctorPos, -ArgPosList)
%
%	Get the position of a functor   and  its argument. Unfortunately
%	this goes wrong for lists, who have two `functor-positions'.

functor_position(term_position(_,_,FF,FT,ArgPos), FF-FT, ArgPos) :- !.
functor_position(list_position(F,_T,Elms,none), F-FT, Elms) :- !,
	FT is F + 1.
functor_position(Pos, Pos, []).


%%	colourise_directive(+Body, +TB, +Pos)
%
%	Colourise the body of a directive.

colourise_directive((A,B), TB, term_position(_,_,_,_,[PA,PB])) :- !,
	colourise_directive(A, TB, PA),
	colourise_directive(B, TB, PB).
colourise_directive(Body, TB, Pos) :-
	nonvar(Body),
	directive_colours(Body, ClassSpec-ArgSpecs), !, % specified
	functor_position(Pos, FPos, ArgPos),
	(   ClassSpec == classify
	->  goal_classification(TB, Body, [], Class)
	;   Class = ClassSpec
	),
	colour_item(goal(Class, Body), TB, FPos),
	specified_items(ArgSpecs, Body, TB, ArgPos).
colourise_directive(Body, TB, Pos) :-
	colourise_body(Body, TB, Pos).


%	colourise_body(+Body, +TB, +Pos)
%
%	Breaks down to colourise_goal/3.

colourise_body(Body, TB, Pos) :-
	colourise_body(Body, [], TB, Pos).

colourise_body(Body, Origin, TB, Pos) :-
	colour_item(body, TB, Pos),
	colourise_goals(Body, Origin, TB, Pos).

%%	colourise_method_body(+MethodBody, +TB, +Pos)
%
%	Colourise the optional "comment":: as pce(comment) and proceed
%	with the body.
%
%	@tbd	Get this handled by a hook.

colourise_method_body(::(_Comment,Body), TB,
		      term_position(_F,_T,_FF,_FT,[CP,BP])) :- !,
	colour_item(comment, TB, CP),
	colourise_body(Body, TB, BP).
colourise_method_body(Body, TB, Pos) :-		% deal with pri(::) < 1000
	Body =.. [F,A,B],
	control_op(F), !,
	Pos = term_position(_F,_T,_FF,_FT,
			    [ AP,
			      BP
			    ]),
	colourise_method_body(A, TB, AP),
	colourise_body(B, TB, BP).
colourise_method_body(Body, TB, Pos) :-
	colourise_body(Body, TB, Pos).

control_op(',').
control_op((;)).
control_op((->)).
control_op((*->)).

colourise_goals(Body, Origin, TB, term_position(_,_,_,_,ArgPos)) :-
	body_compiled(Body), !,
	colourise_subgoals(ArgPos, 1, Body, Origin, TB).
colourise_goals(Goal, Origin, TB, Pos) :-
	colourise_goal(Goal, Origin, TB, Pos).

colourise_subgoals([], _, _, _, _).
colourise_subgoals([Pos|T], N, Body, Origin, TB) :-
	arg(N, Body, Arg),
	colourise_goals(Arg, Origin, TB, Pos),
	NN is N + 1,
	colourise_subgoals(T, NN, Body, Origin, TB).

%	colourise_dcg(+Body, +Head, +TB, +Pos)
%
%	Breaks down to colourise_dcg_goal/3.

colourise_dcg(Body, Head, TB, Pos) :-
	colour_item(dcg, TB, Pos),
	dcg_extend(Head, Origin),
	colourise_dcg_goals(Body, Origin, TB, Pos).

colourise_dcg_goals(Var, _, TB, Pos) :-
	var(Var), !,
	colour_item(goal(meta,Var), TB, Pos).
colourise_dcg_goals({Body}, Origin, TB,	brace_term_position(F,T,Arg)) :- !,
	colour_item(dcg(plain), TB, F-T),
	colourise_goals(Body, Origin, TB, Arg).
colourise_dcg_goals([], _, TB, Pos) :- !,
	colour_item(dcg(list), TB, Pos).
colourise_dcg_goals(List, _, TB, Pos) :-
	List = [_|_], !,
	colour_item(dcg(list), TB, Pos),
	colourise_term_args(List, TB, Pos).
colourise_dcg_goals(Body, Origin, TB, term_position(_,_,_,_,ArgPos)) :-
	body_compiled(Body), !,
	colourise_dcg_subgoals(ArgPos, 1, Body, Origin, TB).
colourise_dcg_goals(Goal, Origin, TB, Pos) :-
	colourise_dcg_goal(Goal, Origin, TB, Pos),
	colourise_term_args(Goal, TB, Pos).

colourise_dcg_subgoals([], _, _, _, _).
colourise_dcg_subgoals([Pos|T], N, Body, Origin, TB) :-
	arg(N, Body, Arg),
	colourise_dcg_goals(Arg, Origin, TB, Pos),
	NN is N + 1,
	colourise_dcg_subgoals(T, NN, Body, Origin, TB).

dcg_extend(Term, _) :-
	var(Term), !, fail.
dcg_extend(M:Term, M:Goal) :-
	dcg_extend(Term, Goal).
dcg_extend(Term, Goal) :-
	callable(Term),
	Term =.. List,
	append(List, [_,_], List2),
	Goal =.. List2.

%	colourise_dcg_goal(+Goal, +Origin, +TB, +Pos).

colourise_dcg_goal(!, Origin, TB, TermPos) :- !,
	colourise_goal(!, Origin, TB, TermPos).
colourise_dcg_goal(Goal, Origin, TB, TermPos) :-
	dcg_extend(Goal, TheGoal), !,
	colourise_goal(TheGoal, Origin, TB, TermPos).
colourise_dcg_goal(Goal, _, TB, Pos) :-
	colourise_term_args(Goal, TB, Pos).


%	colourise_goal(+Goal, +Origin, +TB, +Pos)
%
%	Colourise access to a single goal.

					% Deal with list as goal (consult)
colourise_goal(Goal, _, TB, list_position(F,T,Elms,_)) :- !,
	FT is F + 1,
	AT is T - 1,
	colour_item(goal(built_in, Goal), TB, F-FT),
	colour_item(goal(built_in, Goal), TB, AT-T),
	colourise_file_list(Goal, TB, Elms).
colourise_goal(Goal, Origin, TB, Pos) :-
	nonvar(Goal),
	goal_colours(Goal, ClassSpec-ArgSpecs), !, % specified
	functor_position(Pos, FPos, ArgPos),
	(   ClassSpec == classify
	->  goal_classification(TB, Goal, Origin, Class)
	;   Class = ClassSpec
	),
	colour_item(goal(Class, Goal), TB, FPos),
	specified_items(ArgSpecs, Goal, TB, ArgPos).
colourise_goal(Module:Goal, _Origin, TB, term_position(_,_,_,_,[PM,PG])) :- !,
	colour_item(module(Module), TB, PM),
	(   PG = term_position(_,_,FF,FT,_)
	->  FP = FF-FT
	;   FP = PG
	),
	colour_item(goal(extern(Module), Goal), TB, FP),
	colourise_goal_args(Goal, TB, PG).
colourise_goal(Goal, Origin, TB, Pos) :-
	goal_classification(TB, Goal, Origin, Class),
	(   Pos = term_position(_,_,FF,FT,_ArgPos)
	->  FPos = FF-FT
	;   FPos = Pos
	),
	colour_item(goal(Class, Goal), TB, FPos),
	colourise_goal_args(Goal, TB, Pos).

%%	colourise_goal_args(+Goal, +TB, +Pos)
%
%	Colourise the arguments to a goal. This predicate deals with
%	meta- and database-access predicates.

colourise_goal_args(Goal, TB, term_position(_,_,_,_,ArgPos)) :-
	colourise_options(Goal, TB, ArgPos),
	meta_args(Goal, MetaArgs), !,
	colourise_meta_args(1, Goal, MetaArgs, TB, ArgPos).
colourise_goal_args(Goal, TB, Pos) :-
	Pos = term_position(_,_,_,_,ArgPos), !,
	colourise_options(Goal, TB, ArgPos),
	colourise_term_args(Goal, TB, Pos).
colourise_goal_args(_, _, _).		% no arguments

colourise_meta_args(_, _, _, _, []) :- !.
colourise_meta_args(N, Goal, MetaArgs, TB, [P0|PT]) :-
	arg(N, Goal, Arg),
	arg(N, MetaArgs, MetaSpec),
	colourise_meta_arg(MetaSpec, Arg, TB, P0),
	NN is N + 1,
	colourise_meta_args(NN, Goal, MetaArgs, TB, PT).

colourise_meta_arg(MetaSpec, Arg, TB, Pos) :-
	expand_meta(MetaSpec, Arg, Expanded), !,
	colourise_goal(Expanded, [], TB, Pos). % TBD: recursion
colourise_meta_arg(_, Arg, TB, Pos) :-
	colourise_term_arg(Arg, TB, Pos).

%	meta_args(+Goal, -ArgSpec)
%
%	Return a copy of Goal, where each meta-argument is an integer
%	representing the number of extra arguments. The non-meta
%	arguments are unbound variables.
%
%	E.g. meta_args(maplist(foo,x,y), X) --> X = maplist(2,_,_)
%
%	NOTE: this could be cached if performance becomes an issue.

meta_args(Goal, VarGoal) :-
	xref_meta(Goal, _),
	functor(Goal, Name, Arity),
	functor(VarGoal, Name, Arity),
	xref_meta(VarGoal, MetaArgs),
	instantiate_meta(MetaArgs).

instantiate_meta([]).
instantiate_meta([H|T]) :-
	(   var(H)
	->  H = 0
	;   H = V+N
	->  V = N
	),
	instantiate_meta(T).

%	expand_meta(+MetaSpec, +Goal, -Expanded)
%
%	Add extra arguments to the goal if the meta-specifier is an
%	integer (see above).

expand_meta(MetaSpec, Goal, Goal) :-
	MetaSpec == 0.
expand_meta(MetaSpec, M:Goal, M:Expanded) :-
	atom(M), !,
	expand_meta(MetaSpec, Goal, Expanded).
expand_meta(MetaSpec, Goal, Expanded) :-
	integer(MetaSpec),
	callable(Goal), !,
	length(Extra, MetaSpec),
	Goal =.. List0,
	append(List0, Extra, List),
	Expanded =.. List.

%%	colourise_setof(+Term, +TB, +Pos)
%
%	Colourise the 2nd argument of setof/bagof

colourise_setof(Var^G, TB, term_position(_,_,FF,FT,[VP,GP])) :- !,
	colourise_term_arg(Var, TB, VP),
	colour_item(built_in, TB, FF-FT),
	colourise_setof(G, TB, GP).
colourise_setof(Term, TB, Pos) :-
	colourise_goal(Term, [], TB, Pos).

%	colourise_db(+Arg, +TB, +Pos)
%
%	Colourise database modification calls (assert/1, retract/1 and
%	friends.

colourise_db((Head:-_Body), TB, term_position(_,_,_,_,[HP,_])) :- !,
	colourise_db(Head, TB, HP).
colourise_db(Module:Head, TB, term_position(_,_,_,_,[MP,HP])) :- !,
	colour_item(module(Module), TB, MP),
	(   atom(Module),
	    colour_state_source_id(TB, SourceId),
	    xref_module(SourceId, Module)
	->  colourise_db(Head, TB, HP)
	;   true			% TBD: Modifying in other module
	).
colourise_db(Head, TB, Pos) :-
	colourise_goal(Head, '<db-change>', TB, Pos).


%%	colourise_options(+Goal, +TB, +ArgPos)
%
%	Colourise predicate options

colourise_options(Goal, TB, ArgPos) :-
	(   compound(Goal),
	    functor(Goal, Name, Arity),
	    (	colour_state_source_id(TB, SourceId),
		xref_module(SourceId, Module)
	    ->	true
	    ;	Module = user
	    ),
	    current_predicate_options(Module:Name/Arity, Arg, OptionDecl),
	    debug(emacs, 'Colouring option-arg ~w of ~p',
		  [Arg, Module:Name/Arity]),
	    arg(Arg, Goal, Options0),
	    nth1(Arg, ArgPos, Pos0),
	    strip_option_module_qualifier(Goal, Module, Arg, TB,
					  Options0, Pos0, Options, Pos),
	    (	Pos = list_position(_, _, ElmPos, TailPos)
	    ->	colourise_option_list(Options, OptionDecl, TB, ElmPos, TailPos)
	    ;	(   var(Options)
		;   Options == []
		)
	    ->	colourise_term_arg(Options, TB, Pos)
	    ;	colour_item(type_error(list), TB, Pos)
	    ),
	    fail
	;   true
	).

strip_option_module_qualifier(Goal, Module, Arg, TB,
			      M:Options, term_position(_,_,_,_,[MP,Pos]),
			      Options, Pos) :-
	predicate_property(Module:Goal, meta_predicate(Head)),
	arg(Arg, Head, :), !,
	colour_item(module(M), TB, MP).
strip_option_module_qualifier(_, _, _, _,
			      Options, Pos, Options, Pos).


colourise_option_list(_, _, _, [], none).
colourise_option_list(Tail, _, TB, [], TailPos) :-
	colourise_term_arg(Tail, TB, TailPos).
colourise_option_list([H|T], OptionDecl, TB, [HPos|TPos], TailPos) :-
	colourise_option(H, OptionDecl, TB, HPos),
	colourise_option_list(T, OptionDecl, TB, TPos, TailPos).

colourise_option(Opt, _, TB, Pos) :-
	var(Opt), !,
	colourise_term_arg(Opt, TB, Pos).
colourise_option(Opt, OptionDecl, TB, term_position(_,_,FF,FT,ValPosList)) :- !,
	functor(Opt, Name, Arity),
	functor(GenOpt, Name, Arity),
	(   memberchk(GenOpt, OptionDecl)
	->  colour_item(option_name, TB, FF-FT),
	    Opt =.. [Name|Values],
	    GenOpt =.. [Name|Types],
	    colour_option_values(Values, Types, TB, ValPosList)
	;   colour_item(no_option_name, TB, FF-FT)
	).
colourise_option(_, _, TB, Pos) :-
	colour_item(type_error(option), TB, Pos).

colour_option_values([], [], _, _).
colour_option_values([V0|TV], [T0|TT], TB, [P0|TP]) :-
	(   (   var(V0)
	    ;	is_of_type(T0, V0)
	    )
	->  colourise_term_arg(V0, TB, P0)
	;   callable(V0),
	    (	T0 = callable
	    ->	N = 0
	    ;	T0 = (callable+N)
	    )
	->  colourise_meta_arg(N, V0, TB, P0)
	;   colour_item(type_error(T0), TB, P0)
	),
	colour_option_values(TV, TT, TB, TP).


%%	colourise_files(+Arg, +TB, +Pos)
%
%	Colourise the argument list of one of the file-loading predicates.

colourise_files(List, TB, list_position(_,_,Elms,_)) :- !,
	colourise_file_list(List, TB, Elms).
colourise_files(M:Spec, TB, term_position(_,_,_,_,[MP,SP])) :- !,
	colour_item(module(M), TB, MP),
	colourise_files(Spec, TB, SP).
colourise_files(Var, TB, P) :-
	var(Var), !,
	colour_item(var, TB, P).
colourise_files(Spec0, TB, Pos) :-
	strip_module(Spec0, _, Spec),
	(   colour_state_source_id(TB, Source),
	    prolog_canonical_source(Source, SourceId),
	    catch(xref_source_file(Spec, Path, SourceId), _, fail)
	->  colour_item(file(Path), TB, Pos)
	;   colour_item(nofile, TB, Pos)
	).

colourise_file_list([], _, _).
colourise_file_list([H|T], TB, [PH|PT]) :-
	colourise_files(H, TB, PH),
	colourise_file_list(T, TB, PT).


%%	colourise_directory(+Arg, +TB, +Pos)
%
%	Colourise argument that should be an existing directory.

colourise_directory(Spec, TB, Pos) :-
	(   colour_state_source_id(TB, SourceId),
	    catch(xref_source_file(Spec, Path, SourceId,
				   [file_type(directory)]),
		  _, fail)
	->  colour_item(directory(Path), TB, Pos)
	;   colour_item(nofile, TB, Pos)
	).


%%	colourise_class(ClassName, TB, Pos)
%
%	Colourise an XPCE class.

colourise_class(ClassName, TB, Pos) :-
	colour_state_source_id(TB, SourceId),
	classify_class(SourceId, ClassName, Classification),
	colour_item(class(Classification, ClassName), TB, Pos).

%%	classify_class(+SourceId, +ClassName, -Classification).

classify_class(SourceId, Name, Class) :-
	xref_defined_class(SourceId, Name, Class), !.
:- if(current_predicate(classify_class/2)).
classify_class(_, Name, Class) :-
	classify_class(Name, Class).
:- endif.

%%	colourise_term_args(+Term, +TB, +Pos)
%
%	colourise head/body principal terms.

colourise_term_args(Term, TB,
		    term_position(_,_,_,_,ArgPos)) :- !,
	colourise_term_args(ArgPos, 1, Term, TB).
colourise_term_args(_, _, _).

colourise_term_args([], _, _, _).
colourise_term_args([Pos|T], N, Term, TB) :-
	arg(N, Term, Arg),
	colourise_term_arg(Arg, TB, Pos),
	NN is N + 1,
	colourise_term_args(T, NN, Term, TB).

colourise_term_arg(Var, TB, Pos) :-			% variable
	var(Var), !,
	(   singleton(Var, TB)
	->  colour_item(singleton, TB, Pos)
	;   colour_item(var, TB, Pos)
	).
colourise_term_arg(List, TB, list_position(_, _, Elms, Tail)) :- !,
	colourise_list_args(Elms, Tail, List, TB, classify).	% list
colourise_term_arg(Compound, TB, Pos) :-		% compound
	compound(Compound), !,
	colourise_term_args(Compound, TB, Pos).
colourise_term_arg(_, TB, string_position(F, T)) :- !,	% string
	colour_item(string, TB, F-T).
colourise_term_arg(Atom, TB, Pos) :-			% single quoted atom
	atom(Atom), !,
	colour_item(atom, TB, Pos).
colourise_term_arg(_Arg, _TB, _Pos) :-
	true.

colourise_list_args([HP|TP], Tail, [H|T], TB, How) :-
	specified_item(How, H, TB, HP),
	colourise_list_args(TP, Tail, T, TB, How).
colourise_list_args([], none, _, _, _) :- !.
colourise_list_args([], TP, T, TB, How) :-
	specified_item(How, T, TB, TP).


%	colourise_exports(+List, +TB, +Pos)
%
%	Colourise the module export-list (or any other list holding
%	terms of the form Name/Arity referring to predicates).

colourise_exports([], _, _) :- !.
colourise_exports(List, TB, list_position(_,_,ElmPos,Tail)) :- !,
	(   Tail == none
	->  true
	;   colour_item(type_error(list), TB, Tail)
	),
	colourise_exports2(List, TB, ElmPos).
colourise_exports(_, TB, Pos) :-
	colour_item(type_error(list), TB, Pos).

colourise_exports2([G0|GT], TB, [P0|PT]) :- !,
	colourise_declaration(G0, TB, P0),
	colourise_exports2(GT, TB, PT).
colourise_exports2(_, _, _).


%	colourise_imports(+List, +File, +TB, +Pos)
%
%	Colourise import list from use_module/2, importing from File.

colourise_imports(List, File, TB, Pos) :-
	(   colour_state_source_id(TB, SourceId),
	    catch(xref_public_list(File, Path, Public, SourceId), _, fail)
	->  true
	;   Public = []
	),
	colourise_imports(List, Path, Public, TB, Pos).

colourise_imports([], _, _, _, _).
colourise_imports(List, File, Public, TB, list_position(_,_,ElmPos,Tail)) :- !,
	(   Tail == none
	->  true
	;   colour_item(type_error(list), TB, Tail)
	),
	colourise_imports2(List, File, Public, TB, ElmPos).
colourise_imports(except(Except), File, Public, TB,
		  term_position(_,_,FF,FT,[LP])) :- !,
	colour_item(keyword(except), TB, FF-FT),
	colourise_imports(Except, File, Public, TB, LP).
colourise_imports(_, _, _, TB, Pos) :-
	colour_item(type_error(list), TB, Pos).

colourise_imports2([G0|GT], File, Public, TB, [P0|PT]) :- !,
	colourise_import(G0, File, TB, P0),
	colourise_imports2(GT, File, Public, TB, PT).
colourise_imports2(_, _, _, _, _).


colourise_import(PI as Name, File, TB, term_position(_,_,FF,FT,[PP,NP])) :-
	pi_to_term(PI, Goal), !,
	colour_item(goal(imported(File), Goal), TB, PP),
	functor(Goal, _, Arity),
	functor(NewGoal, Name, Arity),
	goal_classification(TB, NewGoal, [], Class),
	colour_item(goal(Class, NewGoal), TB, NP),
	colour_item(keyword(as), TB, FF-FT).
colourise_import(PI, _, TB, Pos) :-
	colourise_declaration(PI, TB, Pos).


%%	colourise_declarations(+Term, +TB, +Pos)
%
%	Colourise the Predicate indicator lists of dynamic, multifile, etc
%	declarations.

colourise_declarations((Head,Tail), TB,
		       term_position(_,_,_,_,[PH,PT])) :- !,
	colourise_declaration(Head, TB, PH),
	colourise_declarations(Tail, TB, PT).
colourise_declarations(Last, TB, Pos) :-
	colourise_declaration(Last, TB, Pos).

colourise_declaration(PI, TB, Pos) :-
	pi_to_term(PI, Goal), !,
	goal_classification(TB, Goal, [], Class),
	colour_item(goal(Class, Goal), TB, Pos).
colourise_declaration(Module:PI, TB,
		      term_position(_,_,_,_,[PM,PG])) :-
	atom(Module), pi_to_term(PI, Goal), !,
	colour_item(module(M), TB, PM),
	colour_item(goal(extern(M), Goal), TB, PG).
colourise_declaration(op(_,_,_), TB, Pos) :-
	colour_item(exported_operator, TB, Pos).
colourise_declaration(_, TB, Pos) :-
	colour_item(type_error(export_declaration), TB, Pos).

pi_to_term(Name/Arity, Term) :-
	atom(Name), integer(Arity), !,
	functor(Term, Name, Arity).
pi_to_term(Name//Arity0, Term) :-
	atom(Name), integer(Arity0), !,
	Arity is Arity0 + 2,
	functor(Term, Name, Arity).

%%	colourise_prolog_flag_name(+Name, +TB, +Pos)
%
%	Colourise the name of a Prolog flag

colourise_prolog_flag_name(Name, TB, Pos) :-
	atom(Name), !,
	(   current_prolog_flag(Name, _)
	->  colour_item(flag_name(Name), TB, Pos)
	;   colour_item(no_flag_name(Name), TB, Pos)
	).
colourise_prolog_flag_name(Name, TB, Pos) :-
	colourise_term(Name, TB, Pos).


		 /*******************************
		 *	  CONFIGURATION		*
		 *******************************/

%	body_compiled(+Term)
%
%	Succeeds if term is a construct handled by the compiler.

body_compiled((_,_)).
body_compiled((_->_)).
body_compiled((_*->_)).
body_compiled((_;_)).
body_compiled(\+_).

%	goal_classification(+TB, +Goal, +Origin, -Class)
%
%	Classify Goal appearing in TB and called from a clause with head
%	Origin.  For directives Origin is [].

goal_classification(_, Goal, _, meta) :-
	var(Goal), !.
goal_classification(_, Goal, Origin, recursion) :-
	callable(Goal),
	functor(Goal, Name, Arity),
	functor(Origin, Name, Arity), !.
goal_classification(TB, Goal, _, How) :-
	colour_state_source_id(TB, SourceId),
	xref_defined(SourceId, Goal, How),
	How \= public(_), !.
goal_classification(_TB, Goal, _, Class) :-
	goal_classification(Goal, Class), !.
goal_classification(_TB, _Goal, _, undefined).

%	goal_classification(+Goal, -Class)
%
%	Multifile hookable classification for non-local goals.

goal_classification(Goal, built_in) :-
	built_in_predicate(Goal), !.
goal_classification(Goal, autoload) :-	% SWI-Prolog
	functor(Goal, Name, Arity),
	'$in_library'(Name, Arity, _Path), !.
goal_classification(Goal, global) :-	% SWI-Prolog
	current_predicate(_, user:Goal), !.
goal_classification(SS, expanded) :-	% XPCE (TBD)
	functor(SS, send_super, A),
	A >= 2, !.
goal_classification(SS, expanded) :-	% XPCE (TBD)
	functor(SS, get_super, A),
	A >= 3, !.

classify_head(TB, Goal, exported) :-
	colour_state_source_id(TB, SourceId),
	xref_exported(SourceId, Goal), !.
classify_head(_TB, Goal, hook) :-
	xref_hook(Goal), !.
classify_head(TB, Goal, hook) :-
	colour_state_source_id(TB, SourceId),
	xref_module(SourceId, M),
	xref_hook(M:Goal), !.
classify_head(TB, Goal, unreferenced) :-
	colour_state_source_id(TB, SourceId),
	\+ (xref_called(SourceId, Goal, By), By \= Goal), !.
classify_head(TB, Goal, How) :-
	colour_state_source_id(TB, SourceId),
	xref_defined(SourceId, Goal, How), !.
classify_head(_TB, Goal, built_in) :-
	built_in_predicate(Goal), !.
classify_head(_TB, _Goal, undefined).

built_in_predicate(Goal) :-
	predicate_property(system:Goal, built_in), !.
built_in_predicate(module(_, _)).
built_in_predicate(if(_)).
built_in_predicate(elif(_)).
built_in_predicate(else).
built_in_predicate(endif).

%	Specify colours for individual goals.

goal_colours(module(_,_),	     built_in-[identifier,exports]).
goal_colours(use_module(_),	     built_in-[file]).
goal_colours(use_module(File,_),     built_in-[file,imports(File)]).
goal_colours(reexport(_),	     built_in-[file]).
goal_colours(reexport(File,_),       built_in-[file,imports(File)]).
goal_colours(dynamic(_),	     built_in-[predicates]).
goal_colours(thread_local(_),	     built_in-[predicates]).
goal_colours(module_transparent(_),  built_in-[predicates]).
goal_colours(multifile(_),	     built_in-[predicates]).
goal_colours(volatile(_),	     built_in-[predicates]).
goal_colours(public(_),		     built_in-[predicates]).
goal_colours(consult(_),	     built_in-[file]).
goal_colours(include(_),	     built_in-[file]).
goal_colours(ensure_loaded(_),	     built_in-[file]).
goal_colours(load_files(_,_),	     built_in-[file,classify]).
goal_colours(setof(_,_,_),	     built_in-[classify,setof,classify]).
goal_colours(bagof(_,_,_),	     built_in-[classify,setof,classify]).
goal_colours(predicate_options(_,_,_), built_in-[predicate,classify,classify]).
% Database access
goal_colours(assert(_),		     built_in-[db]).
goal_colours(asserta(_),	     built_in-[db]).
goal_colours(assertz(_),	     built_in-[db]).
goal_colours(assert(_,_),	     built_in-[db,classify]).
goal_colours(asserta(_,_),	     built_in-[db,classify]).
goal_colours(assertz(_,_),	     built_in-[db,classify]).
goal_colours(retract(_),	     built_in-[db]).
goal_colours(retractall(_),	     built_in-[db]).
goal_colours(clause(_,_),	     built_in-[db,classify]).
goal_colours(clause(_,_,_),	     built_in-[db,classify,classify]).
% misc
goal_colours(set_prolog_flag(_,_),   built_in-[prolog_flag_name,classify]).
goal_colours(current_prolog_flag(_,_), built_in-[prolog_flag_name,classify]).
% XPCE stuff
goal_colours(pce_autoload(_,_),	     classify-[classify,file]).
goal_colours(pce_image_directory(_), classify-[directory]).
goal_colours(new(_, _),		     built_in-[classify,pce_new]).
goal_colours(send_list(_,_,_),	     built_in-pce_arg_list).
goal_colours(send(_,_),		     built_in-[pce_arg,pce_selector]).
goal_colours(get(_,_,_),	     built_in-[pce_arg,pce_selector,pce_arg]).
goal_colours(send_super(_,_),	     built_in-[pce_arg,pce_selector]).
goal_colours(get_super(_,_),	     built_in-[pce_arg,pce_selector,pce_arg]).
goal_colours(get_chain(_,_,_),	     built_in-[pce_arg,pce_selector,pce_arg]).
goal_colours(Pce,		     built_in-pce_arg) :-
	compound(Pce),
	functor(Pce, Functor, _),
	pce_functor(Functor).

pce_functor(send).
pce_functor(get).
pce_functor(send_super).
pce_functor(get_super).


		 /*******************************
		 *	  SPECIFIC HEADS	*
		 *******************************/

head_colours(file_search_path(_,_), hook-[identifier,classify]).
head_colours(library_directory(_),  hook-[file]).
head_colours(resource(_,_,_),	    hook-[identifier,classify,file]).

head_colours(Var, _) :-
	var(Var), !,
	fail.
head_colours(M:H, Colours) :-
	atom(M), callable(H),
	xref_hook(M:H), !,
	Colours = hook - [ hook, hook-classify ].
head_colours(M:H, Colours) :-
	M == user,
	head_colours(H, HC),
	HC = hook - _, !,
	Colours = hook - [ hook, HC ].
head_colours(M:_, meta-[module(M),extern(M)]).


		 /*******************************
		 *	       STYLES		*
		 *******************************/

%%	def_style(+Pattern, -Style)
%
%	Define the style used for the   given  pattern. Definitions here
%	can     be     overruled     by       defining     rules     for
%	emacs_prolog_colours:style/2

def_style(goal(built_in,_),	   [colour(blue)]).
def_style(goal(imported(_),_),	   [colour(blue)]).
def_style(goal(autoload,_),	   [colour(navy_blue)]).
def_style(goal(global,_),	   [colour(navy_blue)]).
def_style(goal(undefined,_),	   [colour(red)]).
def_style(goal(thread_local(_),_), [colour(magenta), underline(true)]).
def_style(goal(dynamic(_),_),	   [colour(magenta)]).
def_style(goal(multifile(_),_),	   [colour(navy_blue)]).
def_style(goal(expanded,_),	   [colour(blue), underline(true)]).
def_style(goal(extern(_),_),	   [colour(blue), underline(true)]).
def_style(goal(recursion,_),	   [underline(true)]).
def_style(goal(meta,_),		   [colour(red4)]).
def_style(goal(foreign(_),_),	   [colour(darkturquoise)]).
def_style(goal(local(_),_),	   []).
def_style(goal(constraint(_),_),   [colour(darkcyan)]).

def_style(option_name,		   [colour('#3434ba')]).
def_style(no_option_name,	   [colour(red)]).

def_style(head(exported),	   [colour(blue), bold(true)]).
def_style(head(public(_)),	   [colour('#016300'), bold(true)]).
def_style(head(extern(_)),	   [colour(blue), bold(true)]).
def_style(head(dynamic),	   [colour(magenta), bold(true)]).
def_style(head(multifile),	   [colour(navy_blue), bold(true)]).
def_style(head(unreferenced),	   [colour(red), bold(true)]).
def_style(head(hook),		   [colour(blue), underline(true)]).
def_style(head(meta),		   []).
def_style(head(constraint(_)),	   [colour(darkcyan), bold(true)]).
def_style(head(_),		   [bold(true)]).
def_style(module(_),		   [colour(dark_slate_blue)]).
def_style(comment,		   [colour(dark_green)]).

def_style(directive,		   [background(grey90)]).
def_style(method(_),		   [bold(true)]).

def_style(var,			   [colour(red4)]).
def_style(singleton,		   [bold(true), colour(red4)]).
def_style(unbound,		   [colour(red), bold(true)]).
def_style(quoted_atom,		   [colour(navy_blue)]).
def_style(string,		   [colour(navy_blue)]).
def_style(nofile,		   [colour(red)]).
def_style(file(_),		   [colour(blue), underline(true)]).
def_style(directory(_),		   [colour(blue)]).
def_style(class(built_in,_),	   [colour(blue), underline(true)]).
def_style(class(library(_),_),	   [colour(navy_blue), underline(true)]).
def_style(class(local(_,_,_),_),   [underline(true)]).
def_style(class(user(_),_),	   [underline(true)]).
def_style(class(user,_),	   [underline(true)]).
def_style(class(undefined,_),	   [colour(red), underline(true)]).
def_style(prolog_data,		   [colour(blue), underline(true)]).
def_style(flag_name(_),		   [colour(blue)]).
def_style(no_flag_name(_),	   [colour(red)]).

def_style(keyword(_),		   [colour(blue)]).
def_style(identifier,		   [bold(true)]).
def_style(delimiter,		   [bold(true)]).
def_style(expanded,		   [colour(blue), underline(true)]).

def_style(hook,			   [colour(blue), underline(true)]).

def_style(error,		   [background(orange)]).
def_style(type_error(_),	   [background(orange)]).
def_style(syntax_error(_,_),	   [background(orange)]).

%%	syntax_colour(?Class, ?Attributes) is nondet.
%
%	True when a range  classified  Class   must  be  coloured  using
%	Attributes.  Attributes is a list of:
%
%	  * colour(ColourName)
%	  * background(ColourName)
%	  * bold(Boolean)
%	  * underline(Boolean)
%
%	Attributes may be the empty list. This   is used for cases where
%	-for example- a  menu  is  associated   with  the  fragment.  If
%	syntax_colour/2 fails, no fragment is created for the region.

syntax_colour(Class, Attributes) :-
	(   style(Class, Attributes)		% user hook
	;   def_style(Class, Attributes)	% system default
	).


%%	term_colours(+Term, -FunctorColour, -ArgColours)
%
%	Define colourisation for specific terms.

term_colours((?- Directive), Colours) :-
	term_colours((:- Directive), Colours).
term_colours((prolog:Head --> _),
	     expanded - [ expanded - [ expanded,
				       expanded - [ identifier
						  ]
				     ],
			  classify
			]) :-
	prolog_message_hook(Head).

prolog_message_hook(message(_)).
prolog_message_hook(error_message(_)).
prolog_message_hook(message_context(_)).
prolog_message_hook(message_location(_)).

%	XPCE rules

term_colours(variable(_, _, _, _),
	     expanded - [ identifier,
			  classify,
			  classify,
			  comment
			]).
term_colours(variable(_, _, _),
	     expanded - [ identifier,
			  classify,
			  atom
			]).
term_colours(handle(_, _, _),
	     expanded - [ classify,
			  classify,
			  classify
			]).
term_colours(handle(_, _, _, _),
	     expanded - [ classify,
			  classify,
			  classify,
			  classify
			]).
term_colours(class_variable(_,_,_,_),
	     expanded - [ identifier,
			  pce(type),
			  pce(default),
			  comment
			]).
term_colours(class_variable(_,_,_),
	     expanded - [ identifier,
			  pce(type),
			  pce(default)
			]).
term_colours(delegate_to(_),
	     expanded - [ classify
			]).
term_colours((:- encoding(_)),
	     expanded - [ expanded - [ classify
				     ]
			]).
term_colours((:- pce_begin_class(_, _, _)),
	     expanded - [ expanded - [ identifier,
				       pce_new,
				       comment
				     ]
			]).
term_colours((:- pce_begin_class(_, _)),
	     expanded - [ expanded - [ identifier,
				       pce_new
				     ]
			]).
term_colours((:- pce_extend_class(_)),
	     expanded - [ expanded - [ identifier
				     ]
			]).
term_colours((:- pce_end_class),
	     expanded - [ expanded
			]).
term_colours((:- pce_end_class(_)),
	     expanded - [ expanded - [ identifier
				     ]
			]).
term_colours((:- use_class_template(_)),
	     expanded - [ expanded - [ pce_new
				     ]
			]).
term_colours((:- emacs_begin_mode(_,_,_,_,_)),
	     expanded - [ expanded - [ identifier,
				       classify,
				       classify,
				       classify,
				       classify
				     ]
			]).
term_colours((:- emacs_extend_mode(_,_)),
	     expanded - [ expanded - [ identifier,
				       classify
				     ]
			]).
term_colours((:- pce_group(_)),
	     expanded - [ expanded - [ identifier
				     ]
			]).
term_colours((:- pce_global(_, new(_))),
	     expanded - [ expanded - [ identifier,
				       pce_arg
				     ]
			]).
term_colours((:- emacs_end_mode),
	     expanded - [ expanded
			]).
term_colours(pce_ifhostproperty(_,_),
	     expanded - [ classify,
			  classify
			]).
term_colours((_,_),
	     error - [ classify,
		       classify
		     ]).

specified_item(_, Var, TB, Pos) :-
	var(Var), !,
	colourise_term_arg(Var, TB, Pos).
					% generic classification
specified_item(classify, Term, TB, Pos) :- !,
	colourise_term_arg(Term, TB, Pos).
					% classify as head
specified_item(head, Term, TB, Pos) :- !,
	colourise_clause_head(Term, TB, Pos).
					% expanded head (DCG=2, ...)
specified_item(head(+N), Term, TB, Pos) :- !,
	colourise_extended_head(Term, N, TB, Pos).
					% M:Head
specified_item(extern(M), Term, TB, Pos) :- !,
	colourise_extern_head(Term, M, TB, Pos).
					% classify as body
specified_item(body, Term, TB, Pos) :- !,
	colourise_body(Term, TB, Pos).
specified_item(setof, Term, TB, Pos) :- !,
	colourise_setof(Term, TB, Pos).
specified_item(meta(MetaSpec), Term, TB, Pos) :- !,
	colourise_meta_arg(MetaSpec, Term, TB, Pos).
					% DCG goal in body
specified_item(dcg, Term, TB, Pos) :- !,
	colourise_dcg(Term, [], TB, Pos).
					% assert/retract arguments
specified_item(db, Term, TB, Pos) :- !,
	colourise_db(Term, TB, Pos).
					% files
specified_item(file, Term, TB, Pos) :- !,
	colourise_files(Term, TB, Pos).
					% directory
specified_item(directory, Term, TB, Pos) :- !,
	colourise_directory(Term, TB, Pos).
					% [Name/Arity, ...]
specified_item(exports, Term, TB, Pos) :- !,
	colourise_exports(Term, TB, Pos).
					% [Name/Arity, ...]
specified_item(imports(File), Term, TB, Pos) :- !,
	colourise_imports(Term, File, TB, Pos).
					% Name/Arity, ...
specified_item(predicates, Term, TB, Pos) :- !,
	colourise_declarations(Term, TB, Pos).
					% Name/Arity
specified_item(predicate, Term, TB, Pos) :- !,
	colourise_declaration(Term, TB, Pos).
					% set_prolog_flag(Name, _)
specified_item(prolog_flag_name, Term, TB, Pos) :- !,
	colourise_prolog_flag_name(Term, TB, Pos).
					% XPCE new argument
specified_item(pce_new, Term, TB, Pos) :- !,
	(   atom(Term)
	->  colourise_class(Term, TB, Pos)
	;   compound(Term)
	->  functor(Term, Class, _),
	    Pos = term_position(_,_,FF, FT, ArgPos),
	    colourise_class(Class, TB, FF-FT),
	    specified_items(pce_arg, Term, TB, ArgPos)
	;   colourise_term_arg(Term, TB, Pos)
	).
					% Generic XPCE arguments
specified_item(pce_arg, new(X), TB,
	       term_position(_,_,_,_,[ArgPos])) :- !,
	specified_item(pce_new, X, TB, ArgPos).
specified_item(pce_arg, new(X, T), TB,
	       term_position(_,_,_,_,[P1, P2])) :- !,
	colourise_term_arg(X, TB, P1),
	specified_item(pce_new, T, TB, P2).
specified_item(pce_arg, @(Ref), TB, Pos) :- !,
	colourise_term_arg(@(Ref), TB, Pos).
specified_item(pce_arg, prolog(Term), TB,
	       term_position(_,_,FF,FT,[ArgPos])) :- !,
	colour_item(prolog_data, TB, FF-FT),
	colourise_term_arg(Term, TB, ArgPos).
specified_item(pce_arg, Term, TB, Pos) :-
	compound(Term),
	Term \= [_|_], !,
	specified_item(pce_new, Term, TB, Pos).
specified_item(pce_arg, Term, TB, Pos) :- !,
	colourise_term_arg(Term, TB, Pos).
					% List of XPCE arguments
specified_item(pce_arg_list, List, TB, list_position(_,_,Elms,Tail)) :- !,
	colourise_list_args(Elms, Tail, List, TB, pce_arg).
specified_item(pce_arg_list, Term, TB, Pos) :- !,
	specified_item(pce_arg, Term, TB, Pos).
					% XPCE selector
specified_item(pce_selector, Term, TB,
	       term_position(_,_,_,_,ArgPos)) :- !,
	specified_items(pce_arg, Term, TB, ArgPos).
specified_item(pce_selector, Term, TB, Pos) :-
	colourise_term_arg(Term, TB, Pos).
					% Nested specification
specified_item(FuncSpec-ArgSpecs, Term, TB,
	       term_position(_,_,FF,FT,ArgPos)) :- !,
	specified_item(FuncSpec, Term, TB, FF-FT),
	specified_items(ArgSpecs, Term, TB, ArgPos).
					% Nested for {...}
specified_item(FuncSpec-[ArgSpec], {Term}, TB,
	       brace_term_position(F,T,ArgPos)) :- !,
	specified_item(FuncSpec, {Term}, TB, F-T),
	specified_item(ArgSpec, Term, TB, ArgPos).
					% Specified
specified_item(FuncSpec-ElmSpec, List, TB, list_position(F,T,ElmPos,TailPos)) :- !,
	FT is F + 1,
	AT is T - 1,
	colour_item(FuncSpec, TB, F-FT),
	colour_item(FuncSpec, TB, AT-T),
	specified_list(ElmSpec, List, TB, ElmPos, TailPos).
specified_item(Class, _, TB, Pos) :-
	colour_item(Class, TB, Pos).

%	specified_items(+Spec, +T, +TB, +PosList)

specified_items(Specs, Term, TB, PosList) :-
	is_list(Specs), !,
	specified_arglist(Specs, 1, Term, TB, PosList).
specified_items(Spec, Term, TB, PosList) :-
	specified_argspec(PosList, Spec, 1, Term, TB).


specified_arglist([], _, _, _, _).
specified_arglist(_, _, _, _, []) :- !.		% Excess specification args
specified_arglist([S0|ST], N, T, TB, [P0|PT]) :-
	arg(N, T, Term),
	specified_item(S0, Term, TB, P0),
	NN is N + 1,
	specified_arglist(ST, NN, T, TB, PT).

specified_argspec([], _, _, _, _).
specified_argspec([P0|PT], Spec, N, T, TB) :-
	arg(N, T, Term),
	specified_item(Spec, Term, TB, P0),
	NN is N + 1,
	specified_argspec(PT, Spec, NN, T, TB).


%	specified_list(+Spec, +List, +TB, +PosList, TailPos)

specified_list([], [], _, [], _).
specified_list([HS|TS], [H|T], TB, [HP|TP], TailPos) :- !,
	specified_item(HS, H, TB, HP),
	specified_list(TS, T, TB, TP, TailPos).
specified_list(Spec, [H|T], TB, [HP|TP], TailPos) :-
	specified_item(Spec, H, TB, HP),
	specified_list(Spec, T, TB, TP, TailPos).
specified_list(_, _, _, [], none) :- !.
specified_list(Spec, Tail, TB, [], TailPos) :-
	specified_item(Spec, Tail, TB, TailPos).


		 /*******************************
		 *	   DESCRIPTIONS		*
		 *******************************/

syntax_message(Class) -->
	message(Class), !.
syntax_message(goal(Class, Goal)) --> !,
	goal_message(Class, Goal).
syntax_message(class(Type, Class)) --> !,
	xpce_class_message(Type, Class).

goal_message(meta, _) -->
	[ 'Meta call' ].
goal_message(recursion, _) -->
	[ 'Recursive call' ].
goal_message(undefined, _) -->
	[ 'Call to undefined predicate' ].
goal_message(expanded, _) -->
	[ 'Expanded goal' ].
goal_message(global, _) -->
	[ 'Auto-imported from module user' ].
goal_message(Class, Goal) -->
	{ predicate_name(Goal, PI) },
	[ 'Call to ~w predicate ~q'-[Class,PI] ].

xpce_class_message(Type, Class) -->
	[ 'XPCE ~w class ~q'-[Type, Class] ].