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)  1985-2002, 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(man_util,
   36        [ has_attribute/2                         % +Obj x +Name
   37        , has_relation/2                          % +Obj x +Name
   38        , has_attribute_value/2                   % +Obj x +Name
   39        , has_relation_value/2                    % +Obj x +Name
   40        , man_attribute/1
   41        , man_relation/1
   42        , apropos_class/6
   43        , class_of/2
   44        , ifmaintainer/1
   45        , group_objects/2
   46        , indent/2
   47        , man_classification/2
   48        , super_or_delegate_class/2     % +Class, -SuperOrDelegate
   49        , class_of_type/2               % +Type, -Class
   50        ]).   51
   52:- meta_predicate
   53    ifmaintainer(:).   54
   55:- use_module(library(pce)).   56:- require([ chain_list/2
   57           , forall/2
   58           , get_chain/3
   59           , member/2
   60           ]).   61
   62
   63                 /*******************************
   64                 *       CLASS EXTENSIONS       *
   65                 *******************************/
   66
   67:- pce_extend_class(object).
   68
   69:- pce_global(@man_description_cache,   new(hash_table)).
   70:- pce_global(@man_source_cache,        new(hash_table)).
   71:- pce_global(@man_tab,                 new(string('\t'))).
   72:- pce_global(@man_nl,                  new(string('\n'))).
   73:- pce_global(@man_indent,              new(string('\n\t'))).
   74:- pce_global(@man_nl_regex,            new(regex(string('\n')))).
   75:- pce_global(@man_indent_message,
   76              new(message(@arg1, replace, @arg2, @man_indent))).
   77
   78man_header(Object, Header) :<-
   79    get(Object, man_name, Header).
   80
   81group(Object, Group:name) :<-
   82    "Classes are of the group class"::
   83    get(Object, class_name, Group).
   84
   85indent(T, S) :-
   86    new(S, string('\t%s', T)),
   87    send(@man_nl_regex, for_all, S, @man_indent_message).
   88
   89
   90man_description(Obj, Descr:char_array) :<-
   91    (   get(@man_description_cache, member, Obj, Descr)
   92    ->  true
   93    ;   (   get(Obj, man_attribute, description, D0)
   94        ;   get(Obj, man_inherited_attribute, description,
   95                tuple(From, D0))
   96        ;   get(Obj, summary, D0)
   97        ;   D0 = '(not documented)'
   98        ),
   99        D0 \== @nil
  100    ->  indent(D0, Descr),
  101        send(@man_description_cache, append, Obj, Descr),
  102        (   nonvar(From)
  103        ->  send(@man_source_cache, append, Obj, From)
  104        ;   true
  105        )
  106    ).
  107
  108
  109man_description_source(Obj, Source:object) :<-
  110    "Object that provided the description"::
  111    (   get(@man_source_cache, member, Obj, Source)
  112    ->  true
  113    ;   Source = Obj
  114    ).
  115
  116:- pce_end_class.
  117
  118
  119                 /*******************************
  120                 *      UTILITY PREDICATES      *
  121                 *******************************/
  122
  123%       man_attribute(?Attribute).
  124%       Is true if Attribute is the name of a manual card attribute
  125
  126man_attribute(description).
  127man_attribute(diagnostics).
  128man_attribute(defaults).
  129man_attribute(user_interface).
  130man_attribute(code).
  131man_attribute(bugs).
  132
  133%       man_relation(?Relation)
  134%       Is true if Relation is the name of a manual card relation
  135
  136man_relation(see_also).
  137
  138%       has_attribute(+Object, +Selector)
  139%       Is true if Object has an attribute named Selector.
  140
  141has_attribute(Obj, Selector) :-
  142    man_attribute(Selector),
  143    (   get(Obj?class, instance_variable, Selector, _Var1)
  144    ;   send(Obj, has_get_method, man_card_class),
  145        get(Obj?man_card_class, instance_variable, Selector, _Var2)
  146    ),
  147    !.
  148
  149%       has_relation(+Object, +Selector)
  150%       Is true if Object has a relation named Selector.
  151
  152has_relation(Obj, Selector) :-
  153    man_relation(Selector),
  154    (   get(Obj?class, instance_variable, Selector, _Var1)
  155    ;   send(Obj, has_get_method, man_card_class),
  156        get(Obj?man_card_class, instance_variable, Selector, _Var2)
  157    ),
  158    !.
  159
  160%       has_attribute_value(+Obj, +Selector)
  161
  162has_attribute_value(Obj, Selector) :-
  163    get(Obj, man_attribute, Selector, Val), Val \== @nil.
  164
  165%       has_relation_value(+Obj, +Selector)
  166
  167has_relation_value(Obj, Selector) :-
  168    get(Obj, man_related, Selector, Val), Val \== @nil,
  169    \+ send(Val, empty).
  170
  171
  172                 /*******************************
  173                 *    INHERITANCE/DELEGATION    *
  174                 *******************************/
  175
  176%       super_or_delegate_class(+Class, -Super)
  177%
  178%       Successively unifies `Super' with class objects this `Class' inherits
  179%       from or delegates too.
  180
  181:- dynamic done_class/1.  182
  183super_or_delegate_class(Class, Super) :-
  184    retractall(done_class(_)),
  185    super_or_delegate_class_(Class, Super).
  186super_or_delegate_class(_, _) :-
  187    retractall(done_class(_)),
  188    fail.
  189
  190super_or_delegate_class_(Class, _) :-
  191    done_class(Class),
  192    !,
  193    fail.
  194super_or_delegate_class_(Class, Class) :-
  195    asserta(done_class(Class)).
  196super_or_delegate_class_(Class, Super) :-
  197    get(Class, super_class, ThisSuper),
  198    ThisSuper \== @nil,
  199    super_or_delegate_class_(ThisSuper, Super).
  200super_or_delegate_class_(Class, Delegate) :-
  201    get_chain(Class, delegate, List),
  202    member(Var, List),
  203    get(Var, type, Type),
  204    class_of_type(Type, DelClass),
  205    \+ done_class(DelClass),
  206    super_or_delegate_class_(DelClass, Delegate).
  207
  208class_of_type(Type, Class) :-
  209    get(Type, kind, class),
  210    get(Type, context, Class).
  211class_of_type(Type, Class) :-
  212    get_chain(Type, supers, Supers),
  213    member(Super, Supers),
  214    class_of_type(Super, Class).
  215
  216
  217                /********************************
  218                *           FIND OBJECTS        *
  219                ********************************/
  220
  221%       apropos_class(+Class, +Inherit, +Types, +Fields, +Keyword, -Matches)
  222
  223apropos_class(Class, Inherit, Types, Fields, Keyword, Match) :-
  224    !,
  225    (   Keyword == '' ; Keyword = '.*'
  226    ->  Regex = @nil
  227    ;   new(Regex, regex(Keyword)),
  228        send(Regex, ignore_case, @off),
  229        send(Regex, compile, @on)
  230    ),
  231    new(Flds, chain),
  232    forall(member(Field, Fields),
  233           (   map_field(Field, Selector),
  234               send(Flds, append, Selector)
  235           )),
  236    new(Match0, chain),
  237    apropos_class_(Inherit, Class, Types, Flds, Regex, Match0),
  238    get(Match0, find_all,
  239        message(@manual, in_scope, @arg1), Match),
  240    send(Match0, done),
  241    send(Flds, done).
  242
  243map_field(description, man_description) :- !.
  244map_field(X, X).
  245
  246apropos_class_(own, Class, Types, Flds, Regex, Match) :-
  247    !,
  248    forall(member(Type, Types),
  249           apropos_type_attribute(Type, Class, Flds, Regex, Match)).
  250apropos_class_(sub, Class, Types, Flds, Regex, Match) :-
  251    !,
  252    apropos_class_(own, Class, Types, Flds, Regex, Match),
  253    (   get_chain(Class, sub_classes, Subs)
  254    ->  forall(member(Sub, Subs),
  255               apropos_class_(sub, Sub, Types, Flds, Regex, Match))
  256    ;   true
  257    ).
  258apropos_class_(super, Class, Types, Flds, Regex, Match) :-
  259    !,
  260    apropos_class_(@object_class, Class, Types, Flds, Regex, Match).
  261
  262apropos_class_(Scope, Class, Types, Flds, Regex, Match) :-
  263    forall((super_or_delegate_class(Class, Super),
  264            send(Scope, member, Super)),
  265           apropos_class_(own, Super, Types, Flds, Regex, Match)),
  266    cleanup(Match).
  267
  268cleanup(Match) :-
  269    new(Done, chain_table),
  270    new(Tmp, chain),
  271
  272    new(AppendMatch, message(Tmp, append, @arg1)),
  273    new(Selector, @arg1?name),
  274    new(DoneSelector, ?(Done, member, Selector)),
  275
  276    send(Match, for_all,
  277         if(message(@arg1, instance_of, send_method),
  278            if(not(message(DoneSelector, member, send)),
  279               and(AppendMatch,
  280                   message(Done, append, Selector, send))),
  281            if(message(@arg1, instance_of, get_method),
  282               if(not(message(DoneSelector, member, get)),
  283               and(AppendMatch,
  284                   message(Done, append, Selector, get))),
  285               AppendMatch)),
  286         @off),
  287    send(Match, clear),
  288    send(Match, merge, Tmp),
  289    send(Done, done).
  290
  291apropos_type_attribute(self, Class, Fields, Keyword, Match) :-
  292    !,
  293    (   match_apropos(Class, Fields, Keyword)
  294    ->  send(Match, append, Class)
  295    ;   true
  296    ).
  297apropos_type_attribute(variable, Class, Fields, Keyword, Matches) :-
  298    !,
  299    get(Class, instance_variables, Vars),
  300    new(Locals, chain),
  301    send(Vars, for_all, if(@arg1?context == Class,
  302                           message(Locals, append, @arg1))),
  303    chain_list(Locals, List),
  304    send(Locals, done),
  305    (   member(Object, List),
  306        match_apropos(Object, Fields, Keyword),
  307        send(Matches, append, Object),
  308        fail
  309    ;   true
  310    ).
  311apropos_type_attribute(Att, Class, Flds, Regex, Match) :-
  312    type_to_class_attribute(Att, PT),
  313    apropos_class_attribute(Class, PT, Flds, Regex, Match).
  314
  315type_to_class_attribute(send_method, send_methods) :- !.
  316type_to_class_attribute(get_method,  get_methods) :- !.
  317type_to_class_attribute(class_var,   class_variables) :- !.
  318type_to_class_attribute(sub_class,   sub_classes).
  319
  320%       apropos_class_attribute(+Class, +Att, +Flds, +Kwd, +Match)
  321%       Append matching objects of Class to Match
  322
  323apropos_class_attribute(Class, Att, _Fields, @nil, Matches) :-
  324    !,
  325    get(Class, Att, Chain),
  326    send(Matches, merge, Chain).
  327apropos_class_attribute(Class, Att, Fields, Regex, Matches) :-
  328    get(Class, Att, Chain),
  329    !,
  330    pce_catch_error(argument_type,
  331                    send(Chain, for_all,
  332                         and(assign(new(Candidate, var), @arg1),
  333                             if(?(Fields, find,
  334                                  message(Regex, search,
  335                                          Candidate ? @arg1)),
  336                                message(Matches, append, Candidate))))).
  337apropos_class_attribute(_, _, _, _, _).
  338
  339%       match_apropos(+Object, +Fields, +Regex)
  340%       Test if Object contains Regex in one of the specified fields
  341
  342match_apropos(_Object, _Fields, @nil) :- !.
  343match_apropos(Object, Fields, Regex) :-
  344    pce_catch_error(argument_type,
  345                    get(Fields, find,
  346                        message(Regex, search, Object ? @arg1), _)).
  347
  348
  349%       class_of(+Object, -ClassName)
  350%       When Object is related to a class, return the classname.  Otherwise
  351%       return the atom ''.
  352
  353class_of(Class, ClassName) :-
  354    send(Class, instance_of, class),
  355    !,
  356    get(Class, name, ClassName).
  357class_of(Obj, ClassName) :-
  358    send(Obj, instance_of, behaviour),
  359    get(Obj, context, Context),
  360    send(Context, instance_of, class),
  361    !,
  362    get(Context, name, ClassName).
  363class_of(Obj, ClassName) :-
  364    send(Obj, instance_of, class_variable),
  365    get(Obj, context, Context),
  366    !,
  367    get(Context, name, ClassName).
  368class_of(_, '').
  369
  370
  371                 /*******************************
  372                 *           GROUPING           *
  373                 *******************************/
  374
  375%       Translate a chain of objects into a sheet of groups
  376
  377group_objects(Chain, Groups) :-
  378    new(Groups, sheet),
  379    Group = when(@arg1?group, @arg1?group, miscellaneous),
  380    send(Chain, for_all,
  381         if(message(Groups, is_attribute, Group),
  382            message(?(Groups, value, Group), append, @arg1),
  383            message(Groups, value, Group,
  384                    ?(@pce, instance, chain, @arg1)))),
  385
  386    SortByName = ?(@arg1?name, compare, @arg2?name),
  387
  388    order_groups(Groups),           % TBD
  389%       send(Groups?members, sort, ?(@arg1?name, compare, @arg2?name)),
  390
  391    send(Groups?members, for_all,
  392         message(@arg1?value, sort,
  393                 quote_function(SortByName))).
  394
  395%       order_groups(Groups)
  396%       Order chain of groups
  397
  398order_groups(Sheet) :-
  399    get(@manual, module, groups, @on, GroupModule),
  400    get(GroupModule, id_table, Table),
  401    get(Sheet, members, Chain),
  402    new(Unordered, chain),
  403    send(Chain, for_all,
  404         if(not(?(Table, member, @arg1?name)),
  405            and(message(Unordered, append, @arg1),
  406                message(Chain, delete, @arg1)))),
  407    send(Chain, sort,
  408         ?(?(Table, member, @arg1?name)?index, compare,
  409           ?(Table, member, @arg2?name)?index)),
  410    send(Chain, merge, Unordered).
  411
  412
  413                /********************************
  414                *            MAINTAINER         *
  415                ********************************/
  416
  417ifmaintainer(Goal) :-
  418    get(@manual, maintainer, @on),
  419    !,
  420    Goal.
  421ifmaintainer(_).
  422
  423
  424                 /*******************************
  425                 *        CLASSIFICATION        *
  426                 *******************************/
  427
  428man_classification(basic,                       'Basic').
  429man_classification(advanced,                    'Advanced').
  430man_classification(obscure,                     'Rare').
  431man_classification(internal,                    'Internal').
  432man_classification(basic_programming,           'Basic OO').
  433man_classification(advanced_programming,        'Advanced OO').
  434man_classification(user,                        'Application')