/*  Part of XPCE --- The SWI-Prolog GUI toolkit

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        jan@swi.psy.uva.nl
    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    Copyright (c)  1995-2013, University of Amsterdam
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

:- module(pce_expansion,
        [ pce_term_expansion/2,         % +In, -Out
          pce_compiling/1,              % -ClassName
          pce_compiling/2,              % -ClassName, -Path
          pce_begin_recording/1,        % +- source|documentation
          pce_end_recording/0
        ]).
:- use_module(pce_principal).
:- require([ pce_error/1
           , pce_info/1
           , pce_warn/1
           , string/1
           , atomic_list_concat/2
           , expand_goal/2
           , flatten/2
           , forall/2
           , reverse/2
           , source_location/2
           , string_codes/2
           , append/3
           , atom_concat/3
           , between/3
           , maplist/3
           , sub_atom/5
           , push_operators/1
           , pop_operators/0
           ]).

:- dynamic
    compiling/2,                    % -ClassName
    attribute/3,                    % ClassName, Attribute, Value
    verbose/0,
    recording/2.                    % items recorded
:- public
    attribute/3,
    compiling/2.

:- if(exists_source(library(quintus))).
:- use_module(library(quintus), [genarg/3]).
:- endif.

                 /*******************************
                 *           OPERATORS          *
                 *******************************/

%       push_compile_operators.
%
%       Push operator definitions  that  are   specific  to  XPCE  class
%       definitions.

:- module_transparent
    push_compile_operators/0.

push_compile_operators :-
    context_module(M),
    push_compile_operators(M).

push_compile_operators(M) :-
    push_operators(M:
            [ op(1200, xfx, :->)
            , op(1200, xfx, :<-)
            , op(910,  xfy, ::)     % above \+
            , op(100,  xf,  *)
            , op(125,  xf,  ?)
            , op(150,  xf,  ...)
            , op(100,  xfx, ..)
            ]).

pop_compile_operators :-
    pop_operators.

:- push_compile_operators.

%verbose.

pce_term_expansion(In, Out) :-
    pce_pre_expand(In, In0),
    (   is_list(In0)
    ->  maplist(map_term_expand, In0, In1),
        flatten(In1, Out0),
        (   Out0 = [X]
        ->  Out = X
        ;   Out = Out0
        )
    ;   do_term_expand(In0, Out)
    ).

map_term_expand(X, X) :-
    var(X),
    !.
map_term_expand(X, Y) :-
    do_term_expand(X, Y),
    !.
map_term_expand(X, X).


do_term_expand(end_of_file, _) :-
    cleanup, !, fail.
do_term_expand(In0, Out) :-
    pce_expandable(In0),
    (   do_expand(In0, Out0)
    ->  (   pce_post_expand(Out0, Out)
        ->  true
        ;   Out = Out0
        )
    ;   pce_error(expand_failed(In0)),
        Out = []
    ),
    !.
do_term_expand((Head :- Body), _) :-    % check for :- instead of :-> or :<-
    pce_compiling,
    (   Body = ::(Doc, _Body),      % TBD
        is_string(Doc)
    ;   typed_head(Head)
    ),
    pce_error(context_error((Head :- Body), nomethod, clause)),
    fail.


%!  is_string(@Doc) is semidet.
%
%   See whether Doc may have originated from "..."

is_string(Doc) :-
    string(Doc),
    !.
is_string(Doc) :-
    is_list(Doc),
    catch(string_codes(Doc, _), _, fail).

typed_head(T) :-
    functor(T, _, Arity),
    Arity > 1,
    forall(genarg(N, T, A), head_arg(N, A)).

head_arg(1, A) :-
    !,
    var(A).
head_arg(_, A) :-
    nonvar(A),
    (   A = (_:TP)
    ->  true
    ;   A = (_:Name=TP),
        atom(Name)
    ),
    ground(TP).

%!  pce_pre_expand(+In, -Out)
%
%   First step of the XPCE class compiler, calling the supported
%   hook pce_pre_expansion_hook/2.

:- multifile user:pce_pre_expansion_hook/2.
:- dynamic user:pce_pre_expansion_hook/2.
:- multifile user:pce_post_expansion_hook/2.
:- dynamic user:pce_post_expansion_hook/2.

