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

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org/packages/xpce/
    Copyright (c)  2001-2025, University of Amsterdam
                              VU University Amsterdam
                              SWI-Prolog Solutions b.v.
    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(prolog_gui,
          [ prolog_tracer/2,            % +Thread, -GUI
            tracer_gui/3,               % ?Thread, ?Break, ?GUI
            send_tracer/2,              % +Thread, :Goal
            send_if_tracer/2,           % +Thread, :Goal
            get_tracer/3,               % +Thread, :Goal, -Result
            send_tracer/1,              % :Goal
            send_if_tracer/1,           % :Goal
            get_tracer/2,               % :Goal, -Result
            in_debug_thread/2,          % +ObjOrThread, :Goal
            thread_debug_queue/2,       % +Thread, -Queue
            prolog_frame_attribute/4,   % +GUI, +Frame, +Attr, -Value
            prolog_choice_attribute/4,  % +GUI, +Choice, +Attr, -Value
            notify_gui/0,
            prolog_tracer/3             % +Thread, -Ref, +Create
          ]).
:- use_module(library(pce)).
:- use_module(library(lists)).
:- use_module(library(toolbar)).
:- use_module(library(pce_report)).
:- use_module(library(pce_util)).
:- use_module(library(persistent_frame)).
:- use_module(library(debug)).
:- if(exists_source(library(threadutil))).
:- use_module(library(threadutil)).
:- endif.
:- use_module(library(pprint)).
:- use_module(trace).
:- use_module(clause).
:- use_module(util).
:- use_module(source).
:- consult([ settings,
             stack,
             viewterm
           ]).
:- require([ make/0,
	     acyclic_term/1,
	     current_predicate/1,
	     notrace/1,
	     pce_image_directory/1,
	     portray_text/1,
             set_portray_text/3,
	     prolog_ide/1,
	     thread_self/1,
	     atomic_list_concat/2,
	     file_directory_name/2,
	     pce_help_file/2,
	     predicate_name/2,
	     prolog_listen/2,
	     prolog_unlisten/2,
	     string_codes/2,
	     term_attvars/2,
	     unify_with_occurs_check/2,
	     with_mutex/2,
	     '$factorize_term'/3,
	     '$get_predicate_attribute'/3,
	     absolute_file_name/3,
	     atomic_list_concat/3,
	     file_name_extension/3,
	     maplist/3,
	     numbervars/4,
             start_emacs/0
	   ]).

:- if(current_prolog_flag(threads, true)).
:- require([ message_queue_create/1,
	     message_queue_destroy/1,
	     thread_get_message/2,
	     thread_property/2,
	     thread_send_message/2,
	     thread_signal/2
           ]).
:- endif.

:- multifile
    user:message_hook/3.

:- meta_predicate
    in_debug_thread(+, 0),
    send_pce(0),
    send_pce_async(0).

register_directories :-
    (   member(SpyBase, ['icons/nospy', library('trace/icons/nospy')]),
        absolute_file_name(SpyBase,
                           [ extensions([png]), access(read)],
                           SpyIcon)
    ->  file_directory_name(SpyIcon, Icons),
        pce_image_directory(Icons)
    ),
    (   member(HlpBase, ['pltracer', library('trace/pltracer')]),
        absolute_file_name(HlpBase,
                           [ extensions([hlp]), access(read)],
                           HlpFile)
    ->  pce_help_file(pltracer, HlpFile)
    ).

:- register_directories.

version('2.0').

                 /*******************************
                 *            RESOURCES         *
                 *******************************/

resource(debug, image,  image('debug.png')).
resource(Name,  image,  image(PNG)) :-
    button(_, _, PNG, _),
    file_name_extension(Name, png, PNG).

                 /*******************************
                 *           TOPLEVEL           *
                 *******************************/

:- dynamic
    gui/3,                          % +Thread, +BreakLevel, -Gui
    notify/0.                       % see

%!  notify_gui
%
%   Notify changes.  Currently used for blocked background threads.

notify_gui :-
    asserta(notify, Ref),
    erase(Ref).

%!  prolog_tracer(+Thread, -Ref) is det.
%!  prolog_tracer(+Thread, -Ref, +Create) is semidet.
%
%   Get the Prolog debugger window for Thread.

prolog_tracer(Thread, Ref) :-
    prolog_tracer(Thread, Ref, true).

% (*) (Windows) we must start Emacs first because Emacs tries to setup a
% DDE   service   on   Windows,   but    send_pce/1   eventually   calls
% thread_get_message/2, which causes the  main  thread   to  block  on a
% condition variable using SleepConditionVariableCS(),   which  does not
% process Windows messages and sleeps for  15 seconds before continuing.
% In contrast, start_emacs/0 uses  in_pce_thread_sync/1   which  uses  a
% normal message loop to wait for xpce  to   do  its  job. Note that the
% debugger cannot use in_pce_thread_sync/1 because  it requires a method
% to wait that allows for callbacks.

prolog_tracer(Thread, Ref, Create) :-
    break_level(Level),
    (   gui(Thread, Level, Ref)
    ->  true
    ;   Create == true
    ->  debug(gtrace(gui),
              'New GUI for thread ~p, break level ~p', [Thread, Level]),
        start_emacs,		% see (*)
        send_pce(send(new(Ref, prolog_debugger(Level, Thread)), open))
    ).

%!  tracer_gui(?Thread, ?BreakLevel, ?GUI) is nondet.
%
%   True when GUI (an xpce object) is tracing Thread at BreakLevel.

tracer_gui(Thread, BreakLevel, GUI) :-
    gui(Thread, BreakLevel, GUI).

%!  break_level(-Level) is det.
%
%   Current break-level. Level is left unbound   if the caller is an
%   engine. In that case we  use  the   break  level  of  the client
%   thread.

break_level(Level) :-
    current_prolog_flag(break_level, Level),
    !.
