1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
   2
   3    Author:        Jan Wielemaker and Anjo Anjewierden
   4    E-mail:        J.Wielemaker@vu.nl
   5    WWW:           http://www.swi-prolog.org/projects/xpce/
   6    Copyright (c)  1999-2011, University of Amsterdam
   7                              VU University Amsterdam
   8    All rights reserved.
   9
  10    Redistribution and use in source and binary forms, with or without
  11    modification, are permitted provided that the following conditions
  12    are met:
  13
  14    1. Redistributions of source code must retain the above copyright
  15       notice, this list of conditions and the following disclaimer.
  16
  17    2. Redistributions in binary form must reproduce the above copyright
  18       notice, this list of conditions and the following disclaimer in
  19       the documentation and/or other materials provided with the
  20       distribution.
  21
  22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33    POSSIBILITY OF SUCH DAMAGE.
  34*/
  35
  36:- module(pce_meta,
  37          [ pce_to_method/2,            % +Spec, -BehaviourObject
  38            isa_class/2,                % ?SubClassName, ?SuperClassName
  39            current_class/2,            % ?ClassName, ?ClassObject
  40            to_class_name/2,            % +NameOrClass, -ClassName
  41            pce_library_class/4,        % ?Name, ?Super, ?Comment, ?File
  42            implements/2,               % ?Class, ?SendOrGet(?Name)
  43            implements/3,               % idem, -Method
  44            pce_to_pl_type/2,           % +PceType, -PrologType
  45            type_accepts_function/1,    % +Type
  46            classify_class/2            % +Class, -Classification
  47          ]).
  48:- use_module(library(pce)).
  49:- require([ pce_error/1
  50           , chain_list/2
  51           , get_chain/3
  52           , maplist/3
  53           ]).
  54
  55/** <module> Reflection support for XPCE
  56
  57This module defines utilities to  simplify   reflexion  support of XPCE,
  58notably implementing non-deterministic logical relations   on top of the
  59deterministic XPCE methods.
  60*/
  61
  62
  63                 /*******************************
  64                 *      INTERACTION SUPPORT     *
  65                 *******************************/
  66
  67%!  pce_to_method(+Spec, -Object) is semidet.
  68%
  69%   Object is the XPCE object described by Spec.  Spec is one of
  70%
  71%           * send(Receiver, Selector)
  72%           * ->(Receiver, Selector)
  73%           Find a send-method on Receiver
  74%           * get(Receiver, Selector)
  75%           * <-(Receiver, Selector)
  76%           Find a get-method on Receiver
  77%           * Receiver-Selector
  78%           Find an instance variable (slot) on Receiver
  79%           * ClassName
  80%           Find a class from its name
  81
  82pce_to_method(->(Receiver, Selector), Method) :-
  83    !,
  84    (   atom(Receiver)
  85    ->  get(@pce, convert, Receiver, class, Class),
  86        get(Class, send_method, Selector, Method)
  87    ;   object(Receiver)
  88    ->  get(Receiver, send_method, Selector, tuple(_, Method))
  89    ).
  90pce_to_method(<-(Receiver, Selector), Method) :-
  91    !,
  92    (   atom(Receiver)
  93    ->  get(@pce, convert, Receiver, class, Class),
  94        get(Class, get_method, Selector, Method)
  95    ;   object(Receiver)
  96    ->  get(Receiver, get_method, Selector, tuple(_, Method))
  97    ).
  98pce_to_method((Receiver-Selector), Method) :-
  99    !,
 100    (   atom(Receiver)
 101    ->  get(@pce, convert, Receiver, class, Class),
 102        get(Class, instance_variable, Selector, Method)
 103    ;   object(Receiver),
 104        get(Receiver, attribute, Method)
 105    ->  true
 106    ;   object(Receiver),
 107        get(Receiver, class, Class),
 108        get(Class, instance_variable, Selector, Method)
 109    ).
 110pce_to_method(ClassName, Class) :-
 111    atom(ClassName),
 112    get(@pce, convert, ClassName, class, Class),
 113    !.
 114pce_to_method(Method, Method) :-
 115    object(Method),
 116    !.
 117pce_to_method(get(Receiver, Selector), Method) :-
 118    !,
 119    pce_to_method(<-(Receiver, Selector), Method).
 120pce_to_method(send(Receiver, Selector), Method) :-
 121    !,
 122    pce_to_method(->(Receiver, Selector), Method).
 123
 124
 125                 /*******************************
 126                 *           CLASSES            *
 127                 *******************************/
 128
 129%!  isa_class(?Sub, ?Super)
 130%
 131%   Succeeds if Sub is Super or below Super.  Can be used with any
 132%   instantiation.  If class is instantiated the super-chain is
 133%   followed.
 134
 135isa_class(Class, Super) :-
 136    ground(Class),
 137    !,
 138    gen_super(Class, Super).
 139isa_class(Class, Super) :-
 140    current_class(Class, ClassObject),
 141    current_class(Super, SuperObject),
 142    send(ClassObject, is_a, SuperObject).
 143
 144gen_super(Class, Class).
 145gen_super(Class, Super) :-
 146    current_class(Class, ClassObject),
 147    get(ClassObject, super_class, SuperObject),
 148    current_class(Super0, SuperObject),
 149    gen_super(Super0, Super).
 150
 151
 152%!  current_class(?Name, ?Class)
 153%
 154%   Convert between name and class object.  Insufficient instantation
 155%   enumerates the classes.
 156
 157:- dynamic
 158    current_class_cache/2.
 159
 160
 161make_current_class :-
 162    retractall(current_class_cache(_,_)),
 163    send(@classes, for_all,
 164         message(@prolog, assert_class, @arg1, @arg2)),
 165    send(class(class), created_message,
 166         message(@prolog, assert_class, @arg2?name, @arg2)).
 167
 168assert_class(Name, Object) :-
 169    assert(current_class_cache(Name, Object)).
 170
 171:- initialization
 172    make_current_class.
 173
 174current_class(Class, ClassObject) :-
 175    current_class_cache(Class, ClassObject).
 176current_class(Class, ClassObject) :-
 177    pce_prolog_class(Class),
 178    \+ current_class_cache(Class, _),
 179    get(@pce, convert, Class, class, ClassObject).
 180
 181
 182%!  to_class_name(+AtomOrClass, -ClassName)
 183%
 184%   Convert a name or class-object into a class name
 185
 186to_class_name(Name0, Name) :-
 187    atom(Name0),
 188    !,
 189    (   current_class(Name0, _)
 190    ->  Name = Name0
 191    ;   pce_error(no_class(Name0))
 192    ).
 193to_class_name(ClassObj, Name) :-
 194    object(ClassObj),
 195    send(ClassObj, instance_of, class),
 196    !,
 197    get(ClassObj, name, Name).
 198
 199
 200                 /*******************************
 201                 *            LIBRARY           *
 202                 *******************************/
 203
 204:- dynamic
 205    library_index/4,
 206    index_files/1.
 207
 208%!  pce_library_class(?Name, ?Super, ?Comment, ?File)
 209%
 210%   Examine the library index for defined classes.
 211
 212pce_library_class(Name, Super, Comment, library(File)) :-
 213    atom(Name),
 214    !,
 215    (   library_index(Name, Super, Comment, File)
 216    *-> true
 217    ;   update_library_index,
 218        library_index(Name, Super, Comment, File)
 219    ).
 220
 221update_library_index :-
 222    setof(File, index_file(File), Files),
 223    (   index_files(Files)
 224    ->  true
 225    ;   retractall(index_files(_)),
 226        retractall(library_index(_,_,_,_)),
 227        load_index_files(Files),
 228        assert(index_files(Files))
 229    ).
 230
 231
 232index_file(File) :-
 233    absolute_file_name(library('CLASSINDEX.pl'), File,
 234                       [ access(read),
 235                         solutions(all),
 236                         file_errors(fail)
 237                       ]).
 238
 239load_index_files([]).
 240load_index_files([H|T]) :-
 241    load_index_file(H),
 242    load_index_files(T).
 243
 244load_index_file(File) :-
 245    open(File, read, In),
 246    read(In, Term),
 247    call_cleanup(read_index(Term, In), close(In)).
 248
 249read_index(end_of_file, _) :- !.
 250read_index(class(Name, Super, Comment, File), In) :-
 251    assert(library_index(Name, Super, Comment, File)),
 252    read(In, Term),
 253    read_index(Term, In).
 254
 255
 256                 /*******************************
 257                 *            METHODS           *
 258                 *******************************/
 259
 260%!  implements(?Class:atom, ?Method:atom) is nondet.
 261%!  implements(?Class:atom, ?Method:atom, -MethodObj:object) is nondet.
 262%
 263%   True if Class implements the method.  If class is a variable,
 264%   backtracking yields all classes
 265%
 266%   `What'  may  be  wrapped  in  self(What)  or  root(What).  Using
 267%   self(What) returns only those classes  that have a non-inherited
 268%   implementation of the method,  while   using  root(What) returns
 269%   only  those  classes  for   which    there   is  no  super-class
 270%   implementing the requested method.
 271%
 272%   @param Class    Name of XPCE class
 273%   @param Method   One of send(Name) or get(Name)
 274%   @param MethodObj XPCE Object representing the method
 275
 276implements(Class, What) :-
 277    implements(Class, What, _).
 278
 279implements(Class, self(What), Method) :-
 280    implements(Class, What, Method),
 281    get(Method, context, ClassObject),
 282    get(ClassObject, name, Class).
 283implements(Class, root(What), Method) :-
 284    implements(Class, self(What), Method),
 285    (   send(Method, has_get_method, inherited_from)
 286    ->  \+ get(Method, inherited_from, _)
 287    ;   true
 288    ).
 289implements(Class, send(Name), Method) :-
 290    current_class(Class, ClassObject),
 291    (   atom(Name)
 292    ->  get(ClassObject, send_method, Name, Method)
 293    ;   isa_class(Class, Super),
 294        current_class(Super, SuperObject),
 295        (   get_chain(SuperObject, send_methods, Methods)
 296        ;   get_chain(SuperObject, instance_variables, Methods)
 297        ),
 298        member(Method, Methods),
 299        get(Method, name, Name),
 300        get(ClassObject, send_method, Name, Method)         % not overruled
 301    ).
 302implements(Class, get(Name), Method) :-
 303    current_class(Class, ClassObject),
 304    (   atom(Name)
 305    ->  get(ClassObject, get_method, Name, Method)
 306    ;   isa_class(Class, Super),
 307        current_class(Super, SuperObject),
 308        (   get_chain(SuperObject, get_methods, Methods)
 309        ;   get_chain(SuperObject, instance_variables, Methods)
 310        ),
 311        member(Method, Methods),
 312        get(Method, name, Name),
 313        get(ClassObject, get_method, Name, Method)
 314    ).
 315
 316
 317                 /*******************************
 318                 *             TYPES            *
 319                 *******************************/
 320
 321%!  pce_to_pl_type(+PceType, -PrologType)
 322%   Convert an XPCE Type object to our type-checkers type-logic.
 323%
 324
 325pce_to_pl_type(Type, Pl) :-
 326    get(Type, kind, Kind),
 327    pce_to_pl_type(Kind, Type, Pl0),
 328    type_supers(Pl0, Type, Pl).
 329
 330type_supers(Pl0, Type, Pl) :-
 331    get(Type, supers, Supers),
 332    Supers \== @nil,
 333    !,
 334    chain_list(Supers, SuperList),
 335    maplist(pce_to_pl_type, SuperList, PlSupers),
 336    list_to_or([Pl0|PlSupers], Pl).
 337type_supers(Pl, _, Pl).
 338
 339pce_to_pl_type(class, Type, Pl) :-
 340    get(Type, context, Context),
 341    (   atom(Context)
 342    ->  Class = Context
 343    ;   get(Context, name, Class)
 344    ),
 345    class_type(Class, Pl).
 346pce_to_pl_type(class_object, _, and(sub(object), not(sub(function)))).
 347pce_to_pl_type(unchecked,    _, or(sub(object), integer)).
 348pce_to_pl_type(any,          _, and(or(sub(object), integer),
 349                                    not(sub(function)))).
 350pce_to_pl_type(int,          _, integer).
 351pce_to_pl_type(char,         _, integer(0,255)).
 352pce_to_pl_type(int_range,    T, integer(Low, High)) :-
 353    get(T, context, tuple(Low0, High0)),
 354    to_range_boundary(Low0, Low),
 355    to_range_boundary(High0, High).
 356pce_to_pl_type(real_range,   T, float(Low, High)) :-
 357    get(T, context, tuple(Low0, High0)),
 358    to_range_boundary(Low0, Low),
 359    to_range_boundary(High0, High).
 360pce_to_pl_type(event_id,     _, or(integer, atom)).
 361pce_to_pl_type(value,        T, value(V)) :-
 362    get(T, context, V).
 363pce_to_pl_type(name_of,      T, Pl) :-
 364    get_chain(T, context, Atoms),
 365    list_to_value_or(Atoms, Pl).
 366pce_to_pl_type(member,       T, PlType) :-
 367    get(T, context, T2),
 368    pce_to_pl_type(T2, PlType).
 369pce_to_pl_type(value_set,    T, Pl) :-
 370    get_chain(T, context, Elements),
 371    list_to_value_or(Elements, Pl).
 372pce_to_pl_type(compound,     T, PlType) :-
 373    get_chain(T, context, Supers),
 374    maplist(pce_to_pl_type, Supers, PlSupers),
 375    list_to_or(PlSupers, PlType).
 376pce_to_pl_type(alias,        T, PlType) :-
 377    get(T, context, T2),
 378    pce_to_pl_type(T2, PlType).
 379pce_to_pl_type(alien,        _, integer).
 380
 381class_type(name,   atom) :- !.
 382class_type(number, integer) :- !.
 383class_type(real,   float) :- !.
 384class_type(Class,  sub(Class)).
 385
 386to_range_boundary(N, unbound) :-
 387    unbound(N),
 388    !.
 389to_range_boundary(N, N).
 390
 391unbound(@nil).
 392unbound(1073741823).
 393unbound(-1073741824).
 394
 395
 396list_to_or([X], X) :- !.
 397list_to_or([A|B], or(A, C)) :-
 398    list_to_or(B, C).
 399
 400list_to_value_or([X], value(X)) :- !.
 401list_to_value_or([A|B], or(value(A), T)) :-
 402    list_to_value_or(B, T).
 403
 404%!  type_accepts_function(+Type)
 405%
 406%   Succeeds if Type accepts function arguments
 407
 408type_accepts_function(Type) :-
 409    send(type(function), specialised, Type).
 410
 411%!  classify_class(+ClassName, -Classification) is det.
 412%
 413%   Classify an XPCE class.  Defined classes are:
 414%
 415%     * built_in
 416%     * file(File)
 417%     * library(File)
 418%     * user(File)
 419%     * user
 420%     * undefined
 421
 422classify_class(Name, built_in) :-
 423    get(@classes, member, Name, Class),
 424    get(Class, creator, built_in),
 425    !.
 426classify_class(Name, library(File)) :-
 427    pce_library_class(Name, _, _, FileSpec),
 428    FileSpec = library(File),
 429    (   get(@classes, member, Name, Class),
 430        get(Class, source, source_location(File, _Line))
 431    ->  absolute_file_name(FileSpec, File,
 432                           [ access(read)
 433                           ])
 434
 435    ;   true
 436    ),
 437    !.
 438classify_class(Name, user(File)) :-
 439    get(@classes, member, Name, Class),
 440    get(Class, source, source_location(File, _Line)).
 441classify_class(Name, user(File)) :-
 442    pce_prolog_class(Name),
 443    pce_principal:pce_class(Name, _Meta, _Super, _Vars, _Res, Attributes),
 444    memberchk(send(@class, source, source_location(File, _Line)),
 445              Attributes),
 446    !.
 447classify_class(Name, user) :-
 448    get(@classes, member, Name, _),
 449    !.
 450classify_class(_, undefined).