pce_pre_expand(X, Y) :-
    user:pce_pre_expansion_hook(X, X1),
    !,
    (   is_list(X1)
    ->  maplist(do_pce_pre_expand, X1, Y)
    ;   do_pce_pre_expand(X1, Y)
    ).
pce_pre_expand(X, Y) :-
    do_pce_pre_expand(X, Y).

do_pce_pre_expand((:- pce_begin_class(Class, Super)),
                  (:- pce_begin_class(Class, Super, @default))).
do_pce_pre_expand(variable(Name, Type, Access),
                  variable(Name, Type, Access, @default)) :-
    pce_compiling.
do_pce_pre_expand(class_variable(Name, Type, Default),
                  class_variable(Name, Type, Default, @default)) :-
    pce_compiling.
do_pce_pre_expand(handle(X, Y, Kind),
                  handle(X, Y, Kind, @default)) :-
    pce_compiling.
do_pce_pre_expand((:- ClassDirective), D) :-
    functor(ClassDirective, send, _),
    arg(1, ClassDirective, @class),
    !,
    D = (:- pce_class_directive(ClassDirective)).
do_pce_pre_expand(pce_ifhostproperty(Prop, Clause), TheClause) :-
    (   pce_host:property(Prop)
    ->  TheClause = Clause
    ;   TheClause = []
    ).
do_pce_pre_expand(pce_ifhostproperty(Prop, If, Else), Clause) :-
    (   pce_host:property(Prop)
    ->  Clause = If
    ;   Clause = Else
    ).
do_pce_pre_expand(X, X).


%!  pce_post_expand(In, Out)

pce_post_expand([], []).
pce_post_expand([H0|T0], [H|T]) :-
    user:pce_post_expansion_hook(H0, H),
    !,
    pce_post_expand(T0, T).
pce_post_expand([H|T0], [H|T]) :-
    pce_post_expand(T0, T).
pce_post_expand(T0, T) :-
    user:pce_post_expansion_hook(T0, T),
    !.
pce_post_expand(T, T).


%!  pce_expandable(+Term)
%   Quick test whether we can expand this.

pce_expandable((:- pce_begin_class(_Class, _Super, _Doc))).
pce_expandable((:- pce_extend_class(_Class))).
pce_expandable((:- pce_end_class)).
pce_expandable((:- pce_end_class(_))).
pce_expandable((:- use_class_template(_TemplateClass))).
pce_expandable((:- pce_group(_))).
pce_expandable((:- pce_class_directive(_))).
pce_expandable(variable(_Name, _Type, _Access, _Doc)) :-
    pce_compiling.
pce_expandable(class_variable(_Name, _Type, _Default, _Doc)) :-
    pce_compiling.
pce_expandable(delegate_to(_VarName)) :-
    pce_compiling.
pce_expandable(handle(_X, _Y, _Kind, _Name)) :-
    pce_compiling.
pce_expandable(:->(_Head, _Body)).
pce_expandable(:<-(_Head, _Body)).


%!  do_expand(In, Out)
%
%   The XPCE kernel expansion.

do_expand((:- pce_begin_class(Spec, Super, Doc)),
          (:- pce_begin_class_definition(ClassName, MetaClass, Super, Doc))) :-
    break_class_specification(Spec, ClassName, MetaClass, TermArgs),
    can_define_class(ClassName, Super),
    push_class(ClassName),
    set_attribute(ClassName, super, Super),
    set_attribute(ClassName, meta, MetaClass),
    class_summary(ClassName, Doc),
    class_source(ClassName),
    term_names(ClassName, TermArgs).
do_expand((:- pce_extend_class(ClassName)), []) :-
    push_class(ClassName),
    set_attribute(ClassName, extending, true).
do_expand((:- pce_end_class(Class)), Expansion) :-
    (   pce_compiling(ClassName),
        (   Class == ClassName
        ->  do_expand((:- pce_end_class), Expansion)
        ;   pce_error(end_class_mismatch(Class, ClassName))
        )
    ;   pce_error(no_class_to_end)
    ).
