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/packages/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 ]).
63 /******************************* 64 * INTERACTION SUPPORT * 65 *******************************/
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 *******************************/
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).
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).
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.
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 *******************************/
`What' may be wrapped in self(What) or root(What). Using
self(What) returns only those classes that have a non-inherited
implementation of the method, while using root(What) returns
only those classes for which there is no super-class
implementing the requested method.
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 *******************************/
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).
408type_accepts_function(Type) :-
409 send(type(function), specialised, Type).file(File)library(File)user(File)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)
Reflection support for XPCE
This module defines utilities to simplify reflexion support of XPCE, notably implementing non-deterministic logical relations on top of the deterministic XPCE methods. */