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)  2002-2013, 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_keybinding, []).   37:- use_module(pce_boot(pce_principal)).   38:- use_module(pce_boot(pce_realise)).   39
   40:- multifile
   41    binding/3.   42
   43message_level(silent).
   44%message_level(informational).
   45
   46
   47                 /*******************************
   48                 *      STYLE PREFERENCES       *
   49                 *******************************/

 binding(+ModeName, +TableName, +Modifications)

Specify bindings for alternative key-binding-styles.

Arguments:

ModeName	- Name of the key-binding-style
TableName	- Syntax table to modify
Modifications	- List of Key-Method

   59binding(cua, editor,
   60        [ '\\C-v' = paste,
   61          '\\C-s' = save_buffer
   62        ]).
   63binding(cua, 'emacs$fundamental',
   64        [ '\\C-f' = isearch_forward,
   65          '\\C-o' = open,
   66          '\\C-n' = new,
   67          '\\C-p' = print
   68        ]).
   69binding(apple, editor,
   70        [ '\\es'  = save_buffer,
   71          '\\ez'  = undo
   72        ]).
   73binding(apple, 'emacs$fundamental',
   74        [ '\\ec'  = copy_or_capitalize_word,
   75          '\\ex'  = cut_or_execute_extended_command
   76        ]).
   77binding(apple, emacs_page,
   78        [ '\\ev'  = paste_or_scroll_down
   79        ]).
   80
   81
   82                 /*******************************
   83                 *       CHANGE BINDINGS        *
   84                 *******************************/

 set_keybinding_style(+Id)

Runtime modification of the current key-binding style.

   90set_keybinding_style(Mode) :-
   91    current_style(Mode),
   92    !.
   93set_keybinding_style(emacs) :-
   94    !,
   95    send(@key_bindings, for_all,
   96         message(@arg2, unmodify)),
   97    set_style(emacs).
   98set_keybinding_style(Style) :-
   99    set_keybinding_style(emacs),
  100    (   binding(Style, Table, Modifications),
  101        get(@key_bindings, member, Table, KB),
  102        modify(Modifications, KB),
  103        fail
  104    ;   true
  105    ),
  106    set_style(Style).
  107
  108
  109modify([], _).
  110modify([Mod|T], KB) :-
  111    modify1(Mod, KB),
  112    modify(T, KB).
  113
  114modify1(Key = Command, KB) :-
  115    get(KB?bindings, value, Key, Command),
  116    !.
  117modify1(Key = Command, KB) :-
  118    send(KB, save_default, Key),
  119    send(KB, function, Key, Command),
  120    get(KB, name, Table),
  121    message_level(Level),
  122    print_message(Level, format('~w (~p): ~w --> ~w',
  123                                [Table, KB, Key, Command])).
  124modify1(delete(Key), KB) :-
  125    \+ get(KB?bindings, value, Key, _),
  126    !.
  127modify1(delete(Key), KB) :-
  128    send(KB, save_default, Key),
  129    get(KB, bindings, Bindings),
  130    send(Bindings, delete, Key),
  131    get(KB, name, Table),
  132    message_level(Level),
  133    print_message(Level, format('~w: deleted ~w', [Table, Key])).
  134
  135
  136                 /*******************************
  137                 *        DYNAMIC TABLES        *
  138                 *******************************/
  139
  140:- pce_extend_class(key_binding).
  141
  142class_variable(style, name,
  143               [ 'X'(emacs),
  144                 windows(cua),
  145                 apple(apple)
  146               ],
  147               "Basic binding style (emacs,cua,apple)").

 current_style(-Style) is det

 set_style(+Style) is det

