/*  Part of XPCE --- The SWI-Prolog GUI toolkit

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        J.Wielemaker@cs.vu.nl
    WWW:           http://www.swi-prolog.org/packages/xpce/
    Copyright (c)  1985-2010, University of Amsterdam, VU University Amsterdam
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

:- module(emacs_frame, []).
:- use_module(library(pce)).
:- use_module(library(tabbed_window)).
:- use_module(prompt).
:- require([ between/3
           , atomic_list_concat/2
           , default/3
           , forall/2
           , ignore/1
           ]).

resource(pinned,        image, image('pinned.xpm')).
resource(not_pinned,    image, image('pin.xpm')).
resource(mode_x_icon,   image, image('32x32/doc_x.xpm')).


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@current_emacs_mode is a variable  pointing   to  the current emacs-mode
object.  Pushed by `emacs_key_binding  ->fill_arguments_and_execute' and
various others.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- pce_global(@current_emacs_mode, new(var)).

:- pce_begin_class(emacs_tabbed_window, tabbed_window,
                   "Emacs editor tabs").

:- pce_global(@emacs_tab_popup, make_emacs_tab_popup).

make_emacs_tab_popup(P) :-
    new(P, popup),
    Tab = @arg1,
    Cond = (Tab?device?graphicals?size \== 1),
    send_list(P, append,
              [ menu_item(close,
                          message(Tab, destroy),
                          condition := Cond),
                menu_item(close_others,
                          message(Tab, close_other_tabs),
                          condition := Cond),
                menu_item(detach,
                          message(Tab, untab),
                          condition := Cond)
              ]).

current(TW, Window:window) :->
    "Make the given window the current one"::
    send_super(TW, current, Window),
    get(Window, text_buffer, TB),
    (   get(TW, frame, Frame),
        send(TB, check_modified_file, Frame),
        send(Frame, has_send_method, setup_mode)
    ->  send(TW?frame, setup_mode, Window)
    ;   send(TB, check_modified_file)
    ).

frame_window(_TW, Window:window, _Name:name, _Rank:'1..', Frame:frame) :<-
    "After un-tabbing, give the window a new frame"::
    new(Frame, emacs_frame(Window)).

empty(TW) :->
    "Last window-tab disappeared"::
    send(TW?frame, destroy).

:- pce_end_class.


:- pce_begin_class(emacs_frame, frame, "Frame for the PceEmacs editor").

class_variable(size,         size, size(80,32), "Size of text-field").
class_variable(prompt_style, {mini_window,dialog}, dialog, "How to prompt").

initialise(F, For:'emacs_buffer|emacs_view') :->
    "Create window for buffer"::
    send(F, send_super, initialise, 'PceEmacs', application := @emacs),
    send(F, icon, image(resource(mode_x_icon))),
    send(F, done_message, message(F, quit)),
    send(F, append, new(MBD, emacs_mode_dialog)),

    send(new(TW, emacs_tabbed_window), below, MBD),
    send(TW, label_popup, @emacs_tab_popup),
    send(new(emacs_mini_window), below, TW),

    (   send(For, instance_of, emacs_view)
    ->  V = For,
        get(For, text_buffer, B)
    ;   B = For,
        get(F, class_variable_value, size, Size),
        new(V, emacs_view(B, Size?width, Size?height))
    ),

    send(TW, append, V),
    send(B, update_label),
    get(V, editor, E),
    send(F, keyboard_focus, V),
    send(F, setup_mode, V),

    send(F, open),

    get(E, mode, Mode),
    ignore(send(Mode, new_buffer)).

quit(F) :->
    "User-initiated quit"::
    get(F, member, emacs_tabbed_window, TW),
    get(TW?members, size, Count),
    (   Count == 1
    ->  send(F, destroy)
    ;   send(F, confirm, 'Close %d tabs?', Count)
    ->  send(F, destroy)
    ;   true
    ).

confirm(F, Format:char_array, Args:any...) :->
    "Confirm centered"::
    new(D, dialog('Confirm action')),
    String =.. [string, Format | Args ],
    send(D, append, label(message, String)),
    send(D, append, button(ok, message(D, return, ok))),
    send(D, append, button(cancel, message(D, return, cancel))),
    send(D, transient_for, F),
    send(D, modal, transient),
    get(D, confirm_centered, F?area?center, Rval),
    send(D, destroy),
    Rval == ok.

editor_event(F, Ev:event) :->
    "Delegate to the mini-window"::
    get(F, member, mini_window, MW),
    send(MW, editor_event, Ev).

input_focus(F, Val:bool) :->
    "Activate the window"::
    send(F, send_super, input_focus, Val),
    (   send(F, unlinking)
    ->  true
    ;   send(F, active, Val)
    ).

on_current_desktop(F) :->
    "True if F for more than half on the current desktop"::
    get(F, area, FArea),
    get(F?display, size, size(DW,DH)),
    get(FArea, intersection, area(0,0,DW,DH), Intersection),
    get(FArea, measure, MA),
    get(Intersection, measure, IA),
    IA > MA/2.

tab(F, B:buffer=emacs_buffer, Expose:expose=[bool]) :->
    "Add new tab holding buffer"::
    get(F, member, emacs_tabbed_window, TW),
    (   get(TW, members, Windows),
        get(Windows, find, @arg1?text_buffer == B, Window)
    ->  (   Expose == @on
        ->  send(TW, on_top, Window)
        ;   true
        )
    ;   send(TW, append, new(V, emacs_view(B)), B?name, Expose),
        send(B, update_label),
        send(F, setup_mode, V)
    ).


buffer(F, B:emacs_buffer) :->
    "Switch to the given emacs buffer"::
    get(F, editor, E),
    send(E, text_buffer, B).


view(F, View:emacs_view) :<-
    "Currently active view"::
    get(F, member, emacs_tabbed_window, TW),
    get(TW, current, View).


editor(F, Editor:emacs_editor) :<-
    "Editor component of the frame"::
    get(F, view, V),
    get(V, editor, Editor).


menu_bar(F, MB:emacs_menu_bar) :<-
    "The menu_bar object at the top"::
    get(F, member, emacs_mode_dialog, D),
    get(D, member, emacs_menu_bar, MB).


mode(F, Mode:emacs_mode) :<-
    "Current mode object of the editor"::
    get(F, editor, E),
    get(E, mode, Mode).


setup_mode(F, V:emacs_view) :->
    "Setup the mode for indicated view"::
    get(V, mode, Mode),
    (   get(Mode, icon, Icon)
    ->  send(F, icon, Icon)
    ;   true
    ),
    get(F, menu_bar, MB),
    ignore(send(V, fill_menu_bar, MB)),
    (   get(V, label, Label)
    ->  send(F, label, Label)
    ;   true
    ).


active(F, Val:bool) :->
    "Indicate active status"::
    get(F, view, View),
    (   Val == @on
    ->  send(@emacs, first, F),
        send(@emacs, selection, View?text_buffer)
    ;   send(@emacs, selection, @nil)
    ).


fit(F) :->
    "Request to fit the contents"::
    (   get(F, attribute, fitted, @on)
    ->  send(F, resize)
    ;   send(F, send_super, fit),
        send(F, attribute, fitted, @on)
    ).


keyboard_focus(F, W:window) :->
    (   send(W, instance_of, view),
        get(F, member, mini_window, MW),
        get(MW, prompter, Prompter), Prompter \== @nil
    ->  send(F, send_super, keyboard_focus, MW)
    ;   send(F, send_super, keyboard_focus, W)
    ).

                 /*******************************
                 *          PROMPTING           *
                 *******************************/