do_expand((:- pce_end_class),
          [ pce_principal:pce_class(ClassName, MetaClass, Super,
                                    Variables,
                                    Resources,
                                    Directs),
            RegisterDecl
          ]) :-
    pce_compiling(ClassName),
    !,
    findall(V, retract(attribute(ClassName, variable, V)),  Variables),
    findall(R, retract(attribute(ClassName, classvar, R)),  Resources),
    findall(D, retract(attribute(ClassName, directive, D)), Directs),
    (   attribute(ClassName, extending, true)
    ->  MetaClass = (-),
        Super = (-),
        expand_term((:- initialization(pce_extended_class(ClassName))),
                    RegisterDecl)
    ;   retract(attribute(ClassName, super, Super)),
        retract(attribute(ClassName, meta, MetaClass)),
        expand_term((:- initialization(pce_register_class(ClassName))),
                    RegisterDecl)
    ),
    pop_class.
do_expand((:- pce_end_class), []) :-
    pce_error(no_class_to_end).
do_expand((:- use_class_template(_)), []) :-
    current_prolog_flag(xref, true),
    !.
do_expand((:- use_class_template(Template)), []) :-
    used_class_template(Template),
    !.
do_expand((:- use_class_template(Template)),
          [ pce_principal:pce_uses_template(ClassName, Template)
          | LinkClauses
          ]) :-
    pce_compiling(ClassName),
    use_template_class_attributes(Template),
    use_template_send_methods(Template, SendClauses),
    use_template_get_methods(Template, GetClauses),
    append(SendClauses, GetClauses, LinkClauses).
do_expand((:- pce_group(Group)), []) :-
    pce_compiling(ClassName),
    set_attribute(ClassName, group, Group).
do_expand(variable(Name, Type, Access, Doc), []) :-
    pce_compiling(ClassName),
    current_group(ClassName, Group),
    pce_access(Access),
    var_type(Type, PceType, Initial),
    pce_summary(Doc, PceDoc),
    strip_defaults([Initial, Group, PceDoc], Defs),
    Var =.. [variable, Name, PceType, Access | Defs],
    add_attribute(ClassName, variable, Var).
do_expand(class_variable(Name, Type, Default, Doc), []) :-
    pce_compiling(ClassName),
    prolog_load_context(module, M),
    pce_type(Type, PceType),
    pce_summary(Doc, PceDoc),
    add_attribute(ClassName, classvar,
                  M:class_variable(Name, Default, PceType, PceDoc)).
do_expand(handle(X, Y, Kind, Name), []) :-
    pce_compiling(ClassName),
    add_attribute(ClassName, directive,
                  send(@class, handle, handle(X, Y, Kind, Name))).
do_expand(delegate_to(Var), []) :-
    pce_compiling(ClassName),
    add_attribute(ClassName, directive,
                  send(@class, delegate, Var)).
do_expand((:- pce_class_directive(Goal)),
          (:- initialization((send(@class, assign, Class),
                              Goal)))) :-
    pce_compiling(ClassName),
    realised_class(ClassName),
    attribute(ClassName, extending, true),
    !,
    get(@classes, member, ClassName, Class).
do_expand((:- pce_class_directive(Goal)), (:- Goal)) :-
    pce_compiling(ClassName),
    realised_class(ClassName),
    !.
do_expand((:- pce_class_directive(Goal)), []) :-
    pce_compiling(ClassName),
    prolog_load_context(module, M),
    add_attribute(ClassName, directive, M:Goal).
do_expand(:->(Head, DocBody),
          [ pce_principal:pce_lazy_send_method(Selector, ClassName, LSM)
          | Clauses
          ]) :-
    extract_documentation(DocBody, Doc, Body),
    source_location_term(Loc),
    pce_compiling(ClassName),
    current_group(ClassName, Group),
    prolog_head(send, Id, Head, Selector, Types, PlHead),
    strip_defaults([Group, Loc, Doc], NonDefArgs),
    LSM =.. [bind_send, Id, Types | NonDefArgs],
    Clause = (PlHead :- Body),
    gen_method_id((->), ClassName, Selector, Id),
    (   attribute(ClassName, super, template)
    ->  template_clause(Clause, Clauses)
    ;   Clauses = [Clause]
    ),
    (   realised_class(ClassName)   % force a reload (TBD: move to realise)
    ->  send(@class, delete_send_method, Selector)
    ;   true
    ),
    feedback(expand_send(ClassName, Selector)).