break_level(_Level) :-
    thread_self(Me),
    thread_property(Me, engine(true)),
    !.
break_level(-1).                                % non-interactive thread.


%!  send_tracer(+ThreadOrGUI, +Term) is semidet.
%!  send_if_tracer(+Thread, +Term) is semidet.
%!  get_tracer(+Thread, +Term, -Reply) is semidet.
%
%   Send messages to the XPCE tracer window.
%
%   @param Thread: calling thread.

send_tracer(Term) :-
    notrace(send_tracer_(Term)).

send_tracer_(Term) :-
    thread_self_id(Thread),
    send_tracer(Thread, Term).

send_tracer(GUI, Term) :-
    object(GUI),
    !,
    send_pce(send(GUI, Term)).
send_tracer(Thread, Term) :-
    prolog_tracer(Thread, Ref),
    send_pce(send(Ref, Term)).

send_if_tracer(Term) :-
    thread_self_id(Thread),
    send_if_tracer(Thread, Term).
send_if_tracer(Thread, Term) :-
    (   prolog_tracer(Thread, Ref, false)
    ->  send_pce(send(Ref, Term))
    ;   true
    ).

get_tracer(Term, Result) :-
    thread_self_id(Thread),
    get_tracer(Thread, Term, Result).

get_tracer(GUI, Term, Result) :-
    object(GUI),
    !,
    get(GUI, Term, Result).
get_tracer(Thread, Term, Result) :-
    prolog_tracer(Thread, Ref),
    get(Ref, Term, Result).


                 /*******************************
                 *    THREAD SYNCHRONISATION    *
                 *******************************/

%!  thread_debug_queue(+Thread, -Queue) is det.
%
%   Queue is the debugging queue for Thread.  We do not use the main
%   queue to avoid interference with user-messages.

:- dynamic
    thread_debug_queue_store/2.

thread_debug_queue(Thread, Queue) :-
    with_mutex(debug_msg_queue,
               thread_debug_queue_locked(Thread, Queue)).

thread_debug_queue_locked(Thread, Queue) :-
    (   thread_debug_queue_store(Thread, Q)
    ->  Queue = Q
    ;   message_queue_create(Q),
        assert(thread_debug_queue_store(Thread, Q)),
        Queue = Q
    ).

:- initialization
    (   current_prolog_flag(threads, true)
    ->  prolog_unlisten(thread_exit, thread_finished),
        prolog_listen(thread_exit, thread_finished)
    ;   true
    ).

thread_finished(TID) :-
    destroy_thread_debug_gui(TID),
    forall(retract(thread_debug_queue_store(TID, Queue)),
           message_queue_destroy(Queue)).

msg_id(Id) :-
    with_mutex(debug_msg_id,
               msg_id_locked(Id)).

:- dynamic
    trace_msg_id/1.

msg_id_locked(Id) :-
    (   retract(trace_msg_id(Id0))
    ->  NId is Id0+1
    ;   NId = 1
    ),
    assert(trace_msg_id(NId)),
    Id = NId.


%!  send_pce(:Goal)
%
%   Run Goal in XPCE thread. Wait  for completion. In the meanwhile,
%   allow the XPCE thread to call in_debug_thread/1.

send_pce(Goal) :-
    thread_self_id(Me),
    pce_thread(Me),
    !,
    Goal.
send_pce(Goal) :-
    thread_self_id(Self),
    term_variables(Goal, GVars),
    msg_id(Id),
    in_pce_thread(run_pce(Goal, GVars, Self, Id)),
    thread_debug_queue(Self, Queue),
    repeat,
    thread_get_message(Queue, '$trace'(Result, Id2)),
    debug(gtrace(thread),
          ' ---> ~w: send_pce: result = ~p', [Id2, Result]),
    (   Result = call(CallBack, CBVars, Caller)
    ->  run_pce(CallBack, CBVars, Caller, Id2),
        fail
    ;   assertion(Id == Id2),
        (   Result = true(BGVars)
        ->  !, BGVars = GVars
        ;   Result == false
        ->  fail
        ;   Result = error(E)
        ->  throw(E)
        ;   assertion(false)
        )
    ).

run_pce(Goal, Vars, Caller, Id) :-
    debug(gtrace(thread), '~w: running ~p for thread ~p',
          [Id, Goal, Caller]),
    (   catch(Goal, Error, true)
    ->  (   var(Error)
        ->  Result = true(Vars)
        ;   Result = error(Error)
        )
    ;   Result = false
    ),
    debug(gtrace(thread), '~w: ok, returning ~p', [Id, Result]),
    thread_debug_queue(Caller, Queue),
    thread_send_message(Queue, '$trace'(Result, Id)).

%!  in_debug_thread(+Thread, :Goal) is semidet.
%!  in_debug_thread(+Object, :Goal) is semidet.
%
%   Run Goal in the thread  being   debugged.  The first argument is
%   either an XPCE object that is part  of the debugger window, or a
%   thread identifier.

in_debug_thread(Object, Goal) :-
    object(Object),
    !,
    get(Object, frame, Frame),
    get(Frame, thread, Thread),
    in_debug_thread(Thread, Goal).
in_debug_thread(Thread, Goal) :-
    thread_self_id(Thread),
    !,
    Goal,
    !.
in_debug_thread(Thread, Goal) :-
    thread_self_id(Self),
    msg_id(Id),
    debug(gtrace(thread), 'Call [Thread ~p] ~p', [Thread, Goal]),
    term_variables(Goal, GVars),
    thread_debug_queue(Thread, Queue),
    thread_send_message(Queue, '$trace'(call(Goal, GVars, Self), Id)),
    thread_debug_queue(Self, MyQueue),
    thread_get_message(MyQueue, '$trace'(Result, Id)),
    debug(gtrace(thread),
          ' ---> in_debug_thread: result = ~p', [Result]),
    (   Result = error(E)
    ->  throw(E)
    ;   Result = true(BGVars)
    ->  GVars = BGVars
    ).