:- pce_global(@prompt_recogniser, make_prompt_binding).

make_prompt_binding(G) :-
    new(G, key_binding(emacs_mini_window_prompter, text_item)),
    send(G, function, 'TAB',  complete),
    send(G, function, 'SPC',  insert_self),
    send(G, function, 'RET',  if(message(@receiver, apply, @on))),
    send(G, function, '\\C-g', and(message(@receiver, keyboard_quit),
                                  message(@receiver?frame, return,
                                          canceled))).

prompt_using(F, Item:dialog_item, Rval:unchecked) :<-
    "Prompt for value in dialog using Item"::
    get(F, view, View),
    get(F, member, mini_window, W),
    get(F, menu_bar, MB),
    send(MB, active, @off),

    send(W, client, View),
    send(W, prompter, Item),
    send(Item, message, message(F, return, ok)),
    (   send(Item, instance_of, text_item)
    ->  send(Item, recogniser, @prompt_recogniser),
        send(Item, value_font, fixed)
    ;   true
    ),
    send(F, keyboard_focus, W),
    get(F, confirm, Return),
    object(F),                      % may be freed!

    (   Return == ok
    ->  get(Item, selection, Rval)
    ;   true
    ),

    send(Item, message, @nil),
    send(Item, lock_object, @on),   % Tricky, but we should leave the
    send(W, prompter, @nil),        % lifetime to the caller
    get(Item, unlock, Item),
    get(F, view, View),
    send(F, keyboard_focus, View),
    send(MB, active, @on),
    Return == ok.

reset(F) :->
    "Remove prompter"::
    send(F, send_super, reset),
    get(F, member, mini_window, W),
    send(W, prompter, @nil),
    get(F, menu_bar, MB),
    send(MB, active, @on).

show_line_number(F, Line:'int|{too_expensive}*') :->
    "Show current line in mini-window"::
    get(F, member, mini_window, W),
    send(W, show_line_number, Line).

:- pce_end_class(emacs_frame).


:- pce_begin_class(emacs_mode_dialog, dialog,
                   "Show menu-bar for mode options").

initialise(D) :->
    send_super(D, initialise),
    send(D, gap, size(0,0)),
    send(D, pen, 0),
    send(D, append, new(emacs_menu_bar)),
    send(D, append, new(TB, tool_bar), right),
    send(TB, reference, point(0,15)),
    send(TB, alignment, right),
    get(@emacs, history, History),
    get(History, button, forward, Forward),
    get(History, button, backward, Backward),
    send_list(TB, append, [Backward,Forward]),
    send_list([Backward,Forward], activate).

resize(D) :->
    send(D, layout, D?area?size).

assign_accelerators(_) :->
    "Accelerators are defined by the window"::
    true.

:- pce_end_class(emacs_mode_dialog).


:- pce_begin_class(emacs_menu_bar, menu_bar,
                   "Top menu bar of the editor").

assign_accelerators(_) :->
    "Accelerators are defined by the window"::
    true.

mode(MB, Mode:emacs_mode) :->
    "Prepare for given mode"::
    get(Mode, mode_menu, ModeMenu),
    send(MB, clear),
    send(ModeMenu, for_all,
         message(MB, append_items, Mode, @arg1?name, @arg1?value)).

append_items(MB, Mode:emacs_mode, Name:name, Entries:chain) :->
    (   get(MB, member, Name, Popup)
    ->  true
    ;   new(Popup, emacs_popup(Name,
                               message(@emacs_mode, noarg_call, @arg1))),
        (   Name == help
        ->  send(MB, append, Popup, right)
        ;   send(MB, append, Popup)
        )
    ),
    send(Entries, for_some, message(Popup, append_item, Mode, @arg1)).

:- pce_end_class(emacs_menu_bar).


:- pce_begin_class(emacs_popup, popup,
                   "Popup for the mode-menu").

class_variable(accelerator_font, font, small).

assign_accelerators(_) :->
    "Accelerators are defined by the window"::
    true.

append_item(P, Mode:emacs_mode, Item:any) :->
    "Append single menu item"::
    (   Item == -
    ->  send(P, append, gap)
    ;   atom(Item)
    ->  send(P, append, new(MI, menu_item(Item))),
        (   accelerator(Item, Mode, Accell)
        ->  send(MI, accelerator, Accell)
        ;   true
        ),
        (   get(Mode, send_method, Item, tuple(_, Impl))
        ->  (   forall((between(1, 10, ArgN),
                    get(Impl, argument_type, ArgN, ArgType)),
                send(ArgType, includes, default))
            ->  true
            ;   send(MI, label, string('%s ...', Item?label_name))
            )
        ;   send(MI, active, @off)
        )
    ;   send(P, append, Item?clone)
    ).

%       accelerator(+Command, +Mode, -Accelerator)
%
%       Copy/cut are hacked due to the tricky combination of CUA and
%       native Emacs mode.

accelerator(copy, _, 'Control-c') :- !.
accelerator(cut,  _, 'Control-x') :- !.
accelerator(Cmd,  Mode, Accell) :-
    get(Mode, bindings, KeyBindings),
    get(KeyBindings, binding, Cmd, Key),
    human_accelerator(Key, Accell).

%       human_accelerator(+Key, -Human)
%
%       Translate XPCE key-sequences in conventional notation.  Should be
%       part of the XPCE kernel someday.

:- dynamic
    accel_cache/2.

human_accelerator(Key, Text) :-
    accel_cache(Key, Text),
    !.
human_accelerator(Key, Text) :-
    new(S, string('%s', Key)),
    send(regex('\\\\C-(.)'), for_all, S,
         message(@arg1, replace, @arg2, 'Control-\\1 ')),
    send(regex('\\\\e'), for_all, S,
         message(@arg1, replace, @arg2, 'Alt-')),
    get(S, value, Text),
    assert(accel_cache(Key, Text)).

:- pce_end_class(emacs_popup).


:- pce_begin_class(emacs_mini_window, dialog, "Prompt and feedback window").

variable(prompter,       dialog_item*,  get,    "Current prompter").
variable(report_count,   number,        get,    "Count to erase report").
variable(report_type,    name*,         both,   "Last type of report").

initialise(D) :->
    send(D, send_super, initialise),
    send(D, slot, report_count, number(0)),
    send(D, gap, size(10, 2)),
    send(D, pen, 0),
    send(D, display, new(R, label(reporter)), point(0, 2)),
    send(R, wrap, clip),
    send(D, display, new(T, text('', right, normal)), point(100, 2)),
    send(T, name, line),
    get(text_item(''), height, MH),
    send(D, height, MH),
    send(D, name, mini_window).