do_expand(:<-(Head, DocBody),
          [ pce_principal:pce_lazy_get_method(Selector, ClassName, LGM)
          | Clauses
          ]) :-
    extract_documentation(DocBody, Doc, Body),
    source_location_term(Loc),
    pce_compiling(ClassName),
    current_group(ClassName, Group),
    return_type(Head, RType),
    prolog_head(get, Id, Head, Selector, Types, PlHead),
    strip_defaults([Group, Loc, Doc], NonDefArgs),
    LGM =.. [bind_get, Id, RType, Types | NonDefArgs],
    Clause = (PlHead :- Body),
    gen_method_id((<-), ClassName, Selector, Id),
    (   attribute(ClassName, super, template)
    ->  template_clause(Clause, Clauses)
    ;   Clauses = [Clause]
    ),
    (   realised_class(ClassName)   % force a reload
    ->  send(@class, delete_get_method, Selector)
    ;   true
    ),
    feedback(expand_get(ClassName, Selector)).

strip_defaults([@default|T0], T) :-
    !,
    strip_defaults(T0, T).
strip_defaults(L, LV) :-
    reverse(L, LV).

break_class_specification(Meta:Term, ClassName, Meta, TermArgs) :-
    !,
    Term =.. [ClassName|TermArgs].
break_class_specification(Term, ClassName, @default, TermArgs) :-
    Term =.. [ClassName|TermArgs].

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
gen_method_id(+SendGet, +Class, +Selector, -Identifier)

Generate a unique identifier for the method,  used as the first argument
of send_implementation/3 or get_implementation/4.  The identifier should
be an atom or integer. The  value  is   not  relevant,  as long as it is
unique.

This  suggests  simple  counting:  always    unique   and  integers  are
considerably cheaper than atoms. Unfortunately, there  is a problem with
this. If methods appear in pre-compiled files, they cannot be joined. It
is hard to see a good and workable  solution to this problem. Grant each
file a domain? How do we associate a unique domain to each file?
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

gen_method_id(SG, Class, Selector, Id) :-
    attribute(Class, extending, true),
    !,
    atomic_list_concat([Class, '$+$', SG, Selector], Id).
gen_method_id(SG, Class, Selector, Id) :-
    atomic_list_concat([Class, SG, Selector], Id).