%!  send_pce_async(:Goal) is det.
%
%   Send to the debug thread asynchronously.

send_pce_async(Goal) :-
    thread_self_id(Me),
    pce_thread(Me),
    !,
    Goal.
send_pce_async(Goal) :-
    in_pce_thread(Goal).


%!  prolog_frame_attribute(+GUI, +Frame, +Attribute, -Value) is det.
%!  prolog_frame_attribute(+Thread, +Frame, +Attribute, -Value) is det.
%
%   As prolog_frame_attribute/3, but calling in the thread debugged
%   by GUI.

prolog_frame_attribute(Thread, Frame, Attribute, Value) :-
    in_debug_thread(Thread,
                    prolog_frame_attribute(Frame, Attribute, Value)).

prolog_choice_attribute(GUI, Choice, Attribute, Value) :-
    in_debug_thread(GUI,
                    prolog_choice_attribute(Choice, Attribute, Value)).



                 /*******************************
                 *     DEBUGGER APPLICATION     *
                 *******************************/

:- pce_global(@prolog_gui, new(prolog_gui)).

:- pce_begin_class(prolog_gui, application,
                   "Toplevel driver for the Prolog GUI").

initialise(App) :->
    send_super(App, initialise, 'Prolog Debugger GUI'),
    send(App, kind, service).       % Do not debug in this

:- pce_end_class.


                 /*******************************
                 *         DEBUGGER FRAME       *
                 *******************************/

:- pce_begin_class(prolog_debugger, persistent_frame,
                   "Toplevel driver for the debugger").

variable(source,        any,            both, "Source view").
variable(break_level,   int,            get,  "Break-level I'm associated to").
variable(thread,        'int|name*',    get,  "Associated thread").
variable(trap_frame,    int*,           get,  "Last trapped frame").
variable(trap_port,     name*,          get,  "Last trapped port").
variable(current_frame, int*,           both, "The most recent frame").
variable(quitted,       bool := @off,   both, "Asked to quit").
variable(mode,          name := created,get,  "Current mode").

running_in_pce_thread :-
    pce_thread(Pce), thread_self_id(Pce).

initialise(F, Level:int, Thread:'int|name') :->
    assertion(running_in_pce_thread),
    send(F, slot, break_level, Level),
    send(F, slot, thread, Thread),
    send_super(F, initialise, 'SWI-Prolog debugger',
               application := @prolog_gui),
    send(F, icon, resource(debug)),
    send(F, done_message, message(F, quit)),
    send(F, append, new(MBD, dialog)),
    send(MBD, gap, size(0, 2)),
    send(MBD, pen, 0),
    send(MBD, append, new(menu_bar)),
    send(MBD, name, menu_bar_dialog),
    send(MBD, resize_message, message(MBD, layout, @arg2)),
    send(F, fill_menu_bar),
    send(new(D, prolog_button_dialog), below, MBD),
    send(D, name, buttons),

    new(V, prolog_bindings_view),
    send(V, label, 'Bindings'),
    send(V, name, bindings),
    send(new(S, prolog_stack_view), right, V),
    send(V, below, D),
    send(new(Src, prolog_source_view), below, V),
    send(F, source, Src),
    send(new(RD, report_dialog), below, Src),
    send(RD, warning_delay, 0),
    send(S, label, 'Call Stack'),
    send(S, name, stack),
    ignore(send(F, frame_finished, 0)),     % FR_WATCHED issue
    asserta(gui(Thread, Level, F)).

unlink(F) :->
    retractall(gui(_, _, F)),
    clear_clause_info_cache,        % safety first
    send_super(F, unlink).

quit(F) :->
    "User initiated quit"::
    (   (   get(F, mode, thread_finished)
        ;   get(F, mode, query_finished)
        ;   get(F, mode, aborted)
        ;   get(F, mode, replied)
        )
    ->  send(F, destroy)
    ;   get(F, tracer_quitted, Action),
        (   Action == cancel
        ->  true
        ;   send(F, return, Action)
        )
    ).

label(F, Label:char_array) :->
    "Set label, indicating associated thread"::
    get(F, thread, Thread),
    (   Thread == main
    ->  send_super(F, label, Label)
    ;   send_super(F, label, string('[Thread %s] %s', Thread, Label))
    ).

clear_stack_window(F) :->
    "Clear the stack window"::
    get(F, member, stack, StackView),
    send(StackView, clear).

clear(F, Content:[bool]) :->
    "Deactivate all views"::
    ignore(send(F, send_hyper, fragment, free)),
    get(F, member, stack, StackView),
    send(StackView, clear),
    get(F, member, bindings, BindingView),
    send(BindingView, clear, Content).


fill_menu_bar(F) :->
    get(F, member, menu_bar_dialog, MBD),
    get(MBD, member, menu_bar, MB),
    send(MB, append, new(Tool, popup(tool))),
    send(MB, append, new(Edit, popup(edit))),
    send(MB, append, new(View, popup(view))),
    send(MB, append, new(Comp, popup(compile))),
    send(MB, append, new(Help, popup(help)), right),
    send_list(Tool, append,
              [ menu_item(settings,
                          message(F, settings),
                          end_group := @on),
                menu_item(clear_source_cache,
                          message(@prolog, clear_clause_info_cache),
                          end_group := @on),
                menu_item(quit,
                          message(F, quit))
              ]),
    send_list(Edit, append,
              [ menu_item(breakpoints,
                          message(F, breakpoints)),
                menu_item(exceptions,
                          message(F, exceptions),
                          end_group := @on),
                menu_item(toggle_edit_mode,
                          message(F, edit),
                          end_group := @on),
                menu_item(copy_goal,
                          message(F, copy_goal))
              ]),
    send_list(View, append,
              [ menu_item(threads,
                          message(F, show_threads)),
                new(PT, menu_item(portray_code_lists,
                                  message(F, portray_text)))
              ]),
    send_list(Comp, append,
              [ menu_item(make,
                          message(F, make),
                          end_group := @on)
              ]),
    send_list(Help, append,
              [ menu_item(about,
                          message(F, about)),
                menu_item(help_on_debugger,
                          message(F, help),
                          end_group := @on),
                menu_item(prolog_manual,
                          message(@prolog, prolog_help)),
                menu_item('XPCE manual',
                          message(@prolog, manpce))
              ]),
    send(View, show_current, @on),
    send(View, multiple_selection, @on),
    send(PT, condition, message(F, update_portray_text, PT)).