resize(D) :->
    get(D, member, line, Text),
    get(D?area, width, W),
    get(Text, width, TW),
    send(Text, x, W-TW-16).

'_compute_desired_size'(_) :->
    "We have fixed size"::
    true.

client(D, Client:emacs_view) :->
    "Register emacs_view as client"::
    send(D, delete_hypers, client),
    new(_, hyper(D, Client, client, mini_window)).
client(D, Client:emacs_view) :<-
    "Get client emacs_view"::
    get(D, hypered, client, Client).


show_line_number(D, Line:'int|{too_expensive}*') :->
    "Show number of current line"::
    get(D, member, line, Text),
    (   Line == @nil
    ->  send(Text, string, '')
    ;   Line == too_expensive
    ->  send(Text, string, 'Line: ?')
    ;   send(Text, string, string('Line: %d', Line))
    ).


report(D, Type:name, Fmt:[char_array], Args:any ...) :->
    "Report"::
    (   get(D, report_type, ReportType),
        ok_to_overrule(Type, ReportType)
    ->  send(D, report_type, Type),
        get(D, member, reporter, Label),
        get(D, report_count, RC),
        (   Fmt == '', Type == status       % clear
        ->  send(Label, clear),
            send(RC, value, 0)
        ;   (   get(D, prompter, Prompter), Prompter \== @nil
            ->  send(Label, x, Prompter?width + 10)
            ;   send(Label, x, 0)
            ),
            send(Label, displayed, @on),
            Msg =.. [report, Type, Fmt|Args],
            send(Label, Msg),
            send(RC, value, 10)
        )
    ;   true
    ).

ok_to_overrule(_, @nil).
ok_to_overrule(_, status).
ok_to_overrule(_, progress).
ok_to_overrule(_, done).
ok_to_overrule(warning, warning).
ok_to_overrule(inform, _).
ok_to_overrule(error, _).

:- pce_global(@emacs_mini_window_bindings, make_emacs_mini_window_bindings).

make_emacs_mini_window_bindings(B) :-
    new(B, key_binding(emacs_mini_window)),
    send(B, function, '\\en', m_x_next),
    send(B, function, '\\ep', m_x_previous).

editor_event(D, Ev:event) :->
    "Process event typed in the editor"::
    (   get(D, prompter, Prompter),
        Prompter \== @nil
    ->  (   send(@emacs_mini_window_bindings, event, Ev)
        ->  true
        ;   get(D, member, reporter, Reporter),
            send(Reporter, displayed, @off),
            ignore(send(Ev, post, Prompter))
        )
    ;   send(D, report_type, @nil),
        get(D, report_count, RC),
        send(RC, minus, 1),
        (   send(RC, equal, 0)
        ->  send(D, report, status, '')
        ),
        fail
    ).


event(D, Ev:event) :->
    "Process direct event"::
    (   get(D, prompter, Prompter),
        Prompter \== @nil
    ->  send(D, editor_event, Ev)
    ;   send_super(D, event, Ev)
    ).


m_x_next(D) :->
    "Handle M-n to get next value"::
    (   get(D?client?mode, m_x_next, NewDefault)
    ->  send(D?prompter, displayed_value, NewDefault?print_name)
    ;   send(D?prompter, restore)
    ).


m_x_previous(D) :->
    "Handle M-p to get previous value"::
    get(D?client?mode, m_x_previous, NewDefault),
    send(D?prompter, displayed_value, NewDefault?print_name).


geometry(D, X:[int], Y:[int], W:[int], H:[int]) :->
    "Change size, center contents vertically"::
    send(D, send_super, geometry, X, Y, W, H),
    get(D, height, DH),
    DH2 is DH//2,
    send(D?graphicals, for_all,
         message(@arg1, center_y, DH2)).


prompter(D, Prompter:dialog_item*) :->
    "Display the prompter"::
    get(D, member, reporter, Reporter),
    (   get(D, prompter, OldPrompter), OldPrompter \== @nil
    ->  send(D, erase, OldPrompter)
    ;   true
    ),
    (   Prompter == @nil
    ->  send(Reporter, clear),
        send(Reporter, displayed, @on)
    ;   send(Reporter, displayed, @off),
        get(Prompter, height, H),
        get(D, height, DH),
        PY is (DH-H)//2,
        send(D, display, Prompter, point(25, PY)),
        get(Prompter, height, H),
        MinH is H,
        (   DH < MinH
        ->  send(D, height, MinH)
        ;   true
        )
    ),
    send(D, slot, prompter, Prompter).

:- pce_end_class.


:- pce_begin_class(emacs_view, view,
                   "View running an emacs_editor").

:- pce_global(@emacs_image_recogniser,
              new(handler(button,
                          message(@receiver?device?(mode), event, @event)))).

class_variable(size,         size, size(80,32), "Size of text-field").

initialise(V, B:buffer=[emacs_buffer], W:width=[int], H:height=[int]) :->
    "Create for buffer"::
    get(V, class_variable_value, size, size(DW, DH)),
    default(W, DW, Width),
    default(H, DH, Height),
    (   B == @default
    ->  new(Buffer, emacs_buffer(@nil, '*scratch*'))
    ;   Buffer = B
    ),
    send_super(V, initialise, @default, @default, @default,
               new(E, emacs_editor(Buffer, Width, Height))),
    send(E?image, recogniser, @emacs_image_recogniser),
    send(E, recogniser,
         handler(keyboard,
                 if(message(E?frame, has_send_method, editor_event),
                    message(E?frame, editor_event, @arg1),
                    new(or)))),

    get(Buffer, mode, ModeName),
    send(E, mode, ModeName),
    get(E, mode, Mode),             % the mode object
    ignore(send(Mode, new_buffer)).

label(V, Label:name) :->
    "Set label of frame/tab"::
    get(V, device, Dev),
    (   send(Dev, has_send_method, label)
    ->  send(Dev, label, Label),
        (   get(Dev, container, emacs_tabbed_window, TW),
            get(TW, current, V),
            get(V, frame, Frame),
            Frame \== @nil
        ->  send(Frame, label, Label) % HACK: should subclass window_tab
        ;   true
        )
    ;   get(V, frame, Frame),
        Frame \== @nil
    ->  send(Frame, label, Label)
    ;   true
    ).
label(V, Label:name) :<-
    "Fetch the current label"::
    get(V, device, Dev),
    send(Dev, has_get_method, label),
    get(Dev, label, Label).

drop_files(V, Files:chain, _At:point) :->
    "Accept files dropped on me"::
    send(V?editor, drop_files, Files).


:- pce_group(mode).

setup_mode(V) :->
    "Editor has changed mode; ask <-frame to do its part"::
    (   get(V, frame, Frame),
        send(Frame, has_send_method, setup_mode)
    ->  send(Frame, setup_mode, V)
    ;   true
    ).

fill_menu_bar(V, MB:menu_bar) :->
    "Setup menu-bar for current mode"::
    send(V?editor, fill_menu_bar, MB).

:- pce_group(prompt).