%gen_method_id(_, _, _, Id) :-
%%      flag(pce_method_id, Id, Id+1).

                 /*******************************
                 *       TEMPLATE SUPPORT       *
                 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
When compiling a template, calls to   send_class/3 and get_class/4 refer
to the template  classes.  This  is   not  correct.  Therefore,  we will
translate  the  method  implementation   into    a   parameterized  real
implementation and a normal implementation  that calls the parameterized
one. On method instantiation, we create additional clauses for the class
to which we attach the method.

Importing the template (pce_use_class_template/1):

        + Put binding in bind_lazy by searching the templates.
        + Expand the directive itself into the wrapper-implementations.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

template_clause((M:send_implementation(Id, Msg, R) :- Body),
                [ (M:send_implementation(Tid, ClassMsg, R) :- ClassBody),
                  (M:(send_implementation(Id, Msg, R) :-
                        send_implementation(Tid, IClassMsg, R)))
                ]) :-
    !,
    atom_concat('T-', Id, Tid),
    Msg =.. Args,
    append(Args, [Class], Args2),
    ClassMsg =.. Args2,
    append(Args, [template], Args3),
    IClassMsg =.. Args3,
    template_body(Body, template, Class, ClassBody).
template_clause((M:get_implementation(Id, Msg, R, V) :- Body),
                [ (M:get_implementation(Tid, ClassMsg, R, V) :- ClassBody),
                  (M:(get_implementation(Id, Msg, R, V) :-
                        get_implementation(Tid, IClassMsg, R, V)))
                ]) :-
    !,
    atom_concat('T-', Id, Tid),
    Msg =.. Args,
    append(Args, [Class], Args2),
    ClassMsg =.. Args2,
    append(Args, [template], Args3),
    IClassMsg =.. Args3,
    template_body(Body, template, Class, ClassBody).
template_clause(Clause, Clause).

template_body(G0, T, C, G) :-
    compound(G0),
    functor(G0, Name, Arity),
    functor(M, Name, Arity),
    meta(M),
    !,
    functor(G, Name, Arity),
    convert_meta(0, Arity, G0, M, T, C, G).
template_body(G, T, C, send_class(R, C, Msg)) :-
    expand_goal(G, send_class(R, T, Msg)),
    !.
template_body(G, T, C, get_class(R, C, Msg, V)) :-
    expand_goal(G, get_class(R, T, Msg, V)),
    !.
template_body(G, _, _, G).

convert_meta(A, A, _, _, _, _, _) :- !.
convert_meta(I, Arity, G0, M, T, C, G) :-
    A is I + 1,
    arg(A, M, :),
    !,
    arg(A, G0, GA0),
    arg(A, G,  GA),
    template_body(GA0, T, C, GA),
    convert_meta(A, Arity, G0, M, T, C, G).
convert_meta(I, Arity, G0, M, T, C, G) :-
    A is I + 1,
    arg(A, G0, GA),
    arg(A, G,  GA),
    convert_meta(A, Arity, G0, M, T, C, G).

meta(','(:, :)).                        % TBD: synchronise with boot/init.pl
meta(;(:, :)).
meta(->(:, :)).
meta(*->(:, :)).
meta(\+(:)).
meta(not(:)).
meta(call(:)).
meta(once(:)).
meta(ignore(:)).
meta(forall(:, :)).
meta(findall(-, :, -)).
meta(bagof(-, :, -)).
meta(setof(-, :, -)).
meta(^(-,:)).

%!  use_template_class_attributes(+Template)
%
%   Insert variables, class-variables and directives as if they appeared
%   in the current class definition.

use_template_class_attributes(Template) :-
    pce_class(Template, _, template, Variables, ClassVars, Directs),
    assert_attributes(Variables, variable),
    assert_attributes(ClassVars, classvar),
    assert_attributes(Directs,   directive).

assert_attributes([], _).
assert_attributes([H|T], Att) :-
    pce_compiling(ClassName),
    (   H = send(@class, source, _Source)
    ->  true
    ;   add_attribute(ClassName, Att, H)
    ),
    assert_attributes(T, Att).

use_template_send_methods(Template, Clauses) :-
    findall(C, use_template_send_method(Template, C), Clauses).

use_template_send_method(Template, pce_principal:Clause) :-
    pce_compiling(ClassName),
    pce_lazy_send_method(Sel, Template, Binder),
    Binder =.. [Functor, Id | RestBinder],
    gen_method_id('$T$->', ClassName, Sel, NewId),
    (   Clause = pce_lazy_send_method(Sel, ClassName, NewBinder),
        NewBinder =.. [Functor, NewId | RestBinder]
    ;   Clause = (send_implementation(NewId, Msg, R) :-
                    send_implementation(Tid, IClassMsg, R)),
        attribute(ClassName, super, SuperClass), % TBD: pce_extend_class/1
        arg(2, Binder, Types),
        type_arity(Types, Arity),
        functor(Msg, Sel, Arity),
        Msg =.. Args,
        append(Args, [SuperClass], Args1),
        IClassMsg =.. Args1,
        atom_concat('T-', Id, Tid)
    ).

use_template_get_methods(Template, Clauses) :-
    findall(C, use_template_get_method(Template, C), Clauses).

use_template_get_method(Template, pce_principal:Clause) :-
    pce_compiling(ClassName),
    pce_lazy_get_method(Sel, Template, Binder),
    Binder =.. [Functor, Id | RestBinder],
    gen_method_id('$T$<-', ClassName, Sel, NewId),
    (   Clause = pce_lazy_get_method(Sel, ClassName, NewBinder),
        NewBinder =.. [Functor, NewId | RestBinder]
    ;   Clause = (get_implementation(NewId, Msg, R, V) :-
                    get_implementation(Tid, IClassMsg, R, V)),
        attribute(ClassName, super, SuperClass), % TBD: pce_extend_class/1
        arg(3, Binder, Types),
        type_arity(Types, Arity),
        functor(Msg, Sel, Arity),
        Msg =.. Args,
        append(Args, [SuperClass], Args1),
        IClassMsg =.. Args1,
        atom_concat('T-', Id, Tid)
    ).

type_arity(@default, 0) :- !.
type_arity(Atom, 1) :-
    atom(Atom),
    !.
type_arity(Vector, A) :-
    functor(Vector, _, A).

%!  used_class_template(+Template)
%
%   Succeeds if any of my (Prolog-defined) super classes
%   has imported the named template.

used_class_template(Template) :-
    pce_compiling(Class),
    isa_prolog_class(Class, Super),
    Super \== Class,
    pce_uses_template(Super, Template),
    !.

isa_prolog_class(Class, Class).
isa_prolog_class(Class, Super) :-
    attribute(Class, super, Super0),       % Prolog class being loaded
    !,
    isa_prolog_class(Super0, Super).
isa_prolog_class(Class, Super) :-               % Loaded Prolog class
    pce_class(Class, _, Super0, _, _, _),
    !,
    isa_prolog_class(Super0, Super).


                 /*******************************
                 *            CHECKING          *
                 *******************************/

