factor/basis/ui/tools/debugger/debugger.factor

! Copyright (C) 2006, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math models
colors.constants namespaces sequences words continuations
debugger prettyprint help editors fonts ui ui.commands
ui.debugger ui.gestures ui.gadgets ui.pens.solid
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.presentations ui.gadgets.panes
ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.borders ui.gadgets.status-bar
ui.tools.traceback ui.tools.inspector ui.tools.browser ;
IN: ui.tools.debugger

TUPLE: debugger < track error restarts restart-hook restart-list continuation ;

<PRIVATE

SINGLETON: restart-renderer

M: restart-renderer row-columns
    drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;

: <restart-list> ( debugger -- gadget )
    dup restarts>> f prefix <model> restart-renderer <table>
        [ [ \ continue-restart invoke-command ] when* ] >>action
        swap restart-hook>> >>hook
        t >>selection-required?
        t >>single-click? ; inline

: <error-pane> ( error -- pane )
    <pane> [ [ print-error ] with-pane ] keep ; inline

: <error-display> ( debugger -- gadget )
    [ <filled-pile> ] dip
    [ error>> <error-pane> add-gadget ]
    [
        dup restart-hook>> [
            [ "To continue, pick one of the options below:" <label> add-gadget ] dip
            restart-list>> add-gadget
        ] [ drop ] if
    ] bi ;

PRIVATE>

: <debugger> ( error continuation restarts restart-hook -- debugger )
    vertical debugger new-track
        { 3 3 } >>gap
        swap >>restart-hook
        swap >>restarts
        swap >>continuation
        swap >>error
        add-toolbar
        dup <restart-list> >>restart-list
        dup <error-display> f track-add
        COLOR: white <solid> >>interior ;

M: debugger focusable-child*
    dup restart-hook>> [ restart-list>> ] [ drop t ] if ;

: debugger-window ( error continuation -- )
    #! No restarts for the debugger window
    f f <debugger> "Error" open-status-window ;

GENERIC: error-in-debugger? ( error -- ? )

M: world-error error-in-debugger?
    world>> children>> [ f ] [ first debugger? ] if-empty ;

M: object error-in-debugger? drop f ;

[
    dup error-in-debugger?
    [ error-alert ] [ error-continuation get debugger-window ] if
] ui-error-hook set-global

debugger "gestures" f {
    { T{ button-down } request-focus }
} define-command-map

: com-inspect ( debugger -- ) error>> inspector ;

: com-traceback ( debugger -- ) continuation>> traceback-window ;

: com-help ( debugger -- ) error>> error-help-window ;

: com-edit ( debugger -- ) error>> edit-error ;

\ com-edit H{ { +listener+ t } } define-command

debugger "toolbar" f {
    { T{ key-down f { C+ } "i" } com-inspect }
    { T{ key-down f { C+ } "t" } com-traceback }
    { T{ key-down f { C+ } "h" } com-help }
    { T{ key-down f { C+ } "e" } com-edit }
} define-command-map