From 8af7ad47bf2fa30aa08c1c63fb93a76a7a623557 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 13 Feb 2012 09:42:57 +0000 Subject: [PATCH] add more SWI files. --- LGPL/pairs.pl | 165 ++++ LGPL/predicate_options.pl | 912 ++++++++++++++++++++++ LGPL/predopts.pl | 141 ++++ LGPL/prolog_clause.pl | 675 +++++++++++++++++ LGPL/prolog_colour.pl | 1508 +++++++++++++++++++++++++++++++++++++ 5 files changed, 3401 insertions(+) create mode 100644 LGPL/pairs.pl create mode 100644 LGPL/predicate_options.pl create mode 100644 LGPL/predopts.pl create mode 100644 LGPL/prolog_clause.pl create mode 100644 LGPL/prolog_colour.pl diff --git a/LGPL/pairs.pl b/LGPL/pairs.pl new file mode 100644 index 000000000..ab5b66cbf --- /dev/null +++ b/LGPL/pairs.pl @@ -0,0 +1,165 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2006, University of 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 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(pairs, + [ pairs_keys_values/3, + pairs_values/2, + pairs_keys/2, + group_pairs_by_key/2, + transpose_pairs/2, + map_list_to_pairs/3 + ]). + +/** Operations on key-value lists + +This module implements common operations on Key-Value lists, also known +as _Pairs_. Pairs have great practical value, especially due to +keysort/2 and the library assoc.pl. + +This library is based on disussion in the SWI-Prolog mailinglist, +including specifications from Quintus and a library proposal by Richard +O'Keefe. + +@see keysort/2, library(assoc) +@author Jan Wielemaker +*/ + +%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det. +% +% True if Keys holds the keys of Pairs and Values the values. +% +% Deterministic if any argument is instantiated to a finite list +% and the others are either free or finite lists. All three lists +% are in the same order. +% +% @see pairs_values/2 and pairs_keys/2. + +pairs_keys_values(Pairs, Keys, Values) :- + ( nonvar(Pairs) -> + pairs_keys_values_(Pairs, Keys, Values) + ; nonvar(Keys) -> + keys_values_pairs(Keys, Values, Pairs) + ; values_keys_pairs(Values, Keys, Pairs) + ). + +pairs_keys_values_([], [], []). +pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :- + pairs_keys_values_(Pairs, Keys, Values). + +keys_values_pairs([], [], []). +keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :- + keys_values_pairs(Ks, Vs, Pairs). + +values_keys_pairs([], [], []). +values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :- + values_keys_pairs(Vs, Ks, Pairs). + +%% pairs_values(+Pairs, -Values) is det. +% +% Remove the keys from a list of Key-Value pairs. Same as +% pairs_keys_values(Pairs, _, Values) + +pairs_values([], []). +pairs_values([_-V|T0], [V|T]) :- + pairs_values(T0, T). + + +%% pairs_keys(+Pairs, -Keys) is det. +% +% Remove the values from a list of Key-Value pairs. Same as +% pairs_keys_values(Pairs, Keys, _) + +pairs_keys([], []). +pairs_keys([K-_|T0], [K|T]) :- + pairs_keys(T0, T). + + +%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det. +% +% Group values with the same key. Pairs must be a key-sorted list. +% For example: +% +% == +% ?- group_pairs_by_key([a-2, a-1, b-4], X). +% +% X = [a-[2,1], b-[4]] +% == +% +% @param Pairs Key-Value list, sorted to the standard order +% of terms (as keysort/2 does) +% @param Joined List of Key-Group, where Group is the +% list of Values associated with Key. + +group_pairs_by_key([], []). +group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :- + same_key(M, T0, TN, T1), + group_pairs_by_key(T1, T). + +same_key(M, [M-N|T0], [N|TN], T) :- !, + same_key(M, T0, TN, T). +same_key(_, L, [], L). + + +%% transpose_pairs(+Pairs, -Transposed) is det. +% +% Swap Key-Value to Value-Key and sort the result on Value +% (the new key) using keysort/2. + +transpose_pairs(Pairs, Transposed) :- + flip_pairs(Pairs, Flipped), + keysort(Flipped, Transposed). + +flip_pairs([], []). +flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :- + flip_pairs(Pairs, Flipped). + + +%% map_list_to_pairs(:Function, +List, -Keyed) +% +% Create a key-value list by mapping each element of List. +% For example, if we have a list of lists we can create a +% list of Length-List using +% +% == +% map_list_to_pairs(length, ListOfLists, Pairs), +% == + +:- meta_predicate + map_list_to_pairs(2, +, -). + +map_list_to_pairs(Function, List, Pairs) :- + map_list_to_pairs2(List, Function, Pairs). + +map_list_to_pairs2([], _, []). +map_list_to_pairs2([H|T0], Pred, [K-H|T]) :- + call(Pred, H, K), + map_list_to_pairs2(T0, Pred, T). + diff --git a/LGPL/predicate_options.pl b/LGPL/predicate_options.pl new file mode 100644 index 000000000..297a20625 --- /dev/null +++ b/LGPL/predicate_options.pl @@ -0,0 +1,912 @@ +/* Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: J.Wielemaker@cs.vu.nl + WWW: http://www.swi-prolog.org + Copyright (C): 2011, 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 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(predicate_options, + [ predicate_options/3, % +PI, +Arg, +Options + assert_predicate_options/4, % +PI, +Arg, +Options, ?New + + current_option_arg/2, % ?PI, ?Arg + current_predicate_option/3, % ?PI, ?Arg, ?Option + check_predicate_option/3, % +PI, +Arg, +Option + % Create declarations + current_predicate_options/3, % ?PI, ?Arg, ?Options + retractall_predicate_options/0, + derived_predicate_options/3, % :PI, ?Arg, ?Options + derived_predicate_options/1, % +Module + % Checking + check_predicate_options/0, + derive_predicate_options/0, + check_predicate_options/1 % :PredicateIndicator + ]). +:- use_module(library(lists)). +:- use_module(library(pairs)). +:- use_module(library(error)). +:- use_module(library(lists)). +:- use_module(library(debug)). +:- use_module(library(prolog_clause)). + +:- meta_predicate + predicate_options(:, +, +), + assert_predicate_options(:, +, +, ?), + current_predicate_option(:, ?, ?), + check_predicate_option(:, ?, ?), + current_predicate_options(:, ?, ?), + current_option_arg(:, ?), + pred_option(:,-), + derived_predicate_options(:,?,?), + check_predicate_options(:). + +/** Access and analyse predicate options + +This module provides the developers interface for the directive +predicate_options/3. This directive allows us to specify that e.g., +open/4 processes options using the 4th argument and supports the option +=type= using the values =text= and =binary=. Declaring options that are +processed allows for more reliable handling of predicate options and +simplifies porting applications. This libarry provides the following +functionality: + + * Query supported options through current_predicate_option/3 + or current_predicate_options/3. This is intended to support + conditional compilation and an IDE. + * Derive additional declarations through dataflow analysis using + derive_predicate_options/0. + * Perform a compile-time analysis of the entire loaded program using + check_predicate_options/0. + +Below, we describe some use-cases. + + $ Quick check of a program : + This scenario is useful as an occasional check or to assess problems + with option-handling for porting an application to SWI-Prolog. It + consists of three steps: loading the program (1 and 2), deriving + option handling for application predicates (3) and running the + checker (4). + + == + 1 ?- [load]. + 2 ?- autoload. + 3 ?- derive_predicate_options. + 4 ?- check_predicate_options. + == + + $ Add declaations to your program : + Adding declarations about option processes improves the quality of + the checking. The analysis of derive_predicate_options/0 may miss + options and does not derive the types for options that are processed + in Prolog code. The process is similar to the above. In steps 4 and + further, the inferred declarations are listed, inspected and added to + the source-code of the module. + + == + 1 ?- [load]. + 2 ?- autoload. + 3 ?- derive_predicate_options. + 4 ?- derived_predicate_options(module_1). + 5 ?- derived_predicate_options(module_2). + 6 ?- ... + == + + $ Declare option processing requirements : + If an application requires that open/4 needs to support lock(write), + it may do so using the derective below. This directive raises an + exception when loaded on a Prolog implementation that does not support + this option. + + == + :- current_predicate_option(open/4, 4, lock(write)). + == + +@see library(option) for accessing options in Prolog code. +*/ + +:- multifile option_decl/3, pred_option/3. +:- dynamic dyn_option_decl/3. + +%% predicate_options(:PI, +Arg, +Options) is det. +% +% Declare that the predicate PI processes options on Arg. Options +% is a list of options processed. Each element is one of: +% +% * Option(ModeAndType) +% PI processes Option. The option-value must comply to +% ModeAndType. Mode is one of + or - and Type is a type as +% accepted by must_be/2. +% +% * pass_to(:PI,Arg) +% The option-list is passed to the indicated predicate. +% +% Below is an example that processes the option header(boolean) +% and passes all options to open/4: +% +% == +% :- predicate_options(write_xml_file/3, 3, +% [ header(boolean), +% pass_to(open/4, 4) +% ]). +% +% write_xml_file(File, XMLTerm, Options) :- +% open(File, write, Out, Options), +% ( option(header(true), Option, true) +% -> write_xml_header(Out) +% ; true +% ), +% ... +% == +% +% This predicate may only be used as a _directive_ and is +% processed by expand_term/2. Option processing can be be +% specified at runtime using assert_predicate_options/3, which is +% intended to support program analysis. + +predicate_options(PI, Arg, Options) :- + throw(error(context_error(nodirective, + predicate_options(PI, Arg, Options)), _)). + + +%% assert_predicate_options(:PI, +Arg, +Options, ?New) is semidet. +% +% As predicate_options(:PI, +Arg, +Options). New is a boolean +% indicating whether the declarations have changed. If new is +% provided and =false=, the predicate becomes semidet and fails +% without modifications if modifications are required. + +assert_predicate_options(PI, Arg, Options, New) :- + canonical_pi(PI, M:Name/Arity), + functor(Head, Name, Arity), + ( dyn_option_decl(Head, M, Arg) + -> true + ; New = true, + assertz(dyn_option_decl(Head, M, Arg)) + ), + phrase('$predopts':option_clauses(Options, Head, M, Arg), + OptionClauses), + forall(member(Clause, OptionClauses), + assert_option_clause(Clause, New)), + ( var(New) + -> New = false + ; true + ). + +assert_option_clause(Clause, New) :- + rename_clause(Clause, NewClause, + '$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)), + clause_head(NewClause, NewHead), + ( clause(NewHead, _) + -> true + ; New = true, + assertz(NewClause) + ). + +clause_head(M:(Head:-_Body), M:Head) :- !. +clause_head((M:Head :-_Body), M:Head) :- !. +clause_head(Head, Head). + +rename_clause(M:Clause, M:NewClause, Head, NewHead) :- !, + rename_clause(Clause, NewClause, Head, NewHead). +rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !. +rename_clause(Head, NewHead, Head, NewHead) :- !. +rename_clause(Head, Head, _, _). + + + + /******************************* + * QUERY OPTIONS * + *******************************/ + +%% current_option_arg(:PI, ?Arg) is nondet. +% +% True when Arg of PI processes predicate options. Which options +% are processed can be accessed using current_predicate_option/3. + +current_option_arg(Module:Name/Arity, Arg) :- + current_option_arg(Module:Name/Arity, Arg, _DefM). + +current_option_arg(Module:Name/Arity, Arg, DefM) :- + atom(Name), integer(Arity), !, + resolve_module(Module:Name/Arity, DefM:Name/Arity), + functor(Head, Name, Arity), + ( option_decl(Head, DefM, Arg) + ; dyn_option_decl(Head, DefM, Arg) + ). +current_option_arg(M:Name/Arity, Arg, M) :- + ( option_decl(Head, M, Arg) + ; dyn_option_decl(Head, M, Arg) + ), + functor(Head, Name, Arity). + +%% current_predicate_option(:PI, ?Arg, ?Option) is nondet. +% +% True when Arg of PI processes Option. For example, the following +% is true: +% +% == +% ?- current_predicate_option(open/4, 4, type(text)). +% true. +% == +% +% This predicate is intended to support conditional compilation +% using if/1 ... endif/0. The predicate +% current_predicate_options/3 can be used to access the full +% capabilities of a predicate. + +current_predicate_option(Module:PI, Arg, Option) :- + current_option_arg(Module:PI, Arg, DefM), + PI = Name/Arity, + functor(Head, Name, Arity), + catch(pred_option(DefM:Head, Option), + error(type_error(_,_),_), + fail). + +%% check_predicate_option(:PI, +Arg, +Option) is det. +% +% Similar to current_predicate_option/3, but intended to support +% runtime checking. +% +% @error existence_error(option, OptionName) if the option is not +% supported by PI. +% @error type_error(Type, Value) if the option is supported but +% the value does not match the option type. See must_be/2. + +check_predicate_option(Module:PI, Arg, Option) :- + define_predicate(Module:PI), + current_option_arg(Module:PI, Arg, DefM), + PI = Name/Arity, + functor(Head, Name, Arity), + ( pred_option(DefM:Head, Option) + -> true + ; existence_error(option, Option) + ). + + +pred_option(M:Head, Option) :- + pred_option(M:Head, Option, []). + +pred_option(M:Head, Option, Seen) :- + ( has_static_option_decl(M), + M:'$pred_option'(Head, _, Option, Seen) + ; has_dynamic_option_decl(M), + M:'$dyn_pred_option'(Head, _, Option, Seen) + ). + +has_static_option_decl(M) :- + '$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)). +has_dynamic_option_decl(M) :- + '$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)). + + + /******************************* + * TYPE&MODE CONSTRAINTS * + *******************************/ + +:- public + system:predicate_option_mode/2, + system:predicate_option_type/2. + +add_attr(Var, Value) :- + ( get_attr(Var, predicate_options, Old) + -> put_attr(Var, predicate_options, [Value|Old]) + ; put_attr(Var, predicate_options, [Value]) + ). + +system:predicate_option_type(Type, Arg) :- + var(Arg), !, + add_attr(Arg, option_type(Type)). +system:predicate_option_type(Type, Arg) :- + must_be(Type, Arg). + +system:predicate_option_mode(Mode, Arg) :- + var(Arg), !, + add_attr(Arg, option_mode(Mode)). +system:predicate_option_mode(Mode, Arg) :- + check_mode(Mode, Arg). + +check_mode(input, Arg) :- + ( nonvar(Arg) + -> true + ; instantiation_error(Arg) + ). +check_mode(output, Arg) :- + ( var(Arg) + -> true + ; instantiation_error(Arg) % TBD: Uninstantiated + ). + +attr_unify_hook([], _). +attr_unify_hook([H|T], Var) :- + option_hook(H, Var), + attr_unify_hook(T, Var). + +option_hook(option_type(Type), Value) :- + is_of_type(Type, Value). +option_hook(option_mode(Mode), Value) :- + check_mode(Mode, Value). + + +attribute_goals(Var) --> + { get_attr(Var, predicate_options, Attrs) }, + option_goals(Attrs, Var). + +option_goals([], _) --> []. +option_goals([H|T], Var) --> + option_goal(H, Var), + option_goals(T, Var). + +option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)]. +option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)]. + + + /******************************* + * OUTPUT DECLARATIONS * + *******************************/ + +%% current_predicate_options(:PI, ?Arg, ?Options) is nondet. +% +% True when Options is the current active option declaration for +% PI on Arg. See predicate_options/3 for the argument +% descriptions. If PI is ground and refers to an undefined +% predicate, the autoloader is used to obtain a definition of the +% predicate. + +current_predicate_options(PI, Arg, Options) :- + define_predicate(PI), + setof(Arg-Option, + current_predicate_option_decl(PI, Arg, Option), + Options0), + group_pairs_by_key(Options0, Grouped), + member(Arg-Options, Grouped). + +current_predicate_option_decl(PI, Arg, Option) :- + current_predicate_option(PI, Arg, Option0), + Option0 =.. [Name|Values], + maplist(mode_and_type, Values, Types), + Option =.. [Name|Types]. + +mode_and_type(Value, ModeAndType) :- + copy_term(Value,_,Goals), + ( memberchk(predicate_option_mode(output, _), Goals) + -> ModeAndType = -(Type) + ; ModeAndType = Type + ), + ( memberchk(predicate_option_type(Type, _), Goals) + -> true + ; Type = any + ). + +define_predicate(PI) :- + ground(PI), !, + PI = M:Name/Arity, + functor(Head, Name, Arity), + once(predicate_property(M:Head, _)). +define_predicate(_). + +%% derived_predicate_options(:PI, ?Arg, ?Options) is nondet. +% +% True when Options is the current _derived_ active option +% declaration for PI on Arg. + +derived_predicate_options(PI, Arg, Options) :- + define_predicate(PI), + setof(Arg-Option, + derived_predicate_option(PI, Arg, Option), + Options0), + group_pairs_by_key(Options0, Grouped), + member(Arg-Options1, Grouped), + PI = M:_, + phrase(expand_pass_to_options(Options1, M), Options2), + sort(Options2, Options). + +derived_predicate_option(PI, Arg, Decl) :- + current_option_arg(PI, Arg, DefM), + PI = _:Name/Arity, + functor(Head, Name, Arity), + has_dynamic_option_decl(DefM), + ( has_static_option_decl(DefM), + DefM:'$pred_option'(Head, Decl, _, []) + ; DefM:'$dyn_pred_option'(Head, Decl, _, []) + ). + +%% expand_pass_to_options(+OptionsIn, +Module, -OptionsOut)// is det. +% +% Expand the options of pass_to(PI,Arg) if PI does not refer to a +% public predicate. + +expand_pass_to_options([], _) --> []. +expand_pass_to_options([H|T], M) --> + expand_pass_to(H, M), + expand_pass_to_options(T, M). + +expand_pass_to(pass_to(PI, Arg), Module) --> + { strip_module(Module:PI, M, Name/Arity), + functor(Head, Name, Arity), + \+ ( predicate_property(M:Head, exported) + ; predicate_property(M:Head, public) + ; M == system + ), !, + current_predicate_options(M:Name/Arity, Arg, Options) + }, + list(Options). +expand_pass_to(Option, _) --> + [Option]. + +list([]) --> []. +list([H|T]) --> [H], list(T). + +%% derived_predicate_options(+Module) is det. +% +% Derive predicate option declarations for the given module and +% print them to the current output. + +derived_predicate_options(Module) :- + var(Module), !, + forall(current_module(Module), + derived_predicate_options(Module)). +derived_predicate_options(Module) :- + findall(predicate_options(Module:PI, Arg, Options), + ( derived_predicate_options(Module:PI, Arg, Options), + PI = Name/Arity, + functor(Head, Name, Arity), + ( predicate_property(Module:Head, exported) + -> true + ; predicate_property(Module:Head, public) + ) + ), + Decls0), + maplist(qualify_decl(Module), Decls0, Decls1), + sort(Decls1, Decls), + ( Decls \== [] + -> format('~N~n~n% Predicate option declarations for module ~q~n~n', + [Module]), + forall(member(Decl, Decls), + portray_clause((:-Decl))) + ; true + ). + +qualify_decl(M, + predicate_options(PI0, Arg, Options0), + predicate_options(PI1, Arg, Options1)) :- + qualify(PI0, M, PI1), + maplist(qualify_option(M), Options0, Options1). + +qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :- !, + qualify(PI0, M, PI1). +qualify_option(_, Opt, Opt). + +qualify(M:Term, M, Term) :- !. +qualify(QTerm, _, QTerm). + + + /******************************* + * CLEANUP * + *******************************/ + +%% retractall_predicate_options is det. +% +% Remove all dynamically (derived) predicate options. + +retractall_predicate_options :- + forall(retract(dyn_option_decl(_,M,_)), + abolish(M:'$dyn_pred_option'/4)). + + + /******************************* + * COMPILE-TIME CHECKER * + *******************************/ + + +:- thread_local + new_decl/1. + +%% check_predicate_options is det. +% +% Analyse loaded program for errornous options. This predicate +% decompiles the current program and searches for calls to +% predicates that process options. For each option list, it +% validates whether the provided options are supported and +% validates the argument type. This predicate performs partial +% dataflow analysis to track option-lists inside a clause. +% +% @see derive_predicate_options/0 can be used to derive +% declarations for predicates that pass options. This +% predicate should normally be called before +% check_predicate_options/0. + +check_predicate_options :- + forall(current_module(Module), + check_predicate_options_module(Module)). + +%% derive_predicate_options is det. +% +% Derive new predicate option declarations. This predicate +% analyses the loaded program to find clauses that process options +% using one of the predicates from library(option) or passes +% options to other predicates that are known to process options. +% The process is repeated until no new declarations are retrieved. +% +% @see autoload/0 may be used to complete the loaded program. + +derive_predicate_options :- + derive_predicate_options(NewDecls), + ( NewDecls == [] + -> true + ; print_message(informational, check_options(new(NewDecls))), + new_decls(NewDecls), + derive_predicate_options + ). + +new_decls([]). +new_decls([predicate_options(PI, A, O)|T]) :- + assert_predicate_options(PI, A, O, _), + new_decls(T). + + +derive_predicate_options(NewDecls) :- + call_cleanup( + ( forall( + current_module(Module), + forall( + ( predicate_in_module(Module, PI), + PI = Name/Arity, + functor(Head, Name, Arity), + catch(Module:clause(Head, Body, Ref), _, fail) + ), + check_clause((Head:-Body), Module, Ref, decl))), + ( setof(Decl, retract(new_decl(Decl)), NewDecls) + -> true + ; NewDecls = [] + ) + ), + retractall(new_decl(_))). + + +check_predicate_options_module(Module) :- + forall(predicate_in_module(Module, PI), + check_predicate_options(Module:PI)). + +predicate_in_module(Module, PI) :- + current_predicate(Module:PI), + PI = Name/Arity, + functor(Head, Name, Arity), + \+ predicate_property(Module:Head, imported_from(_)). + +%% check_predicate_options(:PredicateIndicator) is det. +% +% Verify calls to predicates that have options in all clauses of +% the predicate indicated by PredicateIndicator. + +check_predicate_options(Module:Name/Arity) :- + debug(predicate_options, 'Checking ~q', [Module:Name/Arity]), + functor(Head, Name, Arity), + forall(catch(Module:clause(Head, Body, Ref), _, fail), + check_clause((Head:-Body), Module, Ref, check)). + +%% check_clause(+Clause, +Module, +Ref, +Action) is det. +% +% Action is one of +% +% * decl +% Create additional declarations +% * check +% Produce error messages + +check_clause((Head:-Body), M, ClauseRef, Action) :- !, + catch(check_body(Body, M, _, Action), E, true), + ( var(E) + -> option_decl(M:Head, Action) + ; ( clause_info(ClauseRef, File, TermPos, _NameOffset), + TermPos = term_position(_,_,_,_,[_,BodyPos]), + catch(check_body(Body, M, BodyPos, Action), + error(Formal, ArgPos), true), + compound(ArgPos), + arg(1, ArgPos, CharCount), + integer(CharCount) + -> Location = file_char_count(File, CharCount) + ; Location = clause(ClauseRef), + E = error(Formal, _) + ), + print_message(error, predicate_option_error(Formal, Location)) + ). + + +%% check_body(+Body, +Module, +TermPos, +Action) + +check_body(Var, _, _, _) :- + var(Var), !. +check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :- !, + check_body(G, M, Pos, Action). +check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :- !, + check_body(A, M, PA, Action), + check_body(B, M, PB, Action). +check_body(A=B, _, _, _) :- % partial evaluation + unify_with_occurs_check(A,B), !. +check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :- + callable(Goal), + functor(Goal, Name, Arity), + ( '$get_predicate_attribute'(M:Goal, imported, DefM) + -> true + ; DefM = M + ), + ( eval_option_pred(DefM:Goal) + -> true + ; current_option_arg(DefM:Name/Arity, OptArg), !, + arg(OptArg, Goal, Options), + nth1(OptArg, ArgPosList, ArgPos), + check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action) + ). +check_body(Goal, M, _, Action) :- + prolog:called_by(Goal, Called), !, + check_called_by(Called, M, Action). +check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :- + '$get_predicate_attribute'(M:Meta, meta_predicate, Head), !, + check_meta_args(1, Head, Meta, M, ArgPosList, Action). +check_body(_, _, _, _). + +check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :- + arg(I, Head, AS), !, + ( AS == 0 + -> arg(I, Meta, MA), + check_body(MA, M, ArgPos, Action) + ; true + ), + succ(I, I2), + check_meta_args(I2, Head, Meta, M, ArgPosList, Action). +check_meta_args(_,_,_,_, _, _). + +%% check_called_by(+CalledBy, +M, +Action) is det. +% +% Handle results from prolog:called_by/2. + +check_called_by([], _, _). +check_called_by([H|T], M, Action) :- + ( H = G+N + -> ( extend(G, N, G2) + -> check_body(G2, M, _, Action) + ; true + ) + ; check_body(H, M, _, Action) + ), + check_called_by(T, M, Action). + +extend(Goal, N, GoalEx) :- + callable(Goal), + Goal =.. List, + length(Extra, N), + append(List, Extra, ListEx), + GoalEx =.. ListEx. + + +%% check_options(:Predicate, +OptionArg, +Options, +ArgPos, +Action) +% +% Verify the list Options, that is passed into Predicate on +% argument OptionArg. ArgPos is a term-position term describing +% the location of the Options list. If Options is a partial list, +% the tail is annotated with pass_to(PI, OptArg). + +check_options(PI, OptArg, QOptions, ArgPos, Action) :- + debug(predicate_options, '\tChecking call to ~q', [PI]), + remove_qualifier(QOptions, Options), + must_be(list_or_partial_list, Options), + check_option_list(Options, PI, OptArg, Options, ArgPos, Action). + +remove_qualifier(X, X) :- + var(X), !. +remove_qualifier(_:X, X) :- !. +remove_qualifier(X, X). + +check_option_list(Var, PI, OptArg, _, _, _) :- + var(Var), !, + annotate(Var, pass_to(PI, OptArg)). +check_option_list([], _, _, _, _, _). +check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :- + check_option(PI, OptArg, H, ArgPos, Action), + check_option_list(T, PI, OptArg, Options, ArgPos, Action). + +check_option(_, _, _, _, decl) :- !. +check_option(PI, OptArg, Opt, ArgPos, _) :- + catch(check_predicate_option(PI, OptArg, Opt), E, true), !, + ( var(E) + -> true + ; E = error(Formal,_), + throw(error(Formal,ArgPos)) + ). + + + /******************************* + * ANNOTATIONS * + *******************************/ + +%% annotate(+Var, +Term) is det. +% +% Use constraints to accumulate annotations about variables. If +% two annotated variables are unified, the attributes are joined. + +annotate(Var, Term) :- + ( get_attr(Var, predopts_analysis, Old) + -> put_attr(Var, predopts_analysis, [Term|Old]) + ; var(Var) + -> put_attr(Var, predopts_analysis, [Term]) + ; true + ). + +annotations(Var, Annotations) :- + get_attr(Var, predopts_analysis, Annotations). + +predopts_analysis:attr_unify_hook(Opts, Value) :- + get_attr(Value, predopts_analysis, Others), !, + append(Opts, Others, All), + put_attr(Value, predopts_analysis, All). +predopts_analysis:attr_unify_hook(_, _). + + + /******************************* + * PARTIAL EVAL * + *******************************/ + +eval_option_pred(swi_option:option(Opt, Options)) :- + processes(Opt, Spec), + annotate(Options, Spec). +eval_option_pred(swi_option:option(Opt, Options, _Default)) :- + processes(Opt, Spec), + annotate(Options, Spec). +eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :- + ignore(unify_with_occurs_check(Rest, Options)), + processes(Opt, Spec), + annotate(Options, Spec). +eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :- + ignore(unify_with_occurs_check(Rest, Options)), + processes(Opt, Spec), + annotate(Options, Spec). +eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :- + remove_qualifier(QOptionsIn, OptionsIn), + remove_qualifier(QOptionsOut, OptionsOut), + ignore(unify_with_occurs_check(OptionsIn, OptionsOut)). + +processes(Opt, Spec) :- + compound(Opt), + functor(Opt, OptName, 1), + Spec =.. [OptName,any]. + + + /******************************* + * NEW DECLARTIONS * + *******************************/ + +%% option_decl(:Head, +Action) is det. +% +% Add new declarations based on attributes left by the analysis +% pass. We do not add declarations for system modules or modules +% that already contain static declarations. +% +% @tbd Should we add a mode to include generating declarations +% for system modules and modules with static declarations? + +option_decl(_, check) :- !. +option_decl(M:_, _) :- + system_module(M), !. +option_decl(M:_, _) :- + has_static_option_decl(M), !. +option_decl(M:Head, _) :- + arg(AP, Head, QA), + remove_qualifier(QA, A), + annotations(A, Annotations0), + functor(Head, Name, Arity), + PI = M:Name/Arity, + delete(Annotations0, pass_to(PI,AP), Annotations), + Annotations \== [], + Decl = predicate_options(PI, AP, Annotations), + ( new_decl(Decl) + -> true + ; assert_predicate_options(M:Name/Arity, AP, Annotations, false) + -> true + ; assertz(new_decl(Decl)), + debug(predicate_options(decl), '~q', [Decl]) + ), + fail. +option_decl(_, _). + +system_module(system) :- !. +system_module(Module) :- + sub_atom(Module, 0, _, _, $). + + + /******************************* + * MISC * + *******************************/ + +canonical_pi(M:Name//Arity, M:Name/PArity) :- + integer(Arity), + PArity is Arity+2. +canonical_pi(PI, PI). + +%% resolve_module(:PI, -DefPI) is det. +% +% Find the real predicate indicator pointing to the definition +% module of PI. This is similar to using predicate_property/3 with +% the property imported_from, but using +% '$get_predicate_attribute'/3 avoids auto-importing the +% predicate. + +resolve_module(Module:Name/Arity, DefM:Name/Arity) :- + functor(Head, Name, Arity), + ( '$get_predicate_attribute'(Module:Head, imported, M) + -> DefM = M + ; DefM = Module + ). + + + /******************************* + * MESSAGES * + *******************************/ +:- multifile + prolog:message//1. + +prolog:message(predicate_option_error(Formal, Location)) --> + error_location(Location), + '$messages':term_message(Formal). % TBD: clean interface +prolog:message(check_options(new(Decls))) --> + [ 'Inferred declarations:'-[], nl ], + new_decls(Decls). + +error_location(file_char_count(File, CharPos)) --> + { filepos_line(File, CharPos, Line, LinePos) }, + [ '~w:~d:~d: '-[File, Line, LinePos] ]. +error_location(clause(ClauseRef)) --> + { clause_property(ClauseRef, file(File)), + clause_property(ClauseRef, line_count(Line)) + }, !, + [ '~w:~d: '-[File, Line] ]. +error_location(clause(ClauseRef)) --> + [ 'Clause ~q: '-[ClauseRef] ]. + +filepos_line(File, CharPos, Line, LinePos) :- + setup_call_cleanup( + ( open(File, read, In), + open_null_stream(Out) + ), + ( Skip is CharPos-1, + copy_stream_data(In, Out, Skip), + stream_property(In, position(Pos)), + stream_position_data(line_count, Pos, Line), + stream_position_data(line_position, Pos, LinePos) + ), + ( close(Out), + close(In) + )). + +new_decls([]) --> []. +new_decls([H|T]) --> + [ ' :- ~q'-[H], nl ], + new_decls(T). + + + /******************************* + * SYSTEM DECLARATIONS * + *******************************/ + +:- use_module(library(dialect/swi/syspred_options)). diff --git a/LGPL/predopts.pl b/LGPL/predopts.pl new file mode 100644 index 000000000..b9653626b --- /dev/null +++ b/LGPL/predopts.pl @@ -0,0 +1,141 @@ +/* Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: J.Wielemaker@cs.vu.nl + WWW: http://www.swi-prolog.org + Copyright (C): 2011, 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 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('$predopts', + [ + ]). + +:- multifile + predicate_options:option_decl/3, + predicate_options:pred_option/3. +:- multifile % provided by library(predicate_options) + system:predicate_option_type/2, + system:predicate_option_mode/2. + +:- public + option_clauses//4. + +%% expand_predicate_options(:PI, +Arg, +OptionList, -Clauses) is det. +% +% Term-expansion code for predicate_options(PI, Arg, OptionList). + +expand_predicate_options(PI, Arg, Options, + [ predicate_options:option_decl(Head, M, Arg), + (:-multifile(M:'$pred_option'/4)) + | OptionClauses + ]) :- + canonical_pi(PI, CPI), + prolog_load_context(module, M0), + strip_module(M0:CPI, M, Name/Arity), + functor(Head, Name, Arity), + ( is_list(Options) + -> true + ; throw(error(type_error(list, Options), _)) + ), + phrase(option_clauses(Options, Head, M, Arg), OptionClauses0), + qualify_list(OptionClauses0, M0, OptionClauses). + +qualify_list([], _, []). +qualify_list([H0|T0], M, [H|T]) :- + qualify(H0, M, H), + qualify_list(T0, M, T). + +qualify(M:Term, M, Term) :- !. +qualify(QTerm, _, QTerm). + + +option_clauses([], _, _, _) --> []. +option_clauses([H|T], Head, M, A) --> + option_clause(H, Head, M), + option_clauses(T, Head, M, A). + +option_clause(Var, _, _) --> + { var(Var), !, + throw(error(instantiation_error, _)) + }. +option_clause(pass_to(PI0, Arg), Head, M) --> !, + { canonical_pi(PI0, PI), + strip_module(M:PI, TM, Name/Arity), + functor(THead, Name, Arity), + Clause = ('$pred_option'(Head, pass_to(PI0, Arg), Opt, Seen) :- + \+ memberchk(PI-Arg, Seen), + predicate_options:pred_option(TM:THead, Opt, [PI-Arg|Seen])) + }, + [ M:Clause ]. +option_clause(Option, Head, M) --> + { Option =.. [Name|ModeAndTypes], !, + modes_and_types(ModeAndTypes, Args, Body), + Opt =.. [Name|Args], + Clause = ('$pred_option'(Head, Option, Opt, _) :- Body) + }, + [ M:Clause ]. +option_clause(Option, _, _) --> + { throw(error(type_error(option_specifier, Option))) + }. + +modes_and_types([], [], true). +modes_and_types([H|T], [A|AT], Body) :- + mode_and_type(H, A, Body0), + ( T == [] + -> Body = Body0, + AT = [] + ; Body0 == true + -> modes_and_types(T, AT, Body) + ; Body = (Body0,Body1), + modes_and_types(T, AT, Body1) + ). + + +mode_and_type(-Type, A, (predicate_option_mode(output, A), Body)) :- !, + type_goal(Type, A, Body). +mode_and_type(+Type, A, Body) :- !, + type_goal(Type, A, Body). +mode_and_type(Type, A, Body) :- + type_goal(Type, A, Body). + +type_goal(Type, A, predicate_option_type(Type, A)). + + +%% canonical_pi(+PIIn, -PIout) + +canonical_pi(M:Name//Arity, M:Name/PArity) :- + integer(Arity), !, + PArity is Arity+2. +canonical_pi(Name//Arity, Name/PArity) :- + integer(Arity), !, + PArity is Arity+2. +canonical_pi(PI, PI). + + + /******************************* + * EXPAND * + *******************************/ + +%system:term_expansion((:- predicate_options(PI, Arg, Options)), Clauses) :- +% expand_predicate_options(PI, Arg, Options, Clauses). diff --git a/LGPL/prolog_clause.pl b/LGPL/prolog_clause.pl new file mode 100644 index 000000000..06afeff85 --- /dev/null +++ b/LGPL/prolog_clause.pl @@ -0,0 +1,675 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: J.Wielemaker@vu.nl + WWW: http://www.swi-prolog.org + 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_clause, + [ clause_info/4, % +ClauseRef, -File, -TermPos, -VarNames + predicate_name/2, % +Head, -Name + clause_name/2 % +ClauseRef, -Name + ]). +:- use_module(library(lists), [append/3]). +:- use_module(library(occurs), [sub_term/2]). +:- use_module(library(debug)). +:- use_module(library(listing)). +:- use_module(library(prolog_source)). + + +:- public % called from library(trace/clause) + unify_term/2, + make_varnames/5, + do_make_varnames/3. + +:- multifile + make_varnames_hook/5. + +/** Get detailed source-information about a clause + +This module started life as part of the GUI tracer. As it is generally +useful for debugging purposes it has moved to the general Prolog +library. + +The tracer library library(trace/clause) adds caching and dealing with +dynamic predicates using listing to XPCE objects to this. Note that +clause_info/4 as below can be slow. +*/ + +%% clause_info(+ClauseRef, -File, -TermPos, -VarNames) +% +% Fetches source information for the given clause. File is the +% file from which the clause was loaded. TermPos describes the +% source layout in a format compatible to the subterm_positions +% option of read_term/2. VarNames provides access to the variable +% allocation in a stack-frame. See make_varnames/5 for details. + +clause_info(ClauseRef, File, TermPos, NameOffset) :- + ( debugging(clause_info) + -> clause_name(ClauseRef, Name), + debug(clause_info, 'clause_info(~w) (~w)... ', + [ClauseRef, Name]) + ; true + ), + clause_property(ClauseRef, file(File)), + '$clause'(Head, Body, ClauseRef, VarOffset), + ( Body == true + -> DecompiledClause = Head + ; DecompiledClause = (Head :- Body) + ), + File \== user, % loaded using ?- [user]. + clause_property(ClauseRef, line_count(LineNo)), + ( module_property(Module, file(File)) + -> true + ; strip_module(user:Head, Module, _) + ), + debug(clause_info, 'from ~w:~d ... ', [File, LineNo]), + read_term_at_line(File, LineNo, Module, Clause, TermPos0, VarNames), + debug(clause_info, 'read ...', []), + unify_clause(Clause, DecompiledClause, Module, TermPos0, TermPos), + debug(clause_info, 'unified ...', []), + make_varnames(Clause, DecompiledClause, VarOffset, VarNames, NameOffset), + debug(clause_info, 'got names~n', []), !. + +%% unify_term(+T1, +T2) +% +% Unify the two terms, where T2 is created by writing the term and +% reading it back in, but be aware that rounding problems may +% cause floating point numbers not to unify. Also, if the initial +% term has a string object, it is written as "..." and read as a +% code-list. We compensate for that. +% +% NOTE: Called directly from library(trace/clause) for the GUI +% tracer. + +unify_term(X, X) :- !. +unify_term(X1, X2) :- + compound(X1), + compound(X2), + functor(X1, F, Arity), + functor(X2, F, Arity), !, + unify_args(0, Arity, X1, X2). +unify_term(X, Y) :- + float(X), float(Y), !. +unify_term(X, Y) :- + string(X), + is_list(Y), + string_to_list(X, Y), !. +unify_term(_, Y) :- + Y == '...', !. % elipses left by max_depth +unify_term(_:X, Y) :- + unify_term(X, Y), !. +unify_term(X, _:Y) :- + unify_term(X, Y), !. +unify_term(X, Y) :- + format('[INTERNAL ERROR: Diff:~n'), + portray_clause(X), + format('~N*** <->~n'), + portray_clause(Y), + break. + +unify_args(N, N, _, _) :- !. +unify_args(I, Arity, T1, T2) :- + A is I + 1, + arg(A, T1, A1), + arg(A, T2, A2), + unify_term(A1, A2), + unify_args(A, Arity, T1, T2). + + +%% read_term_at_line(+File, +Line, +Module, +%% -Clause, -TermPos, -VarNames) is semidet. +% +% Read a term from File at Line. + +read_term_at_line(File, Line, Module, Clause, TermPos, VarNames) :- + catch(open(File, read, In), _, fail), + call_cleanup( + read_source_term_at_location( + In, Clause, + [ line(Line), + module(Module), + subterm_positions(TermPos), + variable_names(VarNames) + ]), + close(In)). + + +%% make_varnames(+ReadClause, +DecompiledClause, +%% +Offsets, +Names, -Term) is det. +% +% Create a Term varnames(...) where each argument contains the name +% of the variable at that offset. If the read Clause is a DCG rule, +% name the two last arguments and +% +% This predicate calles the multifile predicate +% make_varnames_hook/5 with the same arguments to allow for user +% extensions. Extending this predicate is needed if a compiler +% adds additional arguments to the clause head that must be made +% visible in the GUI tracer. +% +% @param Offsets List of Offset=Var +% @param Names List of Name=Var + +make_varnames(ReadClause, DecompiledClause, Offsets, Names, Term) :- + make_varnames_hook(ReadClause, DecompiledClause, Offsets, Names, Term), !. +make_varnames((Head --> _Body), _, Offsets, Names, Bindings) :- !, + functor(Head, _, Arity), + In is Arity, + memberchk(In=IVar, Offsets), + Names1 = [''=IVar|Names], + Out is Arity + 1, + memberchk(Out=OVar, Offsets), + Names2 = [''=OVar|Names1], + make_varnames(xx, xx, Offsets, Names2, Bindings). +make_varnames(_, _, Offsets, Names, Bindings) :- + length(Offsets, L), + functor(Bindings, varnames, L), + do_make_varnames(Offsets, Names, Bindings). + +do_make_varnames([], _, _). +do_make_varnames([N=Var|TO], Names, Bindings) :- + ( find_varname(Var, Names, Name) + -> true + ; Name = '_' + ), + AN is N + 1, + arg(AN, Bindings, Name), + do_make_varnames(TO, Names, Bindings). + +find_varname(Var, [Name = TheVar|_], Name) :- + Var == TheVar, !. +find_varname(Var, [_|T], Name) :- + find_varname(Var, T, Name). + +%% unify_clause(+Read, +Decompiled, +Module, +ReadTermPos, +%% -RecompiledTermPos). +% +% What you read isn't always what goes into the database. The task +% of this predicate is to establish the relation between the term +% read from the file and the result from decompiling the clause. +% +% This predicate calls the multifile predicate unify_clause_hook/5 +% with the same arguments to support user extensions. +% +% @tbd This really must be more flexible, dealing with much +% more complex source-translations, falling back to a +% heuristic method locating as much as possible. + +:- multifile + unify_clause_hook/5. + +unify_clause(Read, Read, _, TermPos, TermPos) :- !. + % XPCE send-methods +unify_clause(Read, Decompiled, Module, TermPoso, TermPos) :- + unify_clause_hook(Read, Decompiled, Module, TermPoso, TermPos), !. +unify_clause(:->(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !, + pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos). + % XPCE get-methods +unify_clause(:<-(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !, + pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos). + % Unit test clauses +unify_clause((TH :- Body), + (_:'unit body'(_, _) :- !, Body), _, + TP0, TP) :- + ( TH = test(_,_) + ; TH = test(_) + ), !, + TP0 = term_position(F,T,FF,FT,[HP,BP]), + TP = term_position(F,T,FF,FT,[HP,term_position(0,0,0,0,[FF-FT,BP])]). + % module:head :- body +unify_clause((Head :- Read), + (Head :- _M:Compiled), Module, TermPos0, TermPos) :- + unify_clause((Head :- Read), (Head :- Compiled), Module, TermPos0, TermPos1), + TermPos1 = term_position(TA,TZ,FA,FZ,[PH,PB]), + TermPos = term_position(TA,TZ,FA,FZ, + [ PH, + term_position(0,0,0,0,[0-0,PB]) + ]). +unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :- + Read = (_ --> List, _), + is_list(List), + ci_expand(Read, Compiled2, Module), + Compiled2 = (DH :- _), + functor(DH, _, Arity), + DArg is Arity - 1, + arg(DArg, DH, List), + nonvar(List), + TermPos0 = term_position(F,T,FF,FT,[ HP, + term_position(_,_,_,_,[_,BP]) + ]), !, + TermPos1 = term_position(F,T,FF,FT,[ HP, BP ]), + match_module(Compiled2, Compiled1, TermPos1, TermPos). + % general term-expansion +unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :- + ci_expand(Read, Compiled2, Module), + match_module(Compiled2, Compiled1, TermPos0, TermPos). + % I don't know ... +unify_clause(_, _, _, _, _) :- + debug(clause_info, 'Could not unify clause', []), + fail. + +unify_clause_head(H1, H2) :- + strip_module(H1, _, H), + strip_module(H2, _, H). + +ci_expand(Read, Compiled, Module) :- + catch(setup_call_cleanup('$set_source_module'(Old, Module), + expand_term(Read, Compiled), + '$set_source_module'(_, Old)), + E, + expand_failed(E, Read)). + +match_module((H1 :- B1), (H2 :- B2), Pos0, Pos) :- !, + unify_clause_head(H1, H2), + unify_body(B1, B2, Pos0, Pos). +match_module(H1, H2, Pos, Pos) :- % deal with facts + unify_clause_head(H1, H2). + +%% expand_failed(+Exception, +Term) +% +% When debugging, indicate that expansion of the term failed. + +expand_failed(E, Read) :- + debugging(clause_info), + message_to_string(E, Msg), + debug(clause_info, 'Term-expand ~p failed: ~w', [Read, Msg]), + fail. + +%% unify_body(+Read, +Decompiled, +Pos0, -Pos) +% +% Deal with translations implied by the compiler. For example, +% compiling (a,b),c yields the same code as compiling a,b,c. +% +% Pos0 and Pos still include the term-position of the head. + +unify_body(B, B, Pos, Pos) :- + does_not_dcg_after_binding(B, Pos), !. +unify_body(R, D, + term_position(F,T,FF,FT,[HP,BP0]), + term_position(F,T,FF,FT,[HP,BP])) :- + ubody(R, D, BP0, BP). + +%% does_not_dcg_after_binding(+ReadBody, +ReadPos) is semidet. +% +% True if ReadPos/ReadPos does not contain DCG delayed +% unifications. +% +% @tbd We should pass that we are in a DCG; if we are not there +% is no reason for this test. + +does_not_dcg_after_binding(B, Pos) :- + acyclic_term(B), % X = call(X) + \+ sub_term(brace_term_position(_,_,_), Pos), + \+ (sub_term((Cut,_=_), B), Cut == !), !. + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Some remarks. + +a --> { x, y, z }. + This is translated into "(x,y),z), X=Y" by the DCG translator, after + which the compiler creates "a(X,Y) :- x, y, z, X=Y". +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +%% ubody(+Read, +Decompiled, +TermPosRead, -TermPosForDecompiled) +% +% @param Read Clause read _after_ expand_term/2 +% @param Decompiled Decompiled clause +% @param TermPosRead Sub-term positions of source + +ubody(B, B, P, P) :- + does_not_dcg_after_binding(B, P), !. +ubody(X, call(X), % X = call(X) + From-To, + term_position(From, To, From, To, [From-To])) :- !. +ubody(B0, B, + brace_term_position(F,T,A0), + Pos) :- + B0 = (_,_=_), !, + T1 is T - 1, + ubody(B0, B, + term_position(F,T, + F,T, + [A0,T1-T]), + Pos). +ubody(B0, B, + brace_term_position(F,T,A0), + term_position(F,T,F,T,[A])) :- !, + ubody(B0, B, A0, A). +ubody(C0, C, P0, P) :- + nonvar(C0), nonvar(C), + C0 = (_,_), C = (_,_), !, + conj(C0, P0, GL, PL), + mkconj(C, P, GL, PL). +ubody(X0, X, + term_position(F,T,FF,TT,PA0), + term_position(F,T,FF,TT,PA)) :- + meta(X0), !, + X0 =.. [_|A0], + X =.. [_|A], + ubody_list(A0, A, PA0, PA). + % 5.7.X optimizations +ubody(_=_, true, % singleton = Any + term_position(F,T,_FF,_TT,_PA), + F-T) :- !. +ubody(_==_, fail, % singleton/firstvar == Any + term_position(F,T,_FF,_TT,_PA), + F-T) :- !. +ubody(A1=B1, B2=A2, % Term = Var --> Var = Term + term_position(F,T,FF,TT,[PA1,PA2]), + term_position(F,T,FF,TT,[PA2,PA1])) :- + (A1==B1) =@= (B2==A2), !, + A1 = A2, B1=B2. +ubody(A1==B1, B2==A2, % const == Var --> Var == const + term_position(F,T,FF,TT,[PA1,PA2]), + term_position(F,T,FF,TT,[PA2,PA1])) :- + (A1==B1) =@= (B2==A2), !, + A1 = A2, B1=B2. +ubody(A is B - C, A is B + C2, Pos, Pos) :- + integer(C), + C2 =:= -C, !. + +ubody_list([], [], [], []). +ubody_list([G0|T0], [G|T], [PA0|PAT0], [PA|PAT]) :- + ubody(G0, G, PA0, PA), + ubody_list(T0, T, PAT0, PAT). + + +conj(Goal, Pos, GoalList, PosList) :- + conj(Goal, Pos, GoalList, [], PosList, []). + +conj((A,B), term_position(_,_,_,_,[PA,PB]), GL, TG, PL, TP) :- !, + conj(A, PA, GL, TGA, PL, TPA), + conj(B, PB, TGA, TG, TPA, TP). +conj((A,B), brace_term_position(_,T,PA), GL, TG, PL, TP) :- + B = (_=_), !, + conj(A, PA, GL, TGA, PL, TPA), + T1 is T - 1, + conj(B, T1-T, TGA, TG, TPA, TP). +conj((!,(S=SR)), F-T, [!,S=SR|TG], TG, [F-T,F1-T1|TP], TP) :- + F1 is F+1, + T1 is T+1. +conj(A, P, [A|TG], TG, [P|TP], TP). + + +mkconj(Goal, Pos, GoalList, PosList) :- + mkconj(Goal, Pos, GoalList, [], PosList, []). + +mkconj(Conj, term_position(0,0,0,0,[PA,PB]), GL, TG, PL, TP) :- + nonvar(Conj), + Conj = (A,B), !, + mkconj(A, PA, GL, TGA, PL, TPA), + mkconj(B, PB, TGA, TG, TPA, TP). +mkconj(A0, P0, [A|TG], TG, [P|TP], TP) :- + ubody(A, A0, P, P0). + + + /******************************* + * PCE STUFF (SHOULD MOVE) * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + (Receiver, ... Arg ...) :-> + Body + +mapped to: + + send_implementation(Id, (...Arg...), Receiver) + +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +pce_method_clause(Head, Body, _:PlHead, PlBody, TermPos0, TermPos) :- !, + pce_method_clause(Head, Body, PlBody, PlHead, TermPos0, TermPos). +pce_method_clause(Head, Body, + send_implementation(_Id, Msg, Receiver), PlBody, + TermPos0, TermPos) :- !, + debug(clause_info, 'send method ...', []), + arg(1, Head, Receiver), + functor(Head, _, Arity), + pce_method_head_arguments(2, Arity, Head, Msg), + debug(clause_info, 'head ...', []), + pce_method_body(Body, PlBody, TermPos0, TermPos). +pce_method_clause(Head, Body, + get_implementation(_Id, Msg, Receiver, Result), PlBody, + TermPos0, TermPos) :- !, + debug(clause_info, 'get method ...', []), + arg(1, Head, Receiver), + debug(clause_info, 'receiver ...', []), + functor(Head, _, Arity), + arg(Arity, Head, PceResult), + debug(clause_info, '~w?~n', [PceResult = Result]), + pce_unify_head_arg(PceResult, Result), + Ar is Arity - 1, + pce_method_head_arguments(2, Ar, Head, Msg), + debug(clause_info, 'head ...', []), + pce_method_body(Body, PlBody, TermPos0, TermPos). + +pce_method_head_arguments(N, Arity, Head, Msg) :- + N =< Arity, !, + arg(N, Head, PceArg), + PLN is N - 1, + arg(PLN, Msg, PlArg), + pce_unify_head_arg(PceArg, PlArg), + debug(clause_info, '~w~n', [PceArg = PlArg]), + NextArg is N+1, + pce_method_head_arguments(NextArg, Arity, Head, Msg). +pce_method_head_arguments(_, _, _, _). + +pce_unify_head_arg(V, A) :- + var(V), !, + V = A. +pce_unify_head_arg(A:_=_, A) :- !. +pce_unify_head_arg(A:_, A). + +% pce_method_body(+SrcBody, +DbBody, +TermPos0, -TermPos +% +% Unify the body of an XPCE method. Goal-expansion makes this +% rather tricky, especially as we cannot call XPCE's expansion +% on an isolated method. +% +% TermPos0 is the term-position term of the whole clause! +% +% Further, please note that the body of the method-clauses reside +% in another module than pce_principal, and therefore the body +% starts with an I_CONTEXT call. This implies we need a +% hypothetical term-position for the module-qualifier. + +pce_method_body(A0, A, TermPos0, TermPos) :- + TermPos0 = term_position(F, T, FF, FT, + [ HeadPos, + BodyPos0 + ]), + TermPos = term_position(F, T, FF, FT, + [ HeadPos, + term_position(0,0,0,0, [0-0,BodyPos]) + ]), + pce_method_body2(A0, A, BodyPos0, BodyPos). + + +pce_method_body2(::(_,A0), A, TermPos0, TermPos) :- !, + TermPos0 = term_position(_, _, _, _, [_Cmt,BodyPos0]), + TermPos = BodyPos, + expand_goal(A0, A, BodyPos0, BodyPos). +pce_method_body2(A0, A, TermPos0, TermPos) :- + A0 =.. [Func,B0,C0], + control_op(Func), !, + A =.. [Func,B,C], + TermPos0 = term_position(F, T, FF, FT, + [ BP0, + CP0 + ]), + TermPos = term_position(F, T, FF, FT, + [ BP, + CP + ]), + pce_method_body2(B0, B, BP0, BP), + expand_goal(C0, C, CP0, CP). +pce_method_body2(A0, A, TermPos0, TermPos) :- + expand_goal(A0, A, TermPos0, TermPos). + +control_op(','). +control_op((;)). +control_op((->)). +control_op((*->)). + + /******************************* + * EXPAND_GOAL SUPPORT * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +With the introduction of expand_goal, it is increasingly hard to relate +the clause from the database to the actual source. For one thing, we do +not know the compilation module of the clause (unless we want to +decompile it). + +Goal expansion can translate goals into control-constructs, multiple +clauses, or delete a subgoal. + +To keep track of the source-locations, we have to redo the analysis of +the clause as defined in init.pl +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +expand_goal(G, call(G), P, term_position(0,0,0,0,[P])) :- + var(G), !. +expand_goal(G, G, P, P) :- + var(G), !. +expand_goal(M0, M, P0, P) :- + meta(M0), !, + P0 = term_position(F,T,FF,FT,PL0), + P = term_position(F,T,FF,FT,PL), + functor(M0, Functor, Arity), + functor(M, Functor, Arity), + expand_meta_args(PL0, PL, 1, M0, M). +expand_goal(A, B, P0, P) :- + goal_expansion(A, B0, P0, P1), !, + expand_goal(B0, B, P1, P). +expand_goal(A, A, P, P). + +expand_meta_args([], [], _, _, _). +expand_meta_args([P0|T0], [P|T], I, M0, M) :- + arg(I, M0, A0), + arg(I, M, A), + expand_goal(A0, A, P0, P), + NI is I + 1, + expand_meta_args(T0, T, NI, M0, M). + +meta((_ , _)). +meta((_ ; _)). +meta((_ -> _)). +meta((_ *-> _)). +meta((\+ _)). +meta((not(_))). +meta((call(_))). +meta((once(_))). +meta((ignore(_))). +meta((forall(_, _))). + +goal_expansion(send(R, Msg), send_class(R, _, SuperMsg), P, P) :- + compound(Msg), + Msg =.. [send_super, Selector | Args], !, + SuperMsg =.. [Selector|Args]. +goal_expansion(get(R, Msg, A), get_class(R, _, SuperMsg, A), P, P) :- + compound(Msg), + Msg =.. [get_super, Selector | Args], !, + SuperMsg =.. [Selector|Args]. +goal_expansion(send_super(R, Msg), send_class(R, _, Msg), P, P). +goal_expansion(get_super(R, Msg, V), get_class(R, _, Msg, V), P, P). +goal_expansion(SendSuperN, send_class(R, _, Msg), P, P) :- + compound(SendSuperN), + SendSuperN =.. [send_super, R, Sel | Args], + Msg =.. [Sel|Args]. +goal_expansion(SendN, send(R, Msg), P, P) :- + compound(SendN), + SendN =.. [send, R, Sel | Args], + atom(Sel), Args \== [], + Msg =.. [Sel|Args]. +goal_expansion(GetSuperN, get_class(R, _, Msg, Answer), P, P) :- + compound(GetSuperN), + GetSuperN =.. [get_super, R, Sel | AllArgs], + append(Args, [Answer], AllArgs), + Msg =.. [Sel|Args]. +goal_expansion(GetN, get(R, Msg, Answer), P, P) :- + compound(GetN), + GetN =.. [get, R, Sel | AllArgs], + append(Args, [Answer], AllArgs), + atom(Sel), Args \== [], + Msg =.. [Sel|Args]. +goal_expansion(G0, G, P, P) :- + user:goal_expansion(G0, G), % TBD: we need the module! + G0 \== G. % \=@=? + + + /******************************* + * PRINTABLE NAMES * + *******************************/ + +:- module_transparent + predicate_name/2. +:- multifile + user:prolog_predicate_name/2, + user:prolog_clause_name/2. + +hidden_module(user). +hidden_module(system). +hidden_module(pce_principal). % should be config +hidden_module(Module) :- % SWI-Prolog specific + import_module(Module, system). + +thaffix(1, st) :- !. +thaffix(2, nd) :- !. +thaffix(_, th). + +%% predicate_name(:Head, -PredName:string) is det. +% +% Describe a predicate as [Module:]Name/Arity. + +predicate_name(Predicate, PName) :- + strip_module(Predicate, Module, Head), + ( user:prolog_predicate_name(Module:Head, PName) + -> true + ; functor(Head, Name, Arity), + ( hidden_module(Module) + -> format(string(PName), '~q/~d', [Name, Arity]) + ; format(string(PName), '~q:~q/~d', [Module, Name, Arity]) + ) + ). + +%% clause_name(+Ref, -Name) +% +% Provide a suitable description of the indicated clause. + +clause_name(Ref, Name) :- + user:prolog_clause_name(Ref, Name), !. +clause_name(Ref, Name) :- + nth_clause(Head, N, Ref), !, + predicate_name(Head, PredName), + thaffix(N, Th), + format(string(Name), '~d-~w clause of ~w', [N, Th, PredName]). +clause_name(_, ''). diff --git a/LGPL/prolog_colour.pl b/LGPL/prolog_colour.pl new file mode 100644 index 000000000..8b4fe1cfe --- /dev/null +++ b/LGPL/prolog_colour.pl @@ -0,0 +1,1508 @@ +/* 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) + ]). + +/** Prolog syntax colouring support. + +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, '', 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] ].