%!  can_define_class(+Name, +Super)
%
%   Check whether we can define Name as   a  subclass of Super. This
%   cannot be done of Name  is  a   builtin  class  or it is already
%   defined at another location.

can_define_class(Name, _Super) :-
    get(@classes, member, Name, Class),
    get(Class, creator, built_in),
    !,
    throw(error(permission_error(modify, pce(built_in_class), Name), _)).
can_define_class(Name, _Super) :-
    flag('$compilation_level', Level, Level),
    Level > 0,                      % SWI: we are running consult
    pce_class(Name, _Meta, _OldSuper, _Vars, _ClassVars, _Dirs),
    throw(error(permission_error(modify, pce(class), Name), _)).
can_define_class(Name, _Super) :-
    get(@types, member, Name, Type),
    \+ get(Type, kind, class),
    throw(error(permission_error(define, pce(class), Name),
                context(pce_begin_class/3,
                        'Already defined as a type'))).
can_define_class(_, _).


                 /*******************************
                 *   PUSH/POP CLASS STRUCTURE   *
                 *******************************/

%!  push_class(+ClassName)
%   Start compiling the argument class.

push_class(ClassName) :-
    compiling(ClassName, _),
    !,
    pce_error(recursive_loading_class(ClassName)),
    fail.
push_class(ClassName) :-
    prolog_load_context(module, M),
    push_compile_operators(M),
    (   source_location(Path, _Line)
    ->  true
    ;   Path = []
    ),
    asserta(compiling(ClassName, Path)),
    (   realised_class(ClassName)
    ->  get(@class, '_value', OldClassVal),
        asserta(attribute(ClassName, old_class_val, OldClassVal)),
        get(@classes, member, ClassName, Class),
        send(@class, assign, Class, global)
    ;   true
    ).

%       pop_class
%       End class compilation.

pop_class :-
    retract(compiling(ClassName, _)),
    !,
    (   attribute(ClassName, old_class_val, OldClassVal)
    ->  send(@class, assign, OldClassVal, global)
    ;   true
    ),
    retractall(attribute(ClassName, _, _)),
    pop_compile_operators.
pop_class :-
    pce_error(no_class_to_end),
    fail.

                 /*******************************
                 *           ATTRIBUTES         *
                 *******************************/

set_attribute(Class, Name, Value) :-
    retractall(attribute(Class, Name, _)),
    asserta(attribute(Class, Name, Value)).

add_attribute(Class, Name, Value) :-
    assert(attribute(Class, Name, Value)).


                 /*******************************
                 *        CONTEXT VALUES        *
                 *******************************/

source_location_term(source_location(File, Line)) :-
    pce_recording(source),
    source_location(File, Line),
    !.
source_location_term(@default).

current_group(Class, Group) :-
    attribute(Class, group, Group),
    !.
current_group(_, @default).

class_source(ClassName) :-
    pce_recording(source),
    source_location_term(Term),
    Term \== @default,
    !,
    add_attribute(ClassName, directive,
                  send(@class, source, Term)).
class_source(_).


                 /*******************************
                 *           RECORDING          *
                 *******************************/

pce_begin_recording(+Topic) :-
    asserta(recording(Topic, true)).
pce_begin_recording(-Topic) :-
    asserta(recording(Topic, fail)).

pce_end_recording :-
    retract(recording(_, _)),
    !.

pce_recording(Topic) :-
    recording(Topic, X),
    !,
    X == true.
pce_recording(_).                       % default recording all


                 /*******************************
                 *        SUMMARY HANDLING      *
                 *******************************/