prompt_using(V, Item:dialog_item, Rval:unchecked) :<-
    "Prompt for one value using a dialog-item"::
    (   get(V, frame, Frame),
        send(Frame, has_get_method, prompt_using)
    ->  get(Frame, prompt_using, Item, Rval)
    ;   new(D, dialog),             % very incomplete!
        send(D, transient_for, V),
        send(D, modal, transient),
        send(D, append, Item),
        get(D, confirm_centered, Rval)
    ).

prompt(V, Label:char_array, Default:[any], Type:[type], History:[chain],
       Rval:any) :<-
    "Prompt for a value"::
    get(V, mode, Mode),
    make_item(Mode, Label, Default, Type, History, Item),
    (   send(Item, instance_of, text_item)
    ->  send(Item, length, 60),
        send(Item, pen, 0)
    ),

    get(V, prompt_using, Item, RawRval),

    fix_rval(Type, RawRval, Rval),
    (   object(Rval),
        get(Rval, lock_object, @off)
    ->  send(Rval, lock_object, @on),       % protect during deletion!
        free(Item),
        get(Rval, unlock, Rval)
    ;   free(Item)
    ).


%       If the user entered a directory while requested for a file,
%       start the finder in the specified directory to provide the file.

fix_rval(Type, RawRval, RVal) :-
    send(Type, instance_of, type),
    send(Type, includes, file),
    \+ send(Type, includes, directory),
    atom(RawRval),
    send(directory(RawRval), exists),
    !,
    get(@finder, file, @on, directory := RawRval, RVal).
fix_rval(_, Rval, Rval).


:- pce_global(@emacs_prompt_for,
              new(constant(prompt, 'Prompt for value'))).

interactive_arguments(V, Impl:any, Times:[int], Argv:vector) :<-
    "Prompt for arguments for the given implementation"::
    get(V, mode, Mode),
    make_arg_vector(Impl, Times, Argv),
    (   get(Argv, index, @emacs_prompt_for, _)
    ->  (   get(V, frame, Frame),
            send(Frame, has_get_method, prompt_style),
            get(Frame, prompt_style, mini_window)
        ->  fill_arg_vector(Mode, Impl, Argv)
        ;   new(D, emacs_prompt_dialog(Mode, Impl, Argv)),
            send(D, prompt, V, Argv),
            send(D, destroy)
        )
    ;   true
    ).

fill_arg_vector(Mode, Impl, Argv) :-
    fill_arg_vector(1, Mode, Impl, Argv).

fill_arg_vector(ArgN, Mode, Impl, Argv) :-
    get(Impl, argument_type, ArgN, ArgType),
    get(Argv, element, ArgN, @emacs_prompt_for),
    !,
    get(Mode, interactive_argument, Impl, ArgN, Arg),
    get(ArgType, check, Arg, CheckedArg),
    send(Argv, element, ArgN, CheckedArg),
    Next is ArgN + 1,
    fill_arg_vector(Next, Mode, Impl, Argv).
fill_arg_vector(ArgN, Mode, Impl, Argv) :-
    get(Impl, argument_type, ArgN, _),
    !,
    Next is ArgN + 1,
    fill_arg_vector(Next, Mode, Impl, Argv).
fill_arg_vector(_, _, _, _).


make_arg_vector(Impl, Times, Argv) :-
    new(Argv, code_vector),
    make_arg_vector(1, Impl, Times, Argv).

make_arg_vector(ArgN, Impl, Times, Argv) :-
    get(Impl, argument_type, ArgN, ArgType),
    !,
    (   integer(Times),
        send(ArgType, includes, int)
    ->  send(Argv, element, ArgN, Times),
        NextTimes = @default
    ;   NextTimes = Times,
        (   send(ArgType, includes, default)
        ->  send(Argv, element, ArgN, @default)
        ;   send(Argv, element, ArgN, @emacs_prompt_for)
        )
    ),
    Next is ArgN + 1,
    make_arg_vector(Next, Impl, NextTimes, Argv).
make_arg_vector(_, _, _, _).


:- pce_end_class(emacs_view).