Manipulate the style. The style is stored in the class-variable key_binding.style, so it can be set in the users preferences file.

  156current_style(Style) :-
  157    get(@pce, convert, key_binding, class, Class),
  158    get(Class, class_variable, style, Var),
  159    get(Var, value, Style).
  160
  161set_style(Style) :-
  162    get(@pce, convert, key_binding, class, Class),
  163    get(Class, class_variable, style, Var),
  164    send(Var, value, Style).
  165
  166
  167apply_preferences(KB) :->
  168    "Apply CUA-mode preferences"::
  169    send(KB, apply_cua),
  170    send(KB, bind_resources).       % bind from ~/.xpce/Defaults
  171
  172apply_cua(KB) :->
  173    "Apply our local overrides"::
  174    current_style(Mode),
  175    (   Mode == emacs
  176    ->  true
  177    ;   get(KB, name, Name),
  178        binding(Mode, Name, Modifications)
  179    ->  modify(Modifications, KB)
  180    ;   true
  181    ).
  182
  183save_default(KB, Key:name) :->
  184    "Save default binding for Key"::
  185    (   get(KB, attribute, modified, Undo)
  186    ->  true
  187    ;   send(KB, attribute, modified, new(Undo, sheet))
  188    ),
  189    (   get(Undo, value, Key, _)
  190    ->  true                        % Already saved this one
  191    ;   get(KB, bindings, Bindings),
  192        (   get(Bindings, value, Key, Command)
  193        ->  send(Undo, value, Key, Command)
  194        ;   send(Undo, value, Key, @nil)
  195        )
  196    ).
  197
  198unmodify(KB) :->
  199    "Replay recorded modifications"::
  200    (   get(KB, attribute, modified, Undo)
  201    ->  send(Undo, for_all,
  202             message(KB, unbind, @arg1?name, @arg1?value)),
  203        send(KB, delete_attribute, modified)
  204    ;   true
  205    ).
  206
  207unbind(KB, Key:name, Command:[name|code]*) :->
  208    "Restore saved binding for Key"::
  209    get(KB, name, Table),
  210    message_level(Level),
  211    (   Command == @nil
  212    ->  get(KB, bindings, Sheet),
  213        send(Sheet, delete, Key),
  214        print_message(Level,
  215                      format('~w: deleted ~w', [Table, Key]))
  216    ;   send(KB, function, Key, Command),
  217        print_message(Level,
  218                      format('~w (~p): ~w --> ~w',
  219                             [Table, KB, Key, Command]))
  220    ).
  221
  222:- pce_end_class(key_binding).
  223
  224
  225/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  226Runtime switching is connected to @pce as the operation influences an
  227unknown number of unknown key_binding objects.
  228- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  229
  230:- pce_extend_class(pce).
  231
  232:- pce_group(preferences).
  233
  234key_binding_style(_Pce, Style:name) :->
  235    "Set the key-binding style"::
  236    set_keybinding_style(Style).
  237
  238key_binding_style(_Pce, Style:name) :<-
  239    "Get the key-binding style"::
  240    current_style(Style).
  241
  242key_binding_styles(_Pce, Styles:chain) :<-
  243    "List of supported styles"::
  244    findall(Style, binding(Style, _Class, _Mod), StyleList),
  245    sort([emacs|StyleList], Sorted),
  246    new(Styles, chain),
  247    add_styles(Sorted, Styles).
  248
  249add_styles([], _).
  250add_styles([H|T], Chain) :-
  251    send(Chain, append, H),
  252    add_styles(T, Chain).
  253
  254:- pce_end_class(pce).
  255
  256
  257%       Create the type key_binding_style, a dynamic `name-of' type
  258%       holding the defined key-binding styles.
  259
  260make_key_binding_style_type :-
  261    get(@pce, convert, key_binding_style, type, Type),
  262    send(Type, name_reference, key_binding_style_type),
  263    send(Type, kind, name_of),
  264    get(@pce, key_binding_styles, Styles),
  265    send(Type, slot, context, Styles).
  266
  267:- initialization make_key_binding_style_type.  268
  269
  270                 /*******************************
  271                 *             APPLE            *
  272                 *******************************/
  273
  274:- pce_extend_class(editor).
  275
  276copy_or_capitalize_word(E, Arg:[int]) :->
  277    "Command-c copies; ESC c capitalizes word"::
  278    (   Arg == @default,
  279        send(@event, has_modifier, m)
  280    ->  send(E, copy)
  281    ;   send(E, capitalize_word, Arg)
  282    ).
  283
  284cut_or_execute_extended_command(E, Arg:[int]) :->
  285    "Command-X cut; ESC-x starts extended command"::
  286    (   Arg == @default,
  287        send(@event, has_modifier, m)
  288    ->  send(E, cut)
  289    ;   send(E, noarg_call, execute_extended_command, Arg)
  290    ).
  291
  292
  293paste_or_scroll_down(E, Arg:[int]) :->
  294    "Command-v pasts; ESC v scrolls down"::
  295    (   Arg == @default,
  296        send(@event, has_modifier, m)
  297    ->  send(E, paste)
  298    ;   send(E, scroll_down, Arg)
  299    ).
  300
  301:- pce_end_class(editor).
  302
  303:- pce_extend_class(list_browser).
  304
  305paste_or_scroll_down(LB, Arg:[int]) :->
  306    "Forward to ->scroll_down (Apple keybinding)"::
  307    send(LB, scroll_down, Arg).
  308
  309:- pce_end_class(list_browser)