class_summary(ClassName, Summary) :-
    pce_summary(Summary, PceSummary),
    (   PceSummary \== @default
    ->  add_attribute(ClassName, directive,
                      send(@class, summary, PceSummary))
    ;   true
    ).


pce_summary(@X, @X) :- !.
pce_summary(_, @default) :-
    \+ pce_recording(documentation),
    !.
pce_summary(Atomic, Atomic) :-
    atomic(Atomic),
    !.
pce_ifhostproperty(string, [
(pce_summary(String, String) :-
        string(String), !),
(pce_summary(List, String) :-
        string_codes(String, List))]).
pce_summary(List, string(List)).


                 /*******************************
                 *       TERM DESCRIPTION       *
                 *******************************/

term_names(_, []) :- !.
term_names(Class, Selectors) :-
    check_term_selectors(Selectors),
    VectorTerm =.. [vector|Selectors],
    add_attribute(Class, directive,
                  send(@class, term_names, new(VectorTerm))).


check_term_selectors([]).
check_term_selectors([H|T]) :-
    (   atom(H)
    ->  true
    ;   pce_error(bad_term_argument(H)),
        fail
    ),
    check_term_selectors(T).


                 /*******************************
                 *             ACCESS           *
                 *******************************/

pce_access(both) :- !.
pce_access(get)  :- !.
pce_access(send) :- !.
pce_access(none) :- !.
pce_access(X) :-
    pce_error(invalid_access(X)),
    fail.


                 /*******************************
                 *             TYPES            *
                 *******************************/

%!  pce_type(+Spec, -PceTypeName)
%   Convert type specification into legal PCE type-name

pce_type(Prolog, Pce) :-
    to_atom(Prolog, RawPce),
    canonicalise_type(RawPce, Pce).

canonicalise_type(T0, T0) :-
    sub_atom(T0, _, _, 0, ' ...'),
    !.
canonicalise_type(T0, T) :-
    atom_concat(T1, '...', T0),
    !,
    atom_concat(T1, ' ...', T).
canonicalise_type(T, T).

to_atom(Atom, Atom) :-
    atom(Atom),
    !.
to_atom(Term, Atom) :-
    ground(Term),
    !,
    phrase(pce_type_description(Term), Chars),
    atom_chars(Atom, Chars).
to_atom(Term, any) :-
    pce_error(type_error(to_atom(Term, any), 1, ground, Term)).

pce_type_description(Atom, Chars, Tail) :-
    atomic(Atom),
    !,
    name(Atom, C0),
    append(C0, Tail, Chars).
pce_type_description([X]) -->
    "[", pce_type_description(X), "]".
pce_type_description([X|Y]) -->
    "[", pce_type_description(X), "|", pce_type_description(Y), "]".
pce_type_description({}(Words)) -->
    "{", word_list(Words), "}".
pce_type_description(=(Name, Type)) -->
    pce_type_description(Name), "=", pce_type_description(Type).
pce_type_description(*(T)) -->
    pce_type_description(T), "*".
pce_type_description(...(T)) -->
    pce_type_description(T), " ...".

word_list((A,B)) -->
    !,
    pce_type_description(A), ",", word_list(B).
word_list(A) -->
    pce_type_description(A).


var_type(Type := new(Term), PceType, Initial) :-
    !,
    pce_type(Type, PceType),
    Term =.. L,
    Initial =.. [create|L].
var_type(Type := Initial, PceType, Initial) :-
    !,
    pce_type(Type, PceType).
var_type(Type, PceType, @default) :-
    pce_type(Type, PceType).


                 /*******************************
                 *        METHOD SUPPORT        *
                 *******************************/

extract_documentation(Body0, Summary, Body) :-
    ex_documentation(Body0, Summary, Body),
    !.
extract_documentation(Body, @default, Body).

ex_documentation(::(DocText, Body), Summary, Body) :-
    !,
    pce_summary(DocText, Summary).
ex_documentation((::(DocText, A), B), Summary, (A,B)) :-
    !,
    pce_summary(DocText, Summary).
ex_documentation((A0 ; B), Summary, (A;B)) :-
    ex_documentation(A0, Summary, A),
    !.
ex_documentation((A0->B), Summary, (A->B)) :-
    !,
    ex_documentation(A0, Summary, A),
    !.
ex_documentation((A0*->B), Summary, (A*->B)) :-
    !,
    ex_documentation(A0, Summary, A),
    !.