:- pce_begin_class(emacs_editor, editor, "Generic PceEmacs editor").

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
We use a pool of  modes  recorded  in   <-modes  to  avoid  the need for
destruction of mode objects during the livetime  of the editor.  This is
dangerous as the mode might still be `running' some command.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

variable(mode,            emacs_mode*,  get, "Mode of operation").
variable(modes,           chain,        get, "Modes part of this editor").

initialise(E, TB:[text_buffer], W:[int], H:[int]) :->
    send(E, send_super, initialise, TB, W, H),
    send(E, slot, modes, new(chain)).


unlink(E) :->
    "Unlink from mode object"::
    get(E, modes, Modes),
    send(Modes, for_all, message(@arg1, free)),
    send(E, send_super, unlink).

:- pce_global(@emacs_idle_timer, make_idle_timer).

make_idle_timer(T) :-
    new(T, timer(2)),
    send(T, message,
         new(Msg, message(T, send_hyper, editor, editor_idle_event))),
    send(Msg, debug_class, service).        % non-traceable


editor_idle_event(E) :->
    "Editor is idle"::
    get(E, mode, Mode),
    Mode \== @nil,
    send(Mode, has_send_method, idle),
    get(E, window, Window),
    get(Window, focus, @nil),       % only send event if no recognisers
    send(Mode, idle).               % are active


start_idle_timer(E, Interval:[real]) :->
    "Reset the idle timer to timeout after the specified time"::
    default(Interval, 2, Time),
    send(@emacs_idle_timer, interval, Time),
    send(@emacs_idle_timer, status, once),
    send(@emacs_idle_timer, delete_hypers),
    new(_, hyper(@emacs_idle_timer, E, editor, idle_timer)).


typed(E, Id:'event|event_id') :->
    "Handle typing via mode"::
    send(E, start_idle_timer),
    get(E, mode, Mode),
    (   send(Mode, typed, Id, E),
        object(Mode)                % may disappear
    ->  send(Mode, highlight_matching_bracket)
    ;   true
    ).


caret(E, Caret:[int]) :->
    "Deal with idle-timing and ->new_caret_position"::
    get(E, caret, Old),
    send_super(E, caret, Caret),
    send(E, start_idle_timer),
    get(E, mode, Mode),
    (                               % Mode can be @nil
        send(Mode, has_send_method, new_caret_position)
    ->  (   Caret == @default
        ->  get(E, caret, NewCaret)
        ;   NewCaret = Caret
        ),
        (   Old \== NewCaret
        ->  send(Mode, new_caret_position, NewCaret)
        ;   true
        )
    ;   true
    ).


event(E, Ev:event) :->
    (   send(Ev, is_a, area_enter)
    ->  get(E, frame, Frame),
        (   get(Frame, transients, Transients),
            Transients \== @nil,
            get(Transients, find, @arg1?modal == transient, _)
        ->  format('We have a transient~n')
        ;   send(Frame, keyboard_focus, E?window)
        )
    ;   send_super(E, event, Ev)
    ).


paste(E, Which:[{primary,clipboard}]) :->
    send(E, start_idle_timer),
    send_super(E, paste, Which),
    send(E, highlight_matching_bracket).


highlight_matching_bracket(E) :->
    get(E, mode, Mode),
    (   send(Mode, highlight_matching_bracket)
    ->  true
    ;   true                        % avoid delegation
    ).


mode(E, ModeName:mode_name) :->
    "Associate argument mode"::
    get(E, mode, OldMode),
    (   get(OldMode, name, ModeName)
    ->  send(E, syntax, OldMode?syntax)
    ;   (   get(E?modes, find, @arg1?name == ModeName, Mode)
        ->  send(E, slot, mode, Mode)
        ;   send(E, slot, mode, ModeName),  % Converted to object
            get(E, mode, Mode),             % The object
            send(Mode, editor, E),
            send(E?modes, append, Mode)
        ),
        send(E?text_buffer, mode, ModeName),
        send(E, syntax, Mode?syntax),
        send(E, bindings, Mode?bindings),
        send(E, setup_mode),
        send(E?device, setup_mode),
        send(E, report, status, 'Switched to ``%s'''' mode', ModeName)
    ).


preview_drop(E, Obj:object*) :->
    "Delegate to mode"::
    get(E, mode, Mode),
    get(Mode?class, send_method, preview_drop, _), % avoid delegation
    send(Mode, preview_drop, Obj).


drop(E, Obj:object) :->
    "Delegate to mode"::
    get(E, mode, Mode),
    get(Mode?class, send_method, drop, _),         % avoid delegation
    send(Mode, drop, Obj).


auto_fill(E, Caret:[int], Regex:[regex]) :->
    "Delegate to mode"::
    (   get(E, mode, Mode),
        get(Mode?class, send_method, auto_fill, _)
    ->  send(Mode, auto_fill, Caret, Regex)
    ;   send_super(E, auto_fill, Caret, Regex)
    ).


import_selection(E) :->
    "Import the (primary) selection or the cut_buffer"::
    get(E, display, Display),
    get(Display, selected_text, String),
    (   get(E, frame, Frame),
        get(Frame, member, mini_window, MiniWindow),
        get(MiniWindow, prompter, TI),
        send(TI, instance_of, text_item)
    ->  send(TI, insert, @default, String)
    ;   send(E, insert, String)
    ).


catch_all(E, Selector:name, Args:unchecked ...) :->
    "Delegate to mode"::
    get(E, mode, Mode),
    get(Mode?class, send_method, Selector, _),
    send(@pce, last_error, @nil),
    Msg =.. [Selector|Args],
    send(Mode, Msg).


text_buffer(E, B:emacs_buffer) :->
    "Switch to indicated buffer"::
    get(E, text_buffer, Last),
    (   B == Last
    ->  true
    ;   send_super(E, text_buffer, B),
        get(B, mode, ModeName),
        send(E, mode, ModeName),
        send(B, update_label),
        send(E, report, status, ''),
        get(E, mode, Mode),
        send(Mode, new_buffer),
        (   send(Last, instance_of, emacs_buffer)
        ->  send(E, delete_hypers, last_buffer),
            new(_, hyper(E, Last, last_buffer, last_editor))
        ;   true
        )
    ).


last_buffer(E, TB:text_buffer) :<-
    "Text-buffer we came from (for default)"::
    get(E, hypered, last_buffer, TB).


                 /*******************************
                 *          UTILITIES           *
                 *******************************/

label(E, Label:name) :->
    "Delegate to view"::
    get(E, device, View),
    send(View, label, Label).

size(E, Size:size) :->
    "Set size, resizing the frame"::
    get(E, frame, Frame),
    get(Frame, size, size(FW,FH)),
    get(E?area, size, size(W0,H0)),
    send_super(E, size, Size),
    get(E?area, size, size(W1,H1)),
    FW1 is FW+W1-W0,
    FH1 is FH+H1-H0,
    send(Frame, size, size(FW1, FH1)).

font(E, Font:font) :->
    "Set font, resizing the frame"::
    get(E, frame, Frame),
    get(Frame, size, size(FW,FH)),
    get(E?area, size, size(W0,H0)),
    send_super(E, font, Font),
    get(E?area, size, size(W1,H1)),
    FW1 is FW+W1-W0,
    FH1 is FH+H1-H0,
    send(Frame, size, size(FW1, FH1)).

looking_at(E, Re:regex, Where:[int], End:[int]) :->
    "Test if regex macthes from the caret"::
    (   Where == @default
    ->  get(E, caret, C)
    ;   C = Where
    ),
    get(E, text_buffer, TB),
    send(Re, match, TB, C, End).

looking_at(E, Re:regex, Where:[int], End:[int], Len:int) :<-
    "Test if regex macthes from the caret"::
    (   Where == @default
    ->  get(E, caret, C)
    ;   C = Where
    ),
    get(E, text_buffer, TB),
    get(Re, match, TB, C, End, Len).

:- pce_end_class.


                 /*******************************
                 *          EMACS MODES         *
                 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PceEmacs  modes  are  tricky  stuff.   We    like  to  have  comfortable
programming, which implies we should  represent   a  PceEmacs  mode as a
class.   This  provides  us  with  a   good  programming  interface  and
inheritance as well as all the other goodies of OO programming.

We also would like to be able to   switch PceEmacs windows from one mode
to another.  This conflicts, as instances  cannot be migrated from class
to class.  Therefore, PceEmacs modes are objects  that are attached to a
emacs_editor.  An emacs_mode delegates to the   editor  in this mode and
editors delegate to their mode (with an explicit method to avoid endless
loops  if  the   method   is   defined    on   neither).    The   method
`pce_editor->mode' attaches a mode to an editor.