settings(_F) :->
    "Edit the preferences"::
    trace_settings.


about(F) :->
    "Display aout message"::
    version(Version),
    send(@display, inform, F, "GUI Tracer",
         'SWI-Prolog debugger version %s\n\c
              By Jan Wielemaker',
         Version).

help(_) :->
    "Show window with help-text"::
    send(@helper, give_help, pltracer, main).

show_frame(GUI, Frame:int, PC:prolog) :->
    "Show the variables of this frame"::
    (   get(GUI, trap_frame, Frame)         % the initial trapped port
    ->  get(GUI, trap_port, Style)
    ;   PC = choice(_)                      % A choice-point
    ->  Style = choice
    ;   Style = frame                       % Somewhere up the stack
    ),
    prolog_show_frame(Frame, [ gui(GUI), pc(PC),
                               source, bindings,
                               style(Style)
                             ]).

show_stack(GUI, CallFrames:prolog, ChoiceFrames:prolog) :->
    "Show the stack and choicepoints"::
    get(GUI, member, stack, StackWindow),
    send(StackWindow, clear),
    display_stack(StackWindow, CallFrames, ChoiceFrames).

show_threads(_GUI) :->
    "Open Thread monitor"::
    prolog_ide(thread_monitor).

portray_text(GUI) :->
    "Toggle portray of text"::
    portraying_text(Old),
    negate(Old, New),
    portray_text(New),
    send(GUI, refresh_bindings),
    send(GUI, report, status, 'Portray code-list as text: %s', New).

negate(true, false).
negate(false, true).

update_portray_text(_GUI, MI:menu_item) :->
    "Update selected of portray text item"::
    portraying_text(Bool),
    send(MI, selected, Bool).

%!  portraying_text(-Bool) is det.
%
%   Whether or not portraying text is enabled. The first checks that the
%   library is loaded.

portraying_text(Bool) :-
    current_predicate(portray_text:set_portray_text/3),
    !,
    set_portray_text(enabled, Bool, Bool).
portraying_text(false).

trapped_location(GUI, StartFrame:int, Frame:int, Port:name) :->
    "The last trapped location"::
    send(GUI, slot, trap_frame, Frame),
    send(GUI, slot, trap_port, Port),
    send(GUI, current_frame, StartFrame).

refresh_bindings(GUI) :->
    "Refresch the binding view after changing parameters"::
    (   get(GUI, member, bindings, Bindings),
        get(Bindings, prolog_frame, Frame),
        Frame \== @nil
    ->  prolog_show_frame(Frame, [ gui(GUI),
                                   bindings
                                 ])
    ;   true
    ).


                 /*******************************
                 *            EVENT             *
                 *******************************/

source_typed(Frame, Typed:event_id) :->
    "Forward a typing event to the button-dialog"::
    get(Frame, member, buttons, Dialog),
    send(Dialog, typed, Typed).


                 /*******************************
                 *           ACTIONS            *
                 *******************************/

window_pos_for_button(F, ButtonName:name, Pos:point) :<-
    "Return position for transient window reacting on Button"::
    get(F, member, buttons, Dialog),
    get(Dialog, button, ButtonName, Button),
    get(Button, display_position, ButtonPos),
    get(ButtonPos, plus, point(0, 25), Pos).

prepare_action(Frame) :->
    "Prepare for reading an action"::
    send(Frame, open),              % make sure
    get(Frame, display, Display),
    send(Display, busy_cursor, @nil),
    send(Frame, mode, wait_user).

action(Frame, Action:name) :<-
    "Wait for the user to return an action"::
    send(Frame, prepare_action),
    get(Frame, confirm, Action),
    (   get(Frame, quitted, @on)
    ->  send(Frame, destroy)
    ;   true
    ).

return(Frame, Result:any) :->
    "Return user action"::
    (   get(Frame, mode, wait_user)
    ->  get(Frame, thread, Thread),
        send(Frame, mode, replied),
        (   pce_thread(Thread)
        ->  send_super(Frame, return, Result)
        ;   (   get(Frame, quitted, @on)
            ->  send(Frame, destroy)
            ;   true
            ),
            debug(gtrace(thread),
                  ' ---> frame for thread = ~p: result = ~p',
                  [Thread, Result]),
            thread_debug_queue(Thread, Queue),
            thread_send_message(Queue, '$trace'(action(Result), action))
        )
    ;   get(Frame, quitted, @on)
    ->  send(Frame, destroy)
    ;   send(Frame, report, warning, 'Not waiting')
    ).

%!  tracer_quitted(+Thread, -Action) is semidet.
%
%   Ask the user what to  do  after   a  user-initiated  quit of the
%   debugger.

tracer_quitted(Frame, Action) :<-
    "Confirm user requested quit"::
    get(Frame, thread, Thread),
    (   Thread == main
    ->  Label = 'Tracer quitted'
    ;   Label = string('[Thread %s] Tracer quitted', Thread)
    ),
    new(D, dialog(Label)),
    send(D, application, @prolog_gui),
    send(D, append,
         button(continue_without_debugging,
                message(D, return, nodebug))),
    send(D, append,
         button(abort,
                message(D, return, abort))),
    (   Thread == main
    ->  send(D, append,
             button(exit_prolog,
                    message(D, return, halt)))
    ;   true
    ),
    send(D, append,
         button(cancel,
                message(D, return, cancel))),
    send(D, transient_for, Frame),
    send(D, modal, transient),
    get(D, confirm_centered, Frame?area?center, Action),
    send(D, destroy),
    (   Action == cancel
    ->  true
    ;   send(Frame, quitted, @on)
    ).