return_type(Term, RType) :-
    functor(Term, _, Arity),
    arg(Arity, Term, Last),
    (   nonvar(Last),
        Last = _:Type
    ->  pce_type(Type, RType)
    ;   RType = @default
    ).

prolog_head(send, MethodId, Head, Selector,
            TypeVector, pce_principal:PlHead) :-
    !,
    Head =.. [Selector, Receiver | Args],
    prolog_send_arguments(Args, Types, PlArgs),
    create_type_vector(Types, TypeVector),
    CallArgs =.. [Selector | PlArgs],
    PlHead =.. [send_implementation, MethodId, CallArgs, Receiver].
prolog_head(get, MethodId, Head, Selector,
            TypeVector, pce_principal:PlHead) :-
    !,
    Head =.. [Selector, Receiver | Args],
    prolog_get_arguments(Args, Types, PlArgs, Rval),
    create_type_vector(Types, TypeVector),
    CallArgs =.. [Selector | PlArgs],
    PlHead =.. [get_implementation, MethodId, CallArgs, Receiver, Rval].

create_type_vector([],      @default) :- !.
create_type_vector(List,    VectorTerm) :-
    VectorTerm =.. [vector|List].

prolog_send_arguments([], [], []) :- !.
prolog_send_arguments([ArgAndType|RA], [T|RT], [Arg|TA]) :-
    !,
    head_arg(ArgAndType, Arg, Type),
    pce_type(Type, T),
    prolog_send_arguments(RA, RT, TA).

prolog_get_arguments([Return], [], [], ReturnVar) :-
    !,
    (   var(Return)
    ->  ReturnVar = Return
    ;   Return = ReturnVar:_Type
    ).
prolog_get_arguments([ArgAndType|RA], [T|RT], [Arg|TA], ReturnVar) :-
    !,
    head_arg(ArgAndType, Arg, Type),
    pce_type(Type, T),
    prolog_get_arguments(RA, RT, TA, ReturnVar).


head_arg(Var, Var, any) :-
    var(Var),
    !.
head_arg(Arg:Type, Arg, Type).
head_arg(Arg:Name=Type, Arg, Name=Type).


                 /*******************************
                 *        PUBLIC METHODS        *
                 *******************************/

%!  pce_compiling(-ClassName)
%   External function to get the current classname

pce_compiling(ClassName, Path) :-
    compiling(X, Y),
    !,
    X = ClassName,
    Y = Path.

pce_compiling(ClassName) :-
    compiling(X, _),
    !,
    X = ClassName.

pce_compiling :-
    compiling(_, _),
    !.


                 /*******************************
                 *            CLEANUP           *
                 *******************************/

%       cleanup
%
%       Cleanup the compilation data. We should  probably give a warning
%       when not under xref and there is data left.

cleanup :-
    source_location(Path, _),
    forall(retract(compiling(Class, Path)),
           retractall(attribute(Class, _, _))).


                 /*******************************
                 *            CHECKS            *
                 *******************************/

%       If we are expanding on behalf of cross-referencing tool, never
%       send messages anywhere!

pce_ifhostproperty(qpc,
(realised_class(_ClassName) :- fail),
(realised_class(ClassName) :-
        \+ current_prolog_flag(xref, true),
        get(@classes, member, ClassName, Class),
        get(Class, realised, @on))).


                /********************************
                *           UTILITIES           *
                ********************************/

term_member(El, Term) :-
    El == Term.
term_member(El, Term) :-
    functor(Term, _, Arity),
    term_member(Arity, El, Term).

term_member(0, _, _) :-
    !,
    fail.
term_member(N, El, Term) :-
    arg(N, Term, Sub),
    term_member(El, Sub).
term_member(N, El, Term) :-
    NN is N - 1,
    term_member(NN, El, Term).

%!  feedback(+Term)
%   Only print if verbose is asserted (basically debugging).

feedback(Term) :-
    (   verbose
    ->  pce_info(Term)
    ;   true
    ).


                /********************************
                *         TERM EXPANSION        *
                ********************************/

:- multifile
    system:term_expansion/2.
:- dynamic
    system:term_expansion/2.

system:term_expansion(A, B) :-
    pce_term_expansion(A, B).

:- pop_compile_operators.