Next, we would like users to be able  to extend these classes to provide
custom methods and possibly redefine methods.  This has been implemented
using tricky meta-programming: class emacs_mode_class   is a subclass of
class `class' (representing classes).   This   class  defines the method
->load_user_extensions, which is called when an instance of the class is
created.   The  classes  defining  emacs_modes  are  instances  of  this
emacs_mode_class class.  To understand this, try:

        ?- new(X, class(myclass, class)),
           new(Y, myclass(myobject, object)),
           new(Z, myobject).

and verify how the objects and classes are related.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


:- pce_begin_class(emacs_mode_class, class,
                   "Class for emacs modes").

variable(user_extensions_loaded, bool := @off, get,
         "Test if extensions are loaded").

load_user_extensions(C) :->
    "Load mode extensions from ~/lib/xpce/emacs/"::
    (   get(C, user_extensions_loaded, @on)
    ->  true
    ;   get(C, name, Name),
        (   atom_concat(emacs_, Base, Name)
        ->  true
        ;   Base = Name
        ),
        send(@emacs, load_user_extension, Base),
        send(C, slot, user_extensions_loaded, @on),
        get(C, super_class, Super),
        (   send(Super, has_send_method, load_user_extensions)
        ->  send(Super, load_user_extensions)
        ;   true
        )
    ).

:- pce_end_class(emacs_mode_class).

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Finally, we have to tell pce_begin_class/3 the  meta-class we want to be
using.  If pce_begin_class/3 makes a subclass, it will make the subclass
of the same  meta-class  as  its   super-class.   Thus,  a  subclass  of
emacs_mode will be an instance   of  class(emacs_mode_class), instead of
class(class).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- pce_begin_class(emacs_mode_class:emacs_mode(name), object,
                   "Generic PceEmacs mode class").

variable(name,            name,         get,  "Name of the mode").
variable(syntax,          syntax_table, get,  "Syntax for this mode").
variable(bindings,        key_binding,  get,  "Key-binding table").
variable(editor,          editor*,      both, "Associated editor").
variable(m_x_history,     chain*,       both, "Current M-x command history").
variable(m_x_index,       int*,         both, "M-p/M-n current index").
variable(m_x_argn,        int*,         both, "M-p/M-n current argument").
variable(keep_selection,  bool := @off, both, "Keep selection for this method").

delegate_to(editor).

                /********************************
                *         CREATE/REUSE          *
                ********************************/

initialise(M) :->
    "Create"::
    get(M, class_name, ClassName),
    mode_name(ClassName, Name),
    send(@mode_name_type?context, add, Name), % make sure
    send(M, send_super, initialise),
    send(M, slot, name, Name),
    send(M, slot, syntax, Name),              % converts to object
    send(M, bindings).


icon(_, I:image) :<-
    "Return icon for mode"::
    new(I, image(resource(mode_x_icon))).


mode_name(emacs_mode, default) :- !.
mode_name(Mode, Name) :-
    (   atom_concat(emacs_, M1, Mode)
    ;   M1 = Mode
    ),
    !,
    (   atom_concat(Name, '_mode', M1)
    ;   Name = M1
    ),
    !.


table_name(ClassName, TableName) :-
    atom_concat(TableName, '_mode', ClassName).


new_buffer(M) :->
    "Called if a new buffer is attached to this mode"::
    (   get(M, frame, Frame),
        send(Frame, has_send_method, show_line_number)
    ->  send(Frame, show_line_number, @nil)
    ;   true
    ),
    send(M, new_caret_position, M?caret).


new_caret_position(M, Caret:int) :->
    "Called after any caret movement"::
    get(M, text_buffer, TB),
    get(TB, find_all_fragments,
        message(@arg1, overlap, Caret),
        Fragments),
    (   send(Fragments, empty)
    ->  send(M, report, status, '')
    ;   send(Fragments, for_some,
             message(M, in_fragment, @arg1))
    ).


highlight_matching_bracket(_M, _At:[int]) :->
    "Virtual.  Statically highlight bracket matching caret"::
    true.


in_fragment(M, Fragment:fragment) :->
    "Called after a caret movement brings the caret in fragment"::
    (   send(Fragment, has_send_method, identify)
    ->  send(Fragment, identify)
    ;   (   get(Fragment, attribute, message, Message)
        ->  get(Fragment, style, StyleName),
            send(M, report, status, '%s: %s', StyleName, Message)
        ;   true
        )
    ).


bindings(M) :->
    "Associate key_binding table"::
    get(M, class_name, ClassName),
    binding_name(ClassName, Name),
    get(@key_bindings, member, Name, Table),
    !,
    send(M, slot, bindings, Table).


syntax(M) :->
    "Associate syntax table"::
    get(M, class_name, ClassName),
    binding_name(ClassName, Name),
    get(@syntax_tables, member, Name, Table),
    !,
    send(M, slot, syntax, Table).


binding_name(ClassName, Name) :-
    table_name(ClassName, Name).
binding_name(ClassName, Name) :-
    mode_name(ClassName, ModeName),
    key_binding_name(ModeName, Name).
binding_name(ClassName, Name) :-
    get(@pce, convert, ClassName, class, Class),
    get(Class, super_class, Super),
    send(Super, is_a, emacs_mode),
    get(Super, name, SuperName),
    binding_name(SuperName, Name).


convert(_, Name:name, Mode:emacs_mode) :<-
    "Convert name into a mode object"::
    atomic_list_concat([emacs_, Name, '_mode'], ModeClassName),
    get(@pce, convert, ModeClassName, class, _), % fail silently
    new(Mode, ModeClassName).


                 /*******************************
                 *         THE MODE MENU        *
                 *******************************/

:- pce_global(@emacs_mode, new(@event?window?(mode))).

mode_menu(M, MM:emacs_mode_menu) :<-
    "Return the mode-menu structure for this mode"::
    get(M, class_name, ClassName),
    mode_menu_name(ClassName, Name),
    get(@emacs_mode_menus, member, Name, MM),
    !.


mode_menu_name(ClassName, Name) :-
    mode_name(ClassName, Name).
mode_menu_name(ClassName, Name) :-
    get(@pce, convert, ClassName, class, Class),
    get(Class, super_class, Super),
    send(Super, is_a, emacs_mode),
    get(Super, name, SuperName),
    mode_menu_name(SuperName, Name).

fill_menu_bar(M, MB:menu_bar) :->
    "Fill the menu_bar"::
    send(MB, mode, M).


                 /*******************************
                 *            HISTORY           *
                 *******************************/

%:- pce_global(@c_method, new(var)).    % debugging

open_history(M, Impl:behaviour, Force:[bool]) :->
    "(Initialise) history for behaviour"::
    (   (Force == @on ; get(M, m_x_history, @nil))
    ->  (   get(Impl, attribute, emacs_history, History)
        ->  true
        ;   send(Impl, attribute, emacs_history, new(History, chain))
        ),
%       send(@c_method, assign, Impl, global),
        send(M, m_x_history, History),
        send(M, m_x_index, @nil)
    ;   true
    ).


close_history(M, Argv:[vector]) :->
    "Close open history adding Argv"::
    get(M, m_x_history, History),
    (   Argv \== @default,
        History \== @nil
    ->  get(Argv, copy, Save),
        clean_argv(Save),
        (   get(History, find,
                message(@prolog, same_argv, Save, @arg1),
                Old)
        ->  send(History, move_after, Old)
        ;   send(History, prepend, Argv)
        )
    ;   true
    ),
    send(M, m_x_history, @nil),
    send(M, m_x_index, @nil).


same_argv(V1, V2) :-
    get(V1, size, S1),
    get(V2, size, S1),
    forall(between(1, S1, N),
           (   get(V1, element, N, E1), get(E1, print_name, P1),
               get(V2, element, N, E2), get(E2, print_name, P2),
               send(P1, equal, P2)
           )).


%       clean_argv(+Vector)
%       Replace vector elements with their written version to avoid the
%       risk of illegal-object references.

clean_argv(Vector) :-
    get(Vector, low_index, Low),
    get(Vector, high_index, High),
    (   between(Low, High, Index),
        get(Vector, element, Index, E),
        object(E),
        get(E, protect, @off),
        send(Vector, element, Index, E),
        fail
    ;   true
    ).


noarg_call(M, Selector:name, Times:[int]) :->
    "Invoke method without arguments (prompt)"::
    (   get(M, send_method, Selector, tuple(_, Impl))
    ->  send(@current_emacs_mode, assign, M),
        send(M, open_history, Impl, @on),
        get(M, interactive_arguments, Impl, Times, Argv),
        send(M, report, status, ''),
        send(M, close_history, Argv),
        (   send(M, send_vector, Selector, Argv)
        ->  (   object(M)
            ->  send(M, mark_undo)
            ;   true
            )
        ;   (   object(M)
            ->  send(M, report, status, '%s command failed', Selector)
            ;   true
            )
        )
    ;   send(M, report, error, 'No implementation for ``%s''''', Selector)
    ).


arg_call(M, Selector:name, Arg:any) :->
    "Invoke method from pullright menu"::
    send(M, Selector, Arg).


                 /*******************************
                 *           SETUP              *
                 *******************************/

setup_mode(M) :->
    "Initialise mode (->load_user_extensions)"::
    send(M, load_user_extensions).


load_user_extensions(M) :->
    "Load mode extensions from ~/lib/xpce/emacs/"::
    send(M?class, load_user_extensions).


                /********************************
                *           TYPING              *
                ********************************/

typed(M, Id:'event|event_id', Editor:editor) :->
    "Handle typed character for editor"::
    get(M, text_buffer, TB),
    send(TB, check_auto_save),

                                    % send to mode rather than editor
    (   get(M, focus_function, F), F \== @nil
    ->  (   send(M, F, Id)
        ->  true
        ;   send(M, focus_function, @nil),
            send(M, typed, Id, Editor)        % failed: unfocus and resent
        )
    ;   get(M, bindings, Binding),
        send(Binding, typed, Id, M)
    ).


                 /*******************************
                 *           SELECTION          *
                 *******************************/

default(_E, _Type:type, _Default:unchecked) :<-
    "[virtual] Provide default for prompting"::
    fail.


                 /*******************************
                 *           EVENTS             *
                 *******************************/

event(M, Ev:event) :->
    "Allow for gestures to be appended to modes"::
    (   get(M, all_recognisers, Chain),
            get(Chain, find,
                message(@arg1, event, Ev), _)
    ;   send(Ev, is_a, ms_right_down), % show fragment popup (if any)
        get(M?image, index, Caret),
        get(M?text_buffer, find_all_fragments,
            message(@arg1, overlap, Caret),
            Fragments),
        send(Fragments, sort, ?(@arg1?length, compare, @arg2?length)),
        get(Fragments, find, message(@arg1, has_get_method, popup), F),
        get(F, popup, P), P \== @nil,
        new(G, popup_gesture(P)),
        send(G, context, F),        % make fragment available as @arg1
        send(G, event, Ev)
    ).


                 /*******************************
                 *        FIX DELEGATION        *
                 *******************************/

file(M, File:file*) :<-
    "Return associated file"::
    get(M?text_buffer, file, File).


                 /*******************************
                 *      PROMPTING ARGUMENTS     *
                 *******************************/

prompt(M, Label:char_array, Default:[any], Type:[type], Rval:any) :<-
    "Prompt for a value in the mini-window"::
    get(M?window, prompt, Label, Default, Type, Rval).


prompt_using(M, Item:graphical, Rval:any) :<-
    "Prompt using dialog item in the mini-window"::
    get(M?window, prompt_using, Item, Rval).


interactive_arguments(M, Implementation:any, Times:[int], Argv:vector) :<-
    "Prompt for arguments for the given implementation"::
    get(M, window, View),
    get(View, interactive_arguments, Implementation, Times, Argv).


interactive_argument(M, Implementation:any, Which:int, Value:any) :<-
    "Prompt for interactive argument of specified type"::
    send(M, open_history, Implementation),
    get(M, window, EmacsWindow),
    get(Implementation, argument_type, Which, Type),
    send(M, m_x_argn, Which),
    get(M, m_x_history, History),
    (   get(M, m_x_index, Idx), Idx \== @nil % use M-x History!
    ->  get(History, nth1, Idx, HistArgv),
        get(HistArgv, element, Which, DefaultValue)
    ->  true
    ;   get(Implementation, name, ImplName),
        \+ send(ImplName, suffix, selection), % not on *_selection
        get(M, selected, Selection),
        get(Type, check, Selection, DefaultValue)
    ->  true
    ;   DefaultValue = @default
    ),
    (   get(Type, argument_name, Label), Label \== @nil
    ->  true
    ;   get(Type, name, Label)
    ),
    (   (   History == @nil
        ;   send(History, empty)
        )
    ->  ValueSet = @default
    ;   get(History, map, ?(@arg1, element, Which), ValueSet)
    ),
    get(EmacsWindow, prompt, Label, DefaultValue, Type, ValueSet, Value).


m_x_previous(M, Value:any) :<-
    "Read next value from the M-x history"::
    get(M, m_x_index, Idx),
    (   Idx == @nil
    ->  Nidx = 1
    ;   Nidx is Idx + 1
    ),
    (   get(M, m_x_history, H), H \== @nil,
        get(H, nth1, Nidx, ArgVector)
    ->  get(ArgVector, element, M?m_x_argn, Value),
        send(M, m_x_index, Nidx)
    ;   send(M, report, warning, 'No (more) history'),
        fail
    ).


m_x_next(M, Value:any) :<-
    "Read previous value from the M-x history"::
    get(M, m_x_index, Idx),
    (   (Idx == @nil ; Idx =< 1)
    ->  send(M, report, warning, 'Back at start'),
        fail
    ;   Nidx is Idx - 1
    ),
    get(M?m_x_history, nth1, Nidx, ArgVector),
    get(ArgVector, element, M?m_x_argn, Value),
    send(M, m_x_index, Nidx).


                 /*******************************
                 *       LOCATION HISTORY       *
                 *******************************/

location_history(M, Start:start=[int], Len:length=[int],
                 Title:title=[char_array]) :->
    "Add location to the editor history"::
    (   Start == @default
    ->  get(M, caret, Caret),
        get(M, scan, Caret, line, 0, start, SOF)
    ;   SOF = Start
    ),
    (   send(M, history_not_interesting, SOF)
    ->  true
    ;   get(M, text_buffer, TB),
        new(_, emacs_history_fragment(TB, SOF, Len, Title))
    ).

history_not_interesting(M, Start:int) :->
    "True if Start is close to the recent history mark"::
    (   Start == 0
    ;   send(M, history_close_to_last, Start)
    ),
    !.

history_close_to_last(M, Start:int, MaxDist:[int]) :->
    "True if Start is within MaxDist lines from last"::
    default(MaxDist, 10, MD),
    get(M, text_buffer, TB),
    get(@emacs?history, current, Current),
    get(Current, get_hyper, fragment, text_buffer, TB),
    get(Current, get_hyper, fragment, start, StartOfCurrent),
    (   Start < StartOfCurrent
    ->  get(TB, count_lines, Start, StartOfCurrent, Lines)
    ;   Start > StartOfCurrent
    ->  get(TB, count_lines, StartOfCurrent, Start, Lines)
    ;   Lines = 0
    ),
    Lines < MD.


                 /*******************************
                 *            REPORT            *
                 *******************************/

report_to(M, E:editor) :<-
    "Send reports to the <-editor"::
    get(M, editor, E).

:- pce_end_class.


:- pce_begin_class(emacs_mode_menu(name), sheet).

:- pce_global(@emacs_mode_menus, new(hash_table)). % name ---> mode_menu object

variable(name,          name,           get,    "Name of the menu").

initialise(MM, Name:name, Super:[emacs_mode_menu]) :->
    "Create from name and super (default) menu"::
    send(MM, send_super, initialise),
    send(MM, slot, name, Name),
    send(@emacs_mode_menus, append, Name, MM),
    send(MM, protect),
    (   Super \== @default
    ->  send(Super, for_all,
             message(MM, value, @arg1?name, @arg1?value?copy))
    ;   true
    ).


lookup(_, Name:name, _Super:[emacs_mode_menu], MM) :<-
    "Reuse existing mode menu"::
    get(@emacs_mode_menus, member, Name, MM).


convert(_, Name:name, MM:emacs_mode_menu) :<-
    "Convert name to mode-menu object"::
    (   get(@emacs_mode_menus, member, Name, MM)
    ->  true
    ;   get(@pce, convert, string('emacs_%s_mode', Name), class, Class),
        get(Class, name, ClassName),
        mode_menu_name(ClassName, MenuName),
        get(@emacs_mode_menus, member, MenuName, MM)
    ).


action_name(Name, Name) :-
    atomic(Name),
    !.
action_name(MenuItem, Name) :-
    get(MenuItem?value?print_name, value, Name).

locate_action(Chain, Action, Cell) :-
    action_name(Action, Name),
    get(Chain, find, message(@prolog, action_name, @arg1, Name), Cell).

append(MM, Name:name, Action:'name|menu_item', Before:[name]) :->
    "Append item for specified menu"::
    (   get(MM, value, Name, Chain)
    ->  true
    ;   send(MM, value, Name, new(Chain, chain))
    ),
    (   Action == -
    ->  send(Chain, append, Action)
    ;   locate_action(Chain, Action, Old)
    ->  send(Chain, replace, Old, Action)
    ;   send(Chain, append, Action),
        (   Before \== @default,
            locate_action(Chain, Before, CellValue),
            send(Chain, move_before, Action, CellValue)
        ->  true
        ;   true
        )
    ).

delete(MM, Menu:name, Action:name) :->
    "Delete item from inherited menu"::
    (   get(MM, value, Menu, Chain),
        send(Chain, delete, Action)
    ->  true
    ;   true
    ).

:- pce_end_class.


                 /*******************************
                 *         KEY-BINDINGS         *
                 *******************************/

:- pce_begin_class(emacs_key_binding, key_binding,
                   "Specialised key_binding for history").

key_binding_name(@default, @default) :- !.
key_binding_name(@nil, @nil) :- !.
key_binding_name(KB, Name) :-
    object(KB),
    get(KB, name, KBName),
    !,
    key_binding_name(KBName, Name).
key_binding_name(editor, editor) :- !.
key_binding_name(X, Internal) :-
    atom_concat('emacs$', X, Internal).


initialise(KB, Name:[name]*, Super:[key_binding]) :->
    default(Super, editor, S),
    key_binding_name(Name, IName),
    key_binding_name(S, IS),
    send(KB, send_super, initialise, IName, IS).

convert(_, IName:name, KB:emacs_key_binding) :<-
    "Handle mapped names"::
    key_binding_name(Name, IName),
    get(type(key_binding), convert, Name, KB).

lookup(_, Name:name, _Super:[key_binding], KB:emacs_key_binding) :<-
    "Find existing mappings"::
    key_binding_name(Name, IName),
    get(@key_bindings, member, IName, KB).

:- pce_group(execute).

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
These methods define  argument-filling  and   execution  from  arbitrary
methods from a keyboard command.  As  we   want  to  do  fairly advanced
prompting we need to do redefine some things from class key_binding.

First we check whether there is  need   for  prompting.  If so, we check
whether we use the miniwindow or  not.   The  miniwindow prompts for one
argument  at  a  time.  The  system  ->fill_arguments_and_execute  calls
<-interactive_argument on Receiver for each missing argument.

If we are in prompt mode we simply   use  ->noarg_call on the mode, just
like commands comming from the menus.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

fill_arguments_and_execute(KB, EvId:event_id, Receiver:emacs_mode,
                           Selector:name, Argv:any ...) :->
    "Open/close the argument processing"::
     Message =.. [ fill_arguments_and_execute,
                   EvId, Receiver, Selector | Argv],

    (   get(Receiver, send_method, Selector, tuple(_, Impl))
    ->  (   length(Argv, Before),
            First is Before + 1,
            args_available(First, Impl, KB, EvId)
        ->  send_super(KB, Message)                 % no need to prompt
        ;   get(Receiver, frame, Frame),
            send(Frame, has_get_method, prompt_style),
            get(Frame, prompt_style, mini_window)
        ->  send(@current_emacs_mode, assign, Receiver),
            send(Receiver, open_history, Impl, @on),
            send_super(KB, Message)                 % miniwindow
        ;   send(Receiver, noarg_call, Selector)    % prompting
        )
    ;   send_super(KB, Message)                     % generate error
    ).

%       args_available(+I, +Implementation, +KeyBinding, +EventId)
%
%       See whether all arguments are around that allow us to execute
%       the command without prompting.  See the implementation of
%       `key_binding->fill_arguments_and_execute' for reference.