selected_frame(F, Frame:int) :<-
    "Prolog frame selected by user in stack window"::
    get(F, member, stack, Browser),
    get(Browser, selection, Frame).


                 /*******************************
                 *  ACTIONS OF THE SOURCE VIEW  *
                 *******************************/

:- pce_group(actions).

edit(F) :->
    "(Toggle) Edit-mode of source-window"::
    send(F?source, edit).

breakpoints(_F) :->
    "Edit spy/break/trace-points"::
    prolog_ide(open_debug_status).

exceptions(_F) :->
    "Edit exceptions"::
    prolog_ide(open_exceptions).

make(_) :->
    "Run Prolog make"::
    (   object(@emacs)
    ->  send(@emacs, save_some_buffers)
    ;   true
    ),
    make.

goal(F, Goal:prolog) :<-
    "Return qualitied term for selected frame"::
    get(F, selected_frame, Frame),
    prolog_frame_attribute(F, Frame, goal, Goal0),
    (   Goal0 = _:_
    ->  Goal = Goal0
    ;   Goal = user:Goal0
    ).

nostop_or_spy(F) :->
    "Clear break- or spy-point"::
    (   send(F?source, delete_selected_stop)
    ->  true
    ;   (   get(F, current_frame, Frame)
        ;   get(F, selected_frame, Frame)
        ),
        Frame \== @nil,
        prolog_frame_attribute(F, Frame, goal, Goal0),
        (   Goal0 = _:_
        ->  Goal = Goal0
        ;   Goal = user:Goal0
        ),
        '$get_predicate_attribute'(Goal, spy, 1)
    ->  nospy(Goal),
        predicate_name(Goal, Pred),
        send(F, report, warning,
             'Removed spy-point for %s', Pred)
    ;   send(F, report, warning,
             'No selected break or current spy-point')
    ).

browse(_F) :->
    "Provides overview for edit/spy/break"::
    prolog_ide(open_navigator).

stop_at(F) :->
    "Set stop at caret"::
    get(F, source, SourceWindow),
    send(SourceWindow, stop_at).

up(F) :->
    "Select child frame"::
    get(F, member, stack, Stack),
    send(Stack, up).

down(F) :->
    "Select parent frame"::
    get(F, member, stack, Stack),
    send(Stack, down).

details(F) :->
    "Show (variable) details"::
    get(F, member, bindings, Bindings),
    send(Bindings, details).

nodebug(F) :->
    "User hit n(odebug)"::
    (   setting(auto_close, true)
    ->  send(F, quitted, @on)
    ;   true
    ),
    send(F, return, nodebug).

abort(F) :->
    "User hit a(bort)"::
    (   setting(auto_close, true)
    ->  send(F, quitted, @on)
    ;   true
    ),
    send(F, return, abort).

interrupt(F) :->
    "User hit t (interrupt, trace)"::
    get(F, thread, Thread),
    thread_signal(Thread, trace).

query(F) :->
    "Enter and run a query"::
    send(F, check_console),
    send(F, report, status,
         'Started toplevel in console.  Type Control-D to resume debugging'),
    in_debug_thread(F, prolog),
    send(F, report, status,
         'Toplevel has terminated; resuming debugger').

check_console(F) :->
    "See whether the debugged thread has a console"::
    (   in_debug_thread(F, thread_has_console)
    ->  true
    ;   send(@display, inform, F, "GUI Tracer",
             'The debugged thread is not attached to a console.\n\c
                  Cannot run an interactive session in the debuggee.'),
        fail
    ).

interactor(_F) :->
    "Open a new interactor"::
    prolog_ide(open_interactor).

copy_goal(F) :->
    "Copy the current goal into the copy-buffer"::
    get(F, selected_frame, Frame),
    (   Frame \== @nil
    ->  true
    ;   send(F, report, warning, 'No current frame'),
        fail
    ),
    prolog_frame_attribute(F, Frame, goal, Goal),
    prolog_frame_attribute(F, Frame, predicate_indicator, PI),
    (   numbervars(Goal, 0, _, [attvar(skip)]),
        format(string(Text), '~q', [Goal]),
        send(@display, copy, Text),
        fail
    ;   true
    ),
    format(atom(PIA), '~q', [PI]),
    send(F, report, inform, 'Copied goal (%s) to clipboard', PIA).

:- pce_group(delegate).

file(F, File:'name|emacs_buffer*') :->
    "Attach to indicated file"::
    send(F?source, source, File).

show_range(F, File:'name|text_buffer', From:int, To:int, Style:name) :->
    "Show indicated region using Style"::
    send(F?source, show_range, File, From, To, Style).

show_line(F, File:'name|text_buffer', Line:int, Style:name) :->
    "Show numbered line"::
    send(F?source, show_line, File, Line, Style).

listing(F, Module:name, Predicate:name, Arity:int) :->
    "List the specified predicate"::
    send(F?source, listing, Module, Predicate, Arity).

/* NOTE: lazy creation of this message interferes with call_cleanup/2 used
   by findall/3 from XPCE's lazy  method   binder.  Therefore  we make a
   dummy call to this method in ->initialise.
*/

frame_finished(F, Frame:int) :->
    "This frame was terminated; remove it"::
    get(F, member, stack, StackView),
    send(StackView, frame_finished, Frame),
    (   get(F, member, bindings, Bindings),
        get(Bindings, prolog_frame, Frame)
    ->  send(Bindings, background,
             ?(Bindings, class_variable_value, background_inactive)),
        send(Bindings, slot, prolog_frame, @nil),
        ignore(send(F, send_hyper, fragment, free))
    ;   true
    ),
    (   get(F, current_frame, Frame)
    ->  send(F, current_frame, @nil)
    ;   true
    ).

aborted(F) :->
    "User has aborted the query"::
    send(F, clear, @off),
    send(F, mode, aborted),
    send(F, report, status, 'Execution aborted').

thread_finished(F, Status:prolog) :->
    "Thread I'm associated with finished"::
    send(F, clear),
    send(F, mode, thread_finished),
    format(string(String), '~q', Status),
    send(F, report, status, 'Thread finished: %s', String).

query_finished(F, Message:char_array) :->
    "Toplevel query finished"::
    send(F, clear),
    send(F, mode, query_finished),
    send(F, report, status, Message).

mode(F, Mode:name) :->
    "Switch modes"::
    send(F, slot, mode, Mode),
    (   get(F, member, buttons, D)
    ->  (   Mode == wait_user
        ->  send(D, running, @off)
        ;   send(D, running, @on)
        )
    ;   true
    ).

:- pce_end_class(prolog_debugger).

                 /*******************************
                 *            BUTTONS           *
                 *******************************/

:- pce_begin_class(prolog_button_dialog, dialog,
                   "Dialog holding the function buttons").

%       button(Action, Keys, Image, Balloon)
%
%       If action is +Action, send message Action to the frame.  Otherwise
%       return Action to the caller.

button(into,           "i",   'into.png',            'Show unification').
button(creep,          "\n ", 'creep.png',           'Step').
button(skip,           "s",   'skip.png',            'Skip over this goal').
button(finish,         "f",   'finish.png',          'Finish selected goal').
button(gap,            -,     -,                     -).
button(retry,          "r",   'retry.png',           'Retry selected goal').
button(gap,            -,     -,                     -).
button(+nodebug,       "n",   'nodebug.png',         'Continue without debugging').
button(+abort,         "a",   'abort.png',           'Abort to the Prolog toplevel').
button(+interrupt,     "t",   'interrupt.png',       'Interrupt (trace)').
button(+interactor,    "B",   'interactor.png',      'Open new console').
button(fail,           "F",   'fail.png',            'Force query to fail').
button(gap,            -,     -,                     -).
button(+up,            "u",   'up.png',              'Select parent frame').
button(+down,          "d",   'down.png',            'Select child frame').
button(gap,            -,     -,                     -).
button(+browse,        "",    '16x16/butterfly.png', 'Browse program structure').
button(gap,            -,     -,                     -).
button(leap,           "l",   'leap.png',            'Continue to spy- or breakpoint').
button(+breakpoints,   "+",   'spy.png',             'Edit spy- and breakpoints').
button(+stop_at,       "!",   'stop.png',            'Set Stop at caret').
button(+nostop_or_spy, "-",   'nostopspy.png',       'Delete break- or spy-point').
button(gap,            -,     -,                     -).
button(+details,       "v",   'details.png',         'Show (variable) details').
button(+edit,          "e",   'edit.png',            'Toggle read-only/edit-mode').


tag_balloon(Balloon0, Keys, Balloon) :-
    maplist(key_name, Keys, Names),
    atomic_list_concat(Names, ', ', Tag),
    atomic_list_concat([Balloon0, ' (', Tag, ')'], Balloon).

key_name(10, return) :- !.
key_name(32,  space) :- !.
key_name(C, A) :-
    char_code(A, C).

initialise(D) :->
    send_super(D, initialise),
    send(D, pen, 0),
    send(D, gap, size(0,0)),
    get(D, frame, Frame),
    send(D, append, new(TB, tool_bar(Frame))),
    (   button(Action, KeyString, Image, Balloon0),
        file_name_extension(Resource, _, Image),
        string_codes(KeyString, Keys),
        (   Action == gap
        ->  send(TB, append, gap)
        ;   tag_balloon(Balloon0, Keys, Balloon),
            make_message(Action, Name, D, Message),
            send(TB, append,
                 new(B, tool_button(Message,
                                    resource(Resource),
                                    Balloon,
                                    name := Name))),
            chain_list(KL, Keys),
            send(B, attribute, keys, KL)
        ),
        fail
    ;   true
    ).

make_message(+Action, Action, D, message(D?frame, Action)) :- !.
make_message(Action,  Action, D, message(D, return, Action)).

typed(D, Id:event_id, Delegate:[bool]) :->
    "Handle typing"::
    (   get(D, find, @default,
            and(message(@arg1, has_get_method, keys),
                message(@arg1?keys, member, Id)),
            Button)
    ->  send(Button, execute)
    ;   Delegate == @on
    ->  send_super(D, typed, Id, Delegate)
    ).

event(D, Ev:event) :->
    (   send(Ev, is_a, keyboard)
    ->  send(D, typed, Ev)
    ;   send_super(D, event, Ev)
    ).

button(D, Name:name, Button:button) :<-
    "Find button from its name"::
    get(D, member, tool_bar, TB),
    get(TB, member, Name, Button).

running(D, Running:bool) :->
    "Make some buttons (in)active"::
    get(Running, negate, NotRunning),
    forall(running_button(Name),
           (   get(D, button, Name, Button)
           ->  send(Button, active, NotRunning)
           ;   format('No button ~w~n', [Name])
           )),
    (   get(D, button, interrupt, Interrupt)
    ->  send(Interrupt, active, Running)
    ;   true
    ).

running_button(into).
running_button(creep).
running_button(skip).
running_button(retry).
running_button(finish).
running_button(nodebug).
running_button(abort).

:- pce_end_class(prolog_button_dialog).


                 /*******************************
                 *           VARIABLES          *
                 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
We use a view with some tweaks   to  display the bindings. Originally we
used a browser, but a view has  two   advantages.  First  of all, we can
write directly to it by opening it as   a stream and second the user can
use search and selection on the view to   analyse it or export text from
it.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- pce_begin_class(prolog_bindings_view, view,
                   "Overview of bindings of the current frame").

class_variable(font,    font,   normal, "Font for bindings").
class_variable(size,    size,   size(40,11), "Initial size").

variable(prolog_frame, int*, both, "Frame who's variables we are showing").

class_variable(background_active,   colour, white).
class_variable(background_inactive, colour, grey80).

:- pce_global(@prolog_binding_recogniser,
              make_prolog_binding_recogniser).
:- pce_global(@prolog_binding_popup,
              make_prolog_binding_popup).

make_prolog_binding_recogniser(G) :-
    new(View, @event?window),
    new(Index, ?(@event?receiver, index, @event)),
    new(C1, click_gesture(left, '', single,
                          message(View, on_click, Index))),
    new(C2, click_gesture(left, '', double,
                          message(View, details))),
    new(C3, popup_gesture(@prolog_binding_popup)),
    send(@prolog_binding_popup, update_message,
         message(View, on_click, Index)),
    new(G, handler_group(C1, C2, C3)).

make_prolog_binding_popup(P) :-
    new(P, popup),
    send_list(P, append,
              [ menu_item(details, message(@arg1?window, details)),
                menu_item(copy,    message(@arg1?window, details,
                                           @default, copy))
              ]).

initialise(B) :->
    send_super(B, initialise),
    send(B?text_buffer, undo_buffer_size, 0),
    get(B, font, Font),
    get(Font, ex, Ex),
    Tab is 15 * Ex,
    send(B, wrap, none),
    send(B?image, tab_stops, vector(Tab)),
    send(B?image, recogniser, @prolog_binding_recogniser),
    send(B, editable, @off),
    send(B, style, constraint, style(colour := blue)),
    send(B?text_cursor, displayed, @off),
    send(B, ver_stretch, 0).

clear(B, Content:[bool]) :->
    send(B, prolog_frame, @nil),
    (   Content == @off
    ->  send(B, background, ?(B, class_variable_value, background_inactive))
    ;   send_super(B, clear)
    ).

scroll_to_end(B) :->
    "Scroll the last line to the bottom"::
    get(B, editor, E),
    get(E, size, size(_,Lines)),
    send(E, scroll_to, @default, Lines).

details(B, Fragment:[prolog_frame_var_fragment], Action:[{view,copy}]) :->
    "View details of the binding"::
    get(B, prolog_frame, Frame),
    (   Frame \== @nil
    ->  true
    ;   send(B, report, warning, 'No current frame'),
        fail
    ),
    (   Fragment == @default
    ->  (   get(B, selected_fragment, Frag),
            Frag \== @nil
        ->  true
        ;   send(B, report, warning, 'No selected variable'),
            fail
        )
    ;   Frag = Fragment
    ),
    (   get(Frag, var_name, VarName)
    ->  get(Frag, value, Value),
        prolog_frame_attribute(B, Frame, level, Level),
        prolog_frame_attribute(B, Frame, goal, Goal),
        predicate_name(Goal, PredName),
        (   send(Frag, instance_of, prolog_frame_constraint_fragment)
        ->  VarType = ''
        ;   integer(VarName)
        ->  VarType = 'Argument'
        ;   VarType = 'Variable'
        ),
        format(string(Label), '~w ~w of frame at level ~d running ~w',
               [ VarType, VarName, Level, PredName ]),
        debug(gtrace(bindings), 'Action ~w on ~w', [Action, Value]),
        (   Action == copy
        ->  (   numbervars(Value, 0, _, [attvar(skip)]),
                format(string(Text), '~q', [Value]),
                send(@display, copy, Text),
                fail
            ;   send(B, report, status, Label)
            )
        ;   view_term(Value,
                      [ comment(Label),
                        source_object(Frag),
                        expose(true)
                      ])
        )
    ;   send(B, report, warning, 'Not a variable value')
    ).

on_click(B, Index:int) :->
    "Select fragment clicked"::
    get(B, text_buffer, TB),
    send(B, selection, Index, Index),           % do not move
    (   get(TB, find_fragment, message(@arg1, overlap, Index), Frag)
    ->  send(B, selected_fragment, Frag)
    ;   send(B, selected_fragment, @nil)
    ).

% Bindings is a list of Vars = Value,   where Vars is a list of variable
% identifiers that take the form Name:ArgN,   were  Name is the variable
% name (atom) and ArgN is the location in the frame.

bindings(B, Bindings:prolog) :->
    "Display complete list of bindings"::
    (   term_attvars(Bindings, [])
    ->  Plain = Bindings,
        Constraints = []
    ;   copy_term(Bindings, Plain, Constraints)
    ),
    debug(gtrace(bindings), 'Plain = ~p, Constraints = ~p', [Plain, Constraints]),
    bind_vars(Plain),
    cycles(Plain, Template, Cycles, Plain),
    send(B, background, ?(B, class_variable_value, background_active)),
    pce_open(B, write, Fd),
    (   forall(member(Vars=Value, Template),
               send(B, append_binding, Vars, value(Value), Fd)),
        forall(member(C, Constraints),
               send(B, append_extra, C, Fd, constraint)),
        forall(member(C, Cycles),
               send(B, append_extra, C, Fd, cycle)),
        fail
    ;   true
    ),
    close(Fd),
    send(B, scroll_to_end).

bind_vars([]).
bind_vars([Vars=Value|T]) :-
    (   var(Value)
    ->  (   Vars = [Name:_|_]       % clustered
        ->  Value = '$VAR'(Name)
        ;   Vars = Name:_           % non-clustered
        ->  Value = '$VAR'(Name)
        )
    ;   true
    ),
    bind_vars(T).

cycles(Term, Template, Cycles, _) :-
    acyclic_term(Term),
    !,
    Template = Term,
    Cycles = [].
cycles(Term, Template, Cycles, Bindings) :-
    '$factorize_term'(Term, Template, Factors),
    bind_non_cycles(Factors, Cycles),
    name_cycle_vars(Cycles, 1, Bindings).

bind_non_cycles([], []).
bind_non_cycles([V=Term|T], L) :-
    unify_with_occurs_check(V, Term),
    !,
    bind_non_cycles(T, L).
bind_non_cycles([H|T0], [H|T]) :-
    bind_non_cycles(T0, T).


name_cycle_vars([], _, _).
name_cycle_vars([H|T], I, Bindings) :-
    H = (Var=_Value),
    (   member(Vars=VarsValue, Bindings),
        VarsValue == Var,
        Vars = [Name:_|_]
    ->  I2 = I
    ;   atom_concat('_S', I, Name),
        I2 is I + 1
    ),
    Var = '$VAR'(Name),
    name_cycle_vars(T, I2, Bindings).


append_binding(B, Names0:prolog, ValueTerm:prolog, Fd:prolog) :->
    "Add a binding to the browser"::
    ValueTerm = value(Value0),      % protect :=, ?, etc.
    (   Value0 = '$VAR'(Name),
        (   Names0 = [Name:_]
        ;   Names0 = Name:_
        )
    ->  (   setting(show_unbound, false)
        ->  true
        ;   format(Fd, '~w\t= _~n', [Name])
        )
    ;   (   Value0 = '$VAR'(_), Names0 = [_,_|_]
        ->  append(Names, [VarN:_], Names0),
            Value = '$VAR'(VarN)
        ;   Names = Names0,
            Value = Value0
        ),
        get(B, text_buffer, TB),
        get(TB, size, S0),
        (   Names = VarName:ArgN
        ->  format(Fd, '~w', [VarName])
        ;   Names = [VarName:ArgN|_],
            write_varnames(Fd, Names)
        ),
        current_prolog_flag(answer_write_options, Options),
        format(Fd, '\t= ~W~n', [Value, Options]),
        flush_output(Fd),
        get(TB, size, S1),
        new(_, prolog_frame_var_fragment(TB, S0, S1, VarName, ArgN))
    ).

write_varnames(Fd, [N:_]) :-
    !,
    format(Fd, '~w', N).
write_varnames(Fd, [N:_|T]) :-
    format(Fd, '~w = ', N),
    write_varnames(Fd, T).

append_extra(B, Constraint:prolog, Fd:prolog, Comment:name) :->
    "Display current constraints"::
    get(B, text_buffer, TB),
    current_prolog_flag(answer_write_options, Options),
    get(TB, size, S0),
    format(Fd, '(~w)\t~W~n', [Comment, Constraint, Options]),
    flush_output(Fd),
    get(TB, size, S1),
    new(_, prolog_frame_constraint_fragment(TB, S0, S1, Comment, Constraint)).

:- pce_end_class(prolog_bindings_view).


:- pce_begin_class(prolog_frame_var_fragment, fragment,
                   "Represent a variable in a frame").

variable(var_name, name, get, "Name of displayed variable").
variable(argn,     int,  get, "Slot in frame").

initialise(F, TB:text_buffer, From:int, To:int, Name:name, ArgN:int) :->
    Len is To-From,
    send_super(F, initialise, TB, From, Len, frame),
    send(F, slot, var_name, Name),
    send(F, slot, argn, ArgN).

%       Issue: this copies really big values

value(F, Value:prolog) :<-
    "Get current value of the variable"::
    get(F, text_buffer, TB),
    get(TB?editors, head, Editor),
    get(Editor, window, View),
    get(View, prolog_frame, Frame), Frame \== @nil,
    get(F, argn, ArgN),
    prolog_frame_attribute(F, Frame, argument(ArgN), Value).

:- pce_end_class(prolog_frame_var_fragment).


:- pce_begin_class(prolog_frame_constraint_fragment, fragment,
                   "Represent a contraint on a frame").

variable(var_name, name,   get, "Comment annotation").
variable(value,    prolog, get, "Displayed term").

initialise(F, TB:text_buffer, From:int, To:int, Name, Term:prolog) :->
    Len is To-From,
    send_super(F, initialise, TB, From, Len, constraint),
    send(F, slot, var_name, Name),
    term_size(Term, Size),
    (   Size < 100_000
    ->  send(F, slot, value, Term)
    ;   send(F, slot, value, 'Term is too large')
    ).

:- pce_end_class(prolog_frame_constraint_fragment).


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

:- initialization
    prolog_unlisten(frame_finished, frame_finished),
    prolog_listen(frame_finished, frame_finished).

frame_finished(Frame) :-
    thread_self_id(Thread),
    gui(Thread, _, Gui),            % has a gui
    send_pce_async(send(Gui, frame_finished(Frame))).

destroy_thread_debug_gui(Thread) :-
    (   gui(Thread, _, Gui)
    ->  thread_property(Thread, status(Status)),
        send_pce_async(send(Gui, thread_finished(Status)))
    ;   true
    ).

:- multifile prolog:message_action/2.

prolog:message_action:message_hook(unwind(abort), _) :-
    aborted.
prolog:message_action(query(YesNo), _) :-
    query_finished(YesNo).
prolog:message_action(break(end, Level), _) :-
    thread_self_id(Thread),
    gui(Thread, Level, Gui),
    send_pce_async(send(Gui, destroy)).

aborted :-
    thread_self_id(Thread),
    gui(Thread, Level, Gui),
    (   Level \== 0
    ->  Message = destroy
    ;   Message = aborted
    ),
    send_pce_async(send(Gui, Message)).

query_finished(YesNo) :-
    finished(YesNo, Message),
    thread_self_id(Thread),
    break_level(Level),
    gui(Thread, Level, Gui),
    send_pce_async(send(Gui, query_finished(Message))).

finished(no, 'Query failed').
finished(yes, 'Query succeeded').
finished(done, 'User ended query').
finished(yes(_), 'Query succeeded with result').
finished(more(_), 'Query succeeded non-deterministically with result').
