1/* Part of XPCE --- The SWI-Prolog GUI toolkit 2 3 Author: Jan Wielemaker and Anjo Anjewierden 4 E-mail: jan@swi.psy.uva.nl 5 WWW: http://www.swi.psy.uva.nl/projects/xpce/ 6 Copyright (c) 2000-2011, University of Amsterdam 7 All rights reserved. 8 9 Redistribution and use in source and binary forms, with or without 10 modification, are permitted provided that the following conditions 11 are met: 12 13 1. Redistributions of source code must retain the above copyright 14 notice, this list of conditions and the following disclaimer. 15 16 2. Redistributions in binary form must reproduce the above copyright 17 notice, this list of conditions and the following disclaimer in 18 the documentation and/or other materials provided with the 19 distribution. 20 21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 POSSIBILITY OF SUCH DAMAGE. 33*/ 34 35:- module(pce_html_refman, 36 [ html_description/2, % +Object, -HTMLString 37 atom_to_method/2, % +Atom, -Behaviour 38 collect_behaviour/2, % +Class, -Behaviour 39 group_objects/2, % +Behaviour, -Groups 40 cluster_behaviour/2, % +Chain, -NestedChain 41 group_summary/2 % +Group, -Summary 42 ]). 43:- use_module(library(pce)). 44:- use_module(library(pce_manual)). 45 46:- dynamic 47 drain/1, % the output object (editor) 48 regex/2, % cache for created regular expr. 49 fetched_description/2, % cache for computed descriptions 50 no_inherit_description/3. % Forbit inheritance of description 51 52% atom_to_method(+Spec, -Method) 53% 54% Find XPCE object holding documentation from a textual specification. 55 56atom_to_method(String, Object) :- 57 ( new(Re, regex('([A-Z]?[a-z_]*)\\s*(<?->?)([a-z_]+)(:.*)?$')), 58 send(Re, match, String) 59 -> get(Re, register_value, String, 1, name, Class0), 60 get(Re, register_value, String, 2, name, What0), 61 get(Re, register_value, String, 3, name, Selector), 62 get(Class0, downcase, Class), 63 ( What0 == '<->' 64 -> member(What, ['->', '<-']) 65 ; What = What0 66 ), 67 Term =.. [What, Class, Selector] 68 ; new(Re, regex('@(.+)$')), 69 send(Re, match, String) 70 -> get(Re, register_value, String, 1, name, Reference), 71 Term = @Reference 72 ; Term = String 73 ), 74 pce_manual:method(Term, Object). 75 76 77 78:- pce_global(@documented, new(chain)). % Chain with documented objects 79 80excluded(Obj, InheritedFrom, _Description) :- 81 no_inherit_description(Type, FromClass, Selector), 82 send(Obj, instance_of, Type), 83 get(Obj, name, Selector), 84 send(InheritedFrom?context, is_a, FromClass). 85 86fetch_description(@Obj, Description) :- 87 fetched_description(Obj, Description), 88 !. 89fetch_description(Obj, Description) :- 90 get(Obj, '_class_name', var), 91 !, 92 get(@manual, self, _), % force creation 93 Obj = @Ref, 94 new(Global, man_global(Ref)), 95 fetch_description(Global, Description), 96 assert(fetched_description(Ref, Description)). 97fetch_description(Obj, Description) :- 98 get(@manual, self, _), % force creation 99 ( get(Obj, attribute, man_description, S0) 100 ; get(Obj, man_attribute, description, S0) 101 ; get(Obj, man_inherited_attribute, description, tuple(From, S0)), 102 \+ excluded(Obj, From, S0) 103 ; send(Obj, has_get_method, summary), 104 get(Obj, summary, S0) 105 ; new(S0, string), 106 send(S0, lock_object, @on) 107 ), 108 S0 \== @nil, 109 !, 110 Obj = @Ref, 111 assert(fetched_description(Ref, S0)), 112 Description = S0. 113 114 115:- pce_extend_class(object). 116 117fetch_description(Obj, Description) :<- 118 "Cached description slot using manual rules":: 119 fetch_description(Obj, Description). 120 121:- pce_end_class. 122 123html_description(Obj, S1) :- 124 fetch_description(Obj, S0), 125 get(S0, copy, S1), 126 desc_to_html(S1, Obj). 127 128% to_regex(+Pattern, -Regex) 129% 130% Convert pattern to regex, maintaining a store of regex objects 131% to avoid unnecessary recompilation. We cannot blindly reuse 132% the regex as they are used recursively. 133 134to_regex(Pattern, Regex) :- 135 retract(regex(Pattern, Regex)), 136 !. 137to_regex(Pattern, Regex) :- 138 new(Regex, regex(Pattern)), 139 send(Regex, lock_object, @on), 140 send(Regex, compile, @on). 141 142done_regex(Pattern, Regex) :- 143 assert(regex(Pattern, Regex)). 144 145substitute(_, []) :- !. 146substitute(S, [Search, Replace | Rest]) :- 147 to_regex(Search, Re), 148 ( Replace = call(Head) 149 -> Head =.. [Pred|Args], 150 append(Args, [@arg1, @arg2], AllArgs), 151 Msg =.. [message, @prolog, Pred | AllArgs], 152 send(Re, for_all, S, Msg) 153 ; send(Re, for_all, S, 154 message(@arg1, replace, @arg2, Replace)) 155 ), 156 done_regex(Search, Re), 157 substitute(S, Rest). 158 159 160desc_to_html(S, Obj) :- 161 send(S, ensure_nl), 162 html_escape(S), 163 substitute(S, ['\n\\s+\n', '\n\n']), % cannonise 164 html_lists(S), 165 substitute(S, 166 [ % HEADING 167 '\n\n\\s*([A-Z ?!._-]+)\\s*\n\n', 168 call(header), % uses \1 169 % ** SubHeader 170 '\n\n\\*\\*+\\s+(.*)\n\n', 171 '\n\n<h4>\\1</h4>\n\n', 172 % *bold* 173 '\\*([^ ]+)\\*', 174 '<b>\\1</b>' 175 ]), 176 substitute(S, ['\n\n+', '\n\n<p>\n']), % paragraphs 177 hyperlinks(S, Obj), 178 send(S, strip). 179 180 181html_lists(S) :- 182 substitute(S, 183 [ % 1) 184 % 2) 185 '\n\n+(\t\\d+\\).*(\n\t.*|\n *)*)', 186 call(enumerate), 187 % aap noot 188 % zus jet 189 '\n\n((\n*\t[^\t\n]+\t.*\n)+)', 190 call(table), 191 % * header 192 % text 193 '\n\n+(\t\\*.*(\n\t.*|\n *)*)', 194 call(itemize), 195 % # text 196 % more text 197 '\n\n+(\t#.*(\n\t.*|\n *)*)', 198 call(description), 199 % Indented by tabs 200% '\n\n+\\(\\(\n*\t.*\\)+\\)', % fails on regex 0.12 201 '\n+((\n+\t.*)+)', 202 call(example) 203 ]). 204 205 206example(Re, String) :- 207 get(Re, register_value, String, 1, S2), 208 substitute(S2, ['^\t(.*)', '\\1']), 209 send(S2, untabify, 4), 210 send(S2, prepend, string('\n<pre>')), 211 send(S2, append, string('\n</pre>\n')), 212 send(Re, register_value, String, S2). 213 214 215list(description, Re, String) :- 216 get(Re, register_value, String, 1, L1), 217 get(Re, register_value, String, 2, RestLines), 218 substitute(RestLines, ['\n\t', '\n']), 219 send(RestLines, strip, trailing), 220 send(RestLines, ensure_nl), 221 html_lists(RestLines), % sub-lists 222 send(RestLines, strip), 223 send(RestLines, ensure_nl), 224 send(RestLines, prepend, string('<dt> <br>%s<dd>\n', L1)), 225 send(Re, register_value, String, RestLines). 226list(itemize, Re, String) :- 227 get(Re, register_value, String, 1, L1), 228 get(Re, register_value, String, 2, RestLines), 229 new(S0, string('\n%s%s', L1, RestLines)), 230 substitute(S0, ['\n\t', '\n']), 231 send(S0, strip, trailing), 232 send(S0, ensure_nl), 233 html_lists(S0), % sub-lists 234 send(S0, strip), 235 send(S0, ensure_nl), 236 send(S0, prepend, string('<li>\n')), 237 send(Re, register_value, String, S0). 238 239 240itemize(Re, String) :- 241 get(Re, register_value, String, 1, S2), 242 substitute(S2, 243 [ '\n*\t\\*\\s*(.*)((\n\t[^*].*|\n *)*)', 244 call(list(itemize)) 245 ]), 246 send(S2, prepend, string('\n<p><ul>\n')), 247 send(S2, ensure_nl), 248 send(S2, append, string('</ul><p>\n')), 249 send(Re, register_value, String, S2). 250 251 252description(Re, String) :- 253 get(Re, register_value, String, 1, S2), 254 substitute(S2, 255 [ '\n*\t#\\s*(.*)((\n\t[^#].*|\n *)*)', 256 call(list(description)) 257 ]), 258 send(S2, ensure_nl), 259 send(S2, prepend, string('\n<dl>\n')), 260 send(S2, append, string('</dl>\n')), 261 send(Re, register_value, String, S2). 262 263 264enumerate(Re, String) :- 265 get(Re, register_value, String, 1, S2), 266 substitute(S2, 267 [ '\n*\t\\d+\\)\\s*(.*)((\n\t[^0-9].*|\n *)*)', 268 call(list(itemize)) 269 ]), 270 send(S2, ensure_nl), 271 send(S2, prepend, string('\n<ol>\n')), 272 send(S2, append, string('</ol>\n')), 273 send(Re, register_value, String, S2). 274 275 276table(Re, String) :- 277 get(Re, register_value, String, 1, S2), 278 substitute(S2, 279 [ '\n*\t([^\t]+)\t+(.*)\n', 280 '<tr><td>\\1<td>\\2</tr>\n' 281 ]), 282 send(S2, prepend, string('\n<p><table align=center border=1 width=50%>\n')), 283 send(S2, append, string('</table>\n')), 284 send(Re, register_value, String, S2). 285 286 287header(Re, String) :- 288 get(Re, register_value, String, 1, ALLCAPITALS), 289 get(ALLCAPITALS, capitalise, Capitals), 290 send(Re, register_value, String, 291 string('<h4>%s</h4>', Capitals), 1). 292 293 294 /******************************* 295 * HYPERLINKS * 296 *******************************/ 297 298% hyperlinks(+String, +Object) 299% 300% Use the typographical conventions in the XPCE manual description 301% to automatically create hyperlinks. 302 303hyperlinks(S, Obj) :- 304 substitute(S, 305 [ '`([^`\']+)\'', 306 call(make_link), 307 '->([a-z_]+)', 308 call(make_sendmethod_link(Obj)), 309 '<-([a-z_]+)', 310 call(make_getmethod_link(Obj)), 311 '(@[a-z_]+)', 312 call(make_link), 313 '\\y[Cc]lass\\s+([a-z_]+)', 314 call(make_link), 315 '([a-z_]+)\\s+object\\y', 316 call(make_link) 317 ]). 318 319make_link(Re, String) :- 320 get(Re, register_value, String, 1, Spec), 321 html_unescape(Spec), 322 get(Spec, value, Atom), 323 atom_to_method(Atom, _), 324 !, 325 www_form_encode(Atom, Encoded), 326 send(Re, register_value, String, 327 string('<a href="/man?for=%s">%s</a>', Encoded, Spec), 1). 328make_link(_, _). 329 330make_sendmethod_link(Obj, Re, String) :- 331 get(Re, register_value, String, 1, name, Method), 332 context_class(Obj, Class), 333 get(string('%s->%s', Class, Method), value, Atom), 334 atom_to_method(Atom, _), 335 !, 336 www_form_encode(Atom, Encoded), 337 get(Re, register_value, String, 0, In), 338 send(Re, register_value, String, 339 string('<a href="/man?for=%s">%s</a>', Encoded, In)). 340make_sendmethod_link(_,_,_). 341 342make_getmethod_link(Obj, Re, String) :- 343 get(Re, register_value, String, 1, name, Method), 344 context_class(Obj, Class), 345 get(string('%s<-%s', Class, Method), value, Atom), 346 atom_to_method(Atom, _), 347 !, 348 www_form_encode(Atom, Encoded), 349 get(Re, register_value, String, 0, In), 350 send(Re, register_value, String, 351 string('<a href="/man?for=%s">%s</a>', Encoded, In)). 352make_getmethod_link(_,_,_). 353 354 355context_class(Class, Name) :- 356 send(Class, instance_of, class), 357 !, 358 get(Class, name, Name). 359context_class(Obj, Name) :- 360 send(Obj, has_get_method, context), 361 get(Obj, context, Class), 362 send(Class, instance_of, class), 363 !, 364 get(Class, name, Name). 365 366 367 /******************************* 368 * ESCAPING * 369 *******************************/ 370 371html_escape(S) :- 372 substitute(S, [ '&', '&', 373 '<', '<', 374 '>', '>' 375 ]). 376 377html_unescape(S) :- 378 substitute(S, [ '&', '&', 379 '<', '<', 380 '>', '>' 381 ]). 382 383 384 /******************************* 385 * BEHAVIOUR * 386 *******************************/ 387 388collect_behaviour(Class, Behaviour) :- 389 new(Behaviour, chain), 390 391 new(Merge, message(Behaviour, append, @arg1)), 392 393 send(Class?get_methods, for_all, Merge), 394 send(Class?send_methods, for_all, Merge), 395 send(Class?instance_variables, for_all, 396 if(@arg1?context == Class, 397 message(Behaviour, append, @arg1))). 398 399 400group_objects(Chain, Groups) :- 401 new(Groups, sheet), 402 Group = when(@arg1?group, @arg1?group, miscellaneous), 403 send(Chain, for_all, 404 if(message(Groups, is_attribute, Group), 405 message(?(Groups, value, Group), append, @arg1), 406 message(Groups, value, Group, 407 ?(@pce, instance, chain, @arg1)))), 408 409 SortByName = ?(@arg1?name, compare, @arg2?name), 410 411 order_groups(Groups), 412 413 send(Groups?members, for_all, 414 message(@arg1?value, sort, 415 quote_function(SortByName))). 416 417order_groups(Sheet) :- 418 get(@manual, module, groups, @on, GroupModule), 419 get(GroupModule, id_table, Table), 420 get(Sheet, members, Chain), 421 new(Unordered, chain), 422 send(Chain, for_all, 423 if(not(?(Table, member, @arg1?name)), 424 and(message(Unordered, append, @arg1), 425 message(Chain, delete, @arg1)))), 426 send(Chain, sort, 427 ?(?(Table, member, @arg1?name)?index, compare, 428 ?(Table, member, @arg2?name)?index)), 429 send(Chain, merge, Unordered). 430 431 432cluster_behaviour(Chain, Combined) :- 433 new(Combined, chain), 434 send(Chain, for_all, 435 and(assign(new(B, var), @arg1), 436 or(and(assign(new(Ch, var), 437 ?(Combined, find, 438 message(@arg1?head?fetch_description, equal, 439 B?fetch_description))), 440 message(Ch, append, B)), 441 message(Combined, append, 442 ?(@pce, instance, chain, B))))), 443 send(Combined, for_all, message(@prolog, sort_cluster, @arg1)). 444 445 446sort_cluster(Chain) :- 447 send(Chain, sort, ?(@prolog, compare_cluster_elements, 448 @arg1?class_name, @arg2?class_name)). 449 450compare_cluster_elements(X, X, equal). 451compare_cluster_elements(delegate_variable, _, smaller). 452compare_cluster_elements(variable, _, smaller). 453compare_cluster_elements(get_method, _, smaller). 454compare_cluster_elements(send_method, _, larger). 455compare_cluster_elements(X, _, _) :- 456 format('[WARNING: compare_cluster_elements/3: Illegal first element ~w]~n', X), 457 fail. 458 459group_summary(Group, Summary) :- 460 get(@manual, module, groups, @on, Module), 461 get(Module?id_table, member, Group, GroupCard), 462 get(GroupCard, summary, Summary), 463 Summary \== @nil. 464 465 466 /******************************* 467 * HELP X-REF * 468 *******************************/ 469 470:- dynamic 471 prolog:called_by/2. 472:- multifile 473 prolog:called_by/2. 474 475prolog:called_by(substitute(_, []), []) :- !. 476prolog:called_by(substitute(S, [_,call(Head)|Rest]), [H|T]) :- 477 catch(Head =.. L, _, fail), 478 !, 479 append(L, [_,_], L2), 480 H =.. L2, 481 prolog:called_by(substitute(S, Rest), T). 482prolog:called_by(substitute(S, [_,_|Rest]), Called) :- 483 prolog:called_by(substitute(S, Rest), Called). 484 485 486 487 488