args_available(N, Impl, KB, EvId) :-
    get(Impl, argument_type, N, ArgType),
    !,
    (   send(ArgType, includes, event_id)
    ;   send(ArgType, includes, char),
        integer(EvId)
    ;   send(ArgType, includes, int),
        get(KB, argument, Arg),
        integer(Arg)
    ;   send(ArgType, includes, default)
    ),
    !,
    NN is N + 1,
    args_available(NN, Impl, KB, EvId).
args_available(_, _, _, _).

execute(KB, Receiver:emacs_mode, Selector:name, Argv:any ...) :->
    "Push history if available"::
    (   get(Receiver, m_x_history, @nil)
    ->  true
    ;   VectorTerm =.. [code_vector|Argv], % do not create references!
        send(Receiver, close_history, new(VectorTerm))
    ),
    Message =.. [execute, Receiver, Selector | Argv],
    send_super(KB, Message).

:- pce_end_class.


                 /*******************************
                 *         ARGUMENT ITEM        *
                 *******************************/

:- pce_begin_class(emacs_argument_item, menu_item,
                   "Item with pullright for args").

initialise(I, Name:name, ValueSet:'chain|function') :->
    send(I, send_super, initialise, Name),
    send(I, popup,
         new(P, emacs_argument_popup(Name,
                                     message(@emacs_mode, arg_call,
                                             Name, @arg1)))),
    (   send(ValueSet, '_instance_of', chain)
    ->  send(P, members, ValueSet)
    ;   send(P, update_message,
             message(@receiver, members, ValueSet))
    ).

:- pce_end_class.


:- pce_begin_class(emacs_argument_popup, popup,
                   "Emacs mode menu pullright popup").

members(I, Members:chain) :->
    "->clear and attach new members (do not capitalise)"::
    get(Members, map,
        create(menu_item, @arg1, @default, @arg1?print_name),
        Items),
    send(I, send_super, members, Items).

:- pce_end_class.
