Rework listener's debugger-popup code
Slava Pestov
parent
3ac409e432
commit
cf4e0d78c3
|
|
@ -54,7 +54,10 @@ SYMBOL: visible-vars
|
|||
|
||||
SYMBOL: error-hook
|
||||
|
||||
[ print-error-and-restarts ] error-hook set-global
|
||||
: call-error-hook ( error -- )
|
||||
error-continuation get error-hook get call ;
|
||||
|
||||
[ drop print-error-and-restarts ] error-hook set-global
|
||||
|
||||
SYMBOL: display-stacks?
|
||||
|
||||
|
|
@ -103,14 +106,8 @@ SYMBOL: max-stack-items
|
|||
|
||||
: listen ( -- )
|
||||
visible-vars. stacks. prompt.
|
||||
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
|
||||
[
|
||||
dup lexer-error? [
|
||||
error-hook get call
|
||||
] [
|
||||
rethrow
|
||||
] if
|
||||
] recover ;
|
||||
[ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
|
||||
[ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
|
||||
|
||||
: until-quit ( -- )
|
||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: ui.gadgets help.markup help.syntax kernel quotations
|
||||
continuations debugger ui ;
|
||||
continuations debugger ui continuations ;
|
||||
IN: ui.tools.debugger
|
||||
|
||||
HELP: <debugger>
|
||||
{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" { $quotation "( list -- )" } } { "gadget" "a new " { $link gadget } } }
|
||||
{ $values { "error" "an error" } { "continuation" continuation } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" { $quotation "( debugger -- )" } } { "debugger" "a new " { $link debugger } } }
|
||||
{ $description
|
||||
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
|
||||
} ;
|
||||
|
|
@ -11,5 +11,5 @@ HELP: <debugger>
|
|||
{ <debugger> debugger-window } related-words
|
||||
|
||||
HELP: debugger-window
|
||||
{ $values { "error" "an error" } }
|
||||
{ $values { "error" "an error" } { "continuation" continuation } }
|
||||
{ $description "Opens a window with a description of the error." } ;
|
||||
|
|
|
|||
|
|
@ -1,47 +1,64 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hashtables io kernel math models
|
||||
namespaces sequences sequences words continuations debugger
|
||||
prettyprint help editors ui ui.commands ui.gestures ui.gadgets
|
||||
prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets
|
||||
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
|
||||
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
|
||||
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
|
||||
ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ;
|
||||
ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks
|
||||
ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders
|
||||
ui.tools.traceback ui.tools.inspector ;
|
||||
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 )
|
||||
[ restart-hook>> ] [ restarts>> ] bi
|
||||
[ name>> ] swap <model> <list> ; inline
|
||||
dup restarts>> f prefix <model> <table>
|
||||
[ [ \ restart invoke-command ] when* ] >>action
|
||||
swap restart-hook>> >>hook
|
||||
restart-renderer >>renderer
|
||||
t >>selection-required?
|
||||
t >>single-click? ; inline
|
||||
|
||||
: <error-pane> ( error -- pane )
|
||||
<pane> [ [ print-error ] with-pane ] keep ; inline
|
||||
|
||||
: <debugger-display> ( debugger -- gadget )
|
||||
<filled-pile>
|
||||
over error>> <error-pane> add-gadget
|
||||
swap restart-list>> add-gadget ; 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 restarts restart-hook -- gadget )
|
||||
: <debugger> ( error continuation restarts restart-hook -- gadget )
|
||||
vertical debugger new-track
|
||||
add-toolbar
|
||||
{ 3 3 } >>gap
|
||||
swap >>restart-hook
|
||||
swap >>restarts
|
||||
swap >>continuation
|
||||
swap >>error
|
||||
error-continuation get >>continuation
|
||||
add-toolbar
|
||||
dup <restart-list> >>restart-list
|
||||
dup <debugger-display> <scroller> 1 track-add ;
|
||||
dup <error-display> f track-add ;
|
||||
|
||||
M: debugger focusable-child* restart-list>> ;
|
||||
M: debugger focusable-child*
|
||||
dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
|
||||
|
||||
: debugger-window ( error -- )
|
||||
: debugger-window ( error continuation -- )
|
||||
#! No restarts for the debugger window
|
||||
f [ drop ] <debugger> "Error" open-window ;
|
||||
f f <debugger> "Error" open-window ;
|
||||
|
||||
GENERIC: error-in-debugger? ( error -- ? )
|
||||
|
||||
|
|
@ -50,7 +67,8 @@ M: world-error error-in-debugger? world>> gadget-child debugger? ;
|
|||
M: object error-in-debugger? drop f ;
|
||||
|
||||
[
|
||||
dup error-in-debugger? [ rethrow ] [ debugger-window ] if
|
||||
dup error-in-debugger?
|
||||
[ rethrow ] [ error-continuation get debugger-window ] if
|
||||
] ui-error-hook set-global
|
||||
|
||||
M: world-error error.
|
||||
|
|
@ -63,9 +81,9 @@ debugger "gestures" f {
|
|||
{ T{ button-down } request-focus }
|
||||
} define-command-map
|
||||
|
||||
: com-traceback ( debugger -- ) continuation>> traceback-window ;
|
||||
: com-inspect ( debugger -- ) error>> inspector ;
|
||||
|
||||
\ com-traceback H{ } define-command
|
||||
: com-traceback ( debugger -- ) continuation>> traceback-window ;
|
||||
|
||||
: com-help ( debugger -- ) error>> (:help) ;
|
||||
|
||||
|
|
@ -76,7 +94,8 @@ debugger "gestures" f {
|
|||
\ com-edit H{ { +listener+ t } } define-command
|
||||
|
||||
debugger "toolbar" f {
|
||||
{ T{ key-down f f "s" } com-traceback }
|
||||
{ T{ key-down f f "h" } com-help }
|
||||
{ T{ key-down f f "e" } com-edit }
|
||||
{ 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
|
||||
|
|
|
|||
|
|
@ -8,11 +8,11 @@ generic.standard.engines.tuple fonts ui.commands ui.operations
|
|||
ui.gadgets ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
|
||||
ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labelled
|
||||
ui.gadgets.theme ui.gadgets.worlds ui.gadgets.wrappers ui.gestures
|
||||
ui.render ui.tools.listener.history combinators vocabs ;
|
||||
ui.render ui.tools.listener.history combinators vocabs
|
||||
ui.tools.listener.popups ;
|
||||
IN: ui.tools.listener.completion
|
||||
|
||||
! We don't directly depend on the listener tool but we use a few slots
|
||||
SLOT: completion-popup
|
||||
SLOT: interactor
|
||||
SLOT: history
|
||||
|
||||
|
|
@ -88,7 +88,7 @@ M: vocab-completion row-color
|
|||
[ drop <word-completion> ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: completion-popup < track table interactor completion-mode ;
|
||||
TUPLE: completion-popup < track interactor table completion-mode ;
|
||||
|
||||
: find-completion-popup ( gadget -- popup )
|
||||
[ completion-popup? ] find-parent ;
|
||||
|
|
@ -99,12 +99,6 @@ TUPLE: completion-popup < track table interactor completion-mode ;
|
|||
|
||||
M: completion-popup focusable-child* table>> ;
|
||||
|
||||
M: completion-popup hide-glass-hook
|
||||
interactor>> f >>completion-popup request-focus ;
|
||||
|
||||
: hide-completion-popup ( popup -- )
|
||||
find-world hide-glass ;
|
||||
|
||||
: completion-loc/doc/elt ( popup -- loc doc elt )
|
||||
[ interactor>> [ editor-caret ] [ model>> ] bi ]
|
||||
[ completion-mode>> completion-element ]
|
||||
|
|
@ -130,7 +124,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
|
|||
find-completion-popup
|
||||
[ insert-completion ]
|
||||
[ accept-completion-hook ]
|
||||
[ nip hide-completion-popup ]
|
||||
[ nip hide-popup ]
|
||||
2tri ;
|
||||
|
||||
: <completion-table> ( interactor completion-mode -- table )
|
||||
|
|
@ -143,7 +137,8 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
|
|||
|
||||
: <completion-scroller> ( completion-popup -- scroller )
|
||||
[ table>> ] [ interactor>> ] [ completion-mode>> ] tri completion-popup-width
|
||||
[ <limited-scroller> ] [ 120 2array ] bi* [ >>min-dim ] [ >>max-dim ] bi ;
|
||||
[ <limited-scroller> ] [ 120 2array ] bi*
|
||||
[ >>min-dim ] [ >>max-dim ] bi ;
|
||||
|
||||
: <completion-popup> ( interactor completion-mode -- popup )
|
||||
[ vertical completion-popup new-track ] 2dip
|
||||
|
|
@ -153,44 +148,13 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
|
|||
COLOR: white <solid> >>interior ;
|
||||
|
||||
completion-popup H{
|
||||
{ T{ key-down f f "ESC" } [ hide-completion-popup ] }
|
||||
{ T{ key-down f f "TAB" } [ table>> row-action ] }
|
||||
{ T{ key-down f f " " } [ table>> row-action ] }
|
||||
} set-gestures
|
||||
|
||||
CONSTANT: completion-popup-offset { -4 0 }
|
||||
|
||||
: (completion-popup-loc) ( interactor completion-mode -- loc )
|
||||
[ drop screen-loc ] [
|
||||
[
|
||||
[ [ editor-caret ] [ model>> ] bi ] dip
|
||||
completion-element prev-elt
|
||||
] [ drop ] 2bi
|
||||
loc>point
|
||||
] 2bi v+ completion-popup-offset v+ ;
|
||||
|
||||
: completion-popup-loc-1 ( interactor completion-mode -- loc )
|
||||
[ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
|
||||
|
||||
: completion-popup-loc-2 ( interactor completion-mode popup -- loc )
|
||||
[ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
|
||||
|
||||
: completion-popup-fits? ( interactor completion-mode popup -- ? )
|
||||
[ [ completion-popup-loc-1 ] dip pref-dim v+ ]
|
||||
[ 2drop find-world dim>> ]
|
||||
3bi [ second ] bi@ <= ;
|
||||
|
||||
: completion-popup-loc ( interactor completion-mode popup -- loc )
|
||||
3dup completion-popup-fits?
|
||||
[ drop completion-popup-loc-1 ]
|
||||
[ completion-popup-loc-2 ]
|
||||
if ;
|
||||
|
||||
: show-completion-popup ( interactor completion-mode -- )
|
||||
2dup <completion-popup>
|
||||
[ nip >>completion-popup drop ]
|
||||
[ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
|
||||
show-glass ;
|
||||
: show-completion-popup ( interactor mode -- )
|
||||
[ completion-element ] [ <completion-popup> ] 2bi
|
||||
show-popup ;
|
||||
|
||||
: code-completion-popup ( interactor -- )
|
||||
dup completion-mode show-completion-popup ;
|
||||
|
|
@ -204,12 +168,6 @@ CONSTANT: completion-popup-offset { -4 0 }
|
|||
: recall-next ( interactor -- )
|
||||
history>> history-recall-next ;
|
||||
|
||||
: selected-word ( editor -- word )
|
||||
dup completion-popup>>
|
||||
[ [ table>> selected-row drop ] [ hide-completion-popup ] bi ]
|
||||
[ selected-token dup search [ ] [ no-word ] ?if ]
|
||||
?if ;
|
||||
|
||||
: completion-gesture ( gesture completion -- value/f operation/f )
|
||||
table>> selected-row
|
||||
[ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -1,25 +1,25 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs calendar combinators
|
||||
combinators.short-circuit compiler.units concurrency.flags
|
||||
concurrency.mailboxes continuations destructors documents
|
||||
documents.elements fry hashtables help help.markup io io.styles kernel
|
||||
lexer listener math models models.delay models.filter namespaces
|
||||
parser prettyprint quotations sequences strings threads tools.vocabs
|
||||
vocabs vocabs.loader vocabs.parser words ui ui.commands ui.gadgets
|
||||
ui.gadgets.buttons ui.gadgets.editors ui.gadgets.frames
|
||||
ui.gadgets.grids ui.gadgets.labelled ui.gadgets.panes
|
||||
ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks
|
||||
ui.gestures ui.operations ui.tools.browser ui.tools.common
|
||||
ui.tools.debugger ui.tools.listener.completion
|
||||
USING: accessors arrays assocs calendar combinators locals
|
||||
colors.constants combinators.short-circuit compiler.units
|
||||
concurrency.flags concurrency.mailboxes continuations destructors
|
||||
documents documents.elements fry hashtables help help.markup io
|
||||
io.styles kernel lexer listener math models models.delay models.filter
|
||||
namespaces parser prettyprint quotations sequences strings threads
|
||||
tools.vocabs vocabs vocabs.loader vocabs.parser words ui ui.commands
|
||||
ui.render ui.gadgets ui.gadgets.buttons ui.gadgets.editors
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.labelled
|
||||
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar
|
||||
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
|
||||
ui.tools.browser ui.tools.common ui.tools.debugger
|
||||
ui.tools.listener.completion ui.tools.listener.popups
|
||||
ui.tools.listener.history ;
|
||||
IN: ui.tools.listener
|
||||
|
||||
! If waiting is t, we're waiting for user input, and invoking
|
||||
! evaluate-input resumes the thread.
|
||||
TUPLE: interactor < source-editor
|
||||
output history flag mailbox thread waiting token-model word-model
|
||||
completion-popup ;
|
||||
output history flag mailbox thread waiting token-model word-model popup ;
|
||||
|
||||
: register-self ( interactor -- )
|
||||
<mailbox> >>mailbox
|
||||
|
|
@ -82,7 +82,7 @@ M: interactor ungraft*
|
|||
|
||||
M: interactor model-changed
|
||||
2dup word-model>> eq? [
|
||||
dup completion-popup>>
|
||||
dup popup>>
|
||||
[ 2drop ] [ [ value>> ] dip show-summary ] if
|
||||
] [ call-next-method ] if ;
|
||||
|
||||
|
|
@ -163,7 +163,7 @@ M: interactor dispose drop ;
|
|||
over set-caret
|
||||
mark>caret ;
|
||||
|
||||
TUPLE: listener-gadget < tool input output scroller popup ;
|
||||
TUPLE: listener-gadget < tool input output scroller ;
|
||||
|
||||
{ 550 700 } listener-gadget set-tool-dim
|
||||
|
||||
|
|
@ -194,7 +194,7 @@ TUPLE: listener-gadget < tool input output scroller popup ;
|
|||
dup scroller>> 1 track-add ;
|
||||
|
||||
M: listener-gadget focusable-child*
|
||||
[ popup>> ] [ input>> ] bi or ;
|
||||
input>> dup popup>> or ;
|
||||
|
||||
: wait-for-listener ( listener -- )
|
||||
#! Wait for the listener to start.
|
||||
|
|
@ -297,29 +297,20 @@ M: object accept-completion-hook 2drop ;
|
|||
[ history>> history-add drop ] [ control-value ] [ select-all ] tri
|
||||
[ parse-lines ] with-compilation-unit ;
|
||||
|
||||
: hide-popup ( listener -- )
|
||||
dup popup>> track-remove
|
||||
f >>popup
|
||||
request-focus ;
|
||||
:: <debugger-popup> ( interactor error continuation -- popup )
|
||||
error continuation error compute-restarts
|
||||
[ interactor hide-popup ] <debugger>
|
||||
COLOR: white <solid> >>interior
|
||||
COLOR: black <solid> >>boundary
|
||||
"Error" <labelled-gadget> ;
|
||||
|
||||
: show-popup ( gadget listener -- )
|
||||
dup hide-popup
|
||||
over >>popup
|
||||
over f track-add drop
|
||||
request-focus ;
|
||||
|
||||
: show-titled-popup ( listener gadget title -- )
|
||||
[ find-listener hide-popup ] <closable-gadget>
|
||||
swap show-popup ;
|
||||
|
||||
: debugger-popup ( error listener -- )
|
||||
swap dup compute-restarts
|
||||
[ find-listener hide-popup ] <debugger>
|
||||
"Error" show-titled-popup ;
|
||||
: debugger-popup ( interactor error continuation -- )
|
||||
[ [ drop one-line-elt ] 2keep ] dip <debugger-popup> show-popup ;
|
||||
|
||||
: handle-parse-error ( interactor error -- )
|
||||
dup lexer-error? [ 2dup go-to-error error>> ] when
|
||||
swap find-listener debugger-popup ;
|
||||
error-continuation get
|
||||
debugger-popup ;
|
||||
|
||||
: try-parse ( lines interactor -- quot/error/f )
|
||||
[ drop parse-lines-interactive ] [
|
||||
|
|
@ -347,7 +338,7 @@ M: interactor stream-read-quot
|
|||
} cond ;
|
||||
|
||||
: pass-to-popup ( gesture interactor -- ? )
|
||||
completion-popup>> focusable-child resend-gesture ;
|
||||
popup>> focusable-child resend-gesture ;
|
||||
|
||||
: interactor-operation ( gesture interactor -- ? )
|
||||
[ token-model>> value>> ] keep word-at-caret
|
||||
|
|
@ -356,7 +347,7 @@ M: interactor stream-read-quot
|
|||
M: interactor handle-gesture
|
||||
{
|
||||
{ [ over key-gesture? not ] [ call-next-method ] }
|
||||
{ [ dup completion-popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
|
||||
{ [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
|
||||
{ [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
|
||||
[ call-next-method ]
|
||||
} cond ;
|
||||
|
|
@ -381,7 +372,7 @@ interactor "completion" f {
|
|||
: listener-thread ( listener -- )
|
||||
dup listener-streams [
|
||||
[ com-follow ] help-hook set
|
||||
'[ _ debugger-popup ] error-hook set
|
||||
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
|
||||
welcome.
|
||||
listener
|
||||
] with-streams* ;
|
||||
|
|
@ -438,10 +429,6 @@ listener-gadget "multi-touch" f {
|
|||
{ up-action refresh-all }
|
||||
} define-command-map
|
||||
|
||||
listener-gadget "other" f {
|
||||
{ T{ key-down f f "ESC" } hide-popup }
|
||||
} define-command-map
|
||||
|
||||
M: listener-gadget graft*
|
||||
[ call-next-method ] [ restart-listener ] bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test ui.tools.listener.popups ;
|
||||
IN: ui.tools.listener.popups.tests
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors documents.elements kernel math math.vectors
|
||||
sequences ui.gadgets ui.gadgets.editors ui.gadgets.glass
|
||||
ui.gadgets.tracks ui.gadgets.wrappers
|
||||
ui.gadgets.worlds ui.gestures ;
|
||||
IN: ui.tools.listener.popups
|
||||
|
||||
SLOT: popup
|
||||
|
||||
TUPLE: popup < wrapper interactor element ;
|
||||
|
||||
: <popup> ( interactor element gadget -- popup )
|
||||
popup new-wrapper
|
||||
swap >>element
|
||||
swap >>interactor ;
|
||||
|
||||
M: popup hide-glass-hook
|
||||
interactor>> f >>popup request-focus ;
|
||||
|
||||
: hide-popup ( popup -- )
|
||||
find-world hide-glass ;
|
||||
|
||||
popup H{
|
||||
{ T{ key-down f f "ESC" } [ hide-popup ] }
|
||||
} set-gestures
|
||||
|
||||
CONSTANT: popup-offset { -4 0 }
|
||||
|
||||
: (popup-loc) ( interactor element -- loc )
|
||||
[ drop screen-loc ] [
|
||||
[
|
||||
[ [ editor-caret ] [ model>> ] bi ] dip
|
||||
prev-elt
|
||||
] [ drop ] 2bi
|
||||
loc>point
|
||||
] 2bi v+ popup-offset v+ ;
|
||||
|
||||
: popup-loc-1 ( interactor element -- loc )
|
||||
[ (popup-loc) ] [ drop caret-dim ] 2bi v+ ;
|
||||
|
||||
: popup-loc-2 ( interactor element popup -- loc )
|
||||
[ (popup-loc) ] dip pref-dim { 0 1 } v* v- ;
|
||||
|
||||
: popup-fits? ( interactor element popup -- ? )
|
||||
[ [ popup-loc-1 ] dip pref-dim v+ ]
|
||||
[ 2drop find-world dim>> ]
|
||||
3bi [ second ] bi@ <= ;
|
||||
|
||||
: popup-loc ( popup -- loc )
|
||||
[ interactor>> ] [ element>> ] [ ] tri 3dup popup-fits?
|
||||
[ drop popup-loc-1 ] [ popup-loc-2 ] if ;
|
||||
|
||||
: show-popup ( interactor element popup -- )
|
||||
<popup>
|
||||
[ dup interactor>> (>>popup) ]
|
||||
[ [ interactor>> find-world ] [ ] [ popup-loc ] tri show-glass ]
|
||||
bi ;
|
||||
|
|
@ -1,24 +1,44 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors continuations kernel models namespaces
|
||||
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
USING: accessors continuations kernel models namespaces arrays
|
||||
fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
|
||||
ui.gadgets.status-bar ui.gadgets.scrollers
|
||||
ui.gestures sequences inspector models.filter ;
|
||||
ui.gadgets.tables ui.gestures sequences inspector
|
||||
models.filter ;
|
||||
QUALIFIED-WITH: ui.tools.inspector i
|
||||
IN: ui.tools.traceback
|
||||
|
||||
TUPLE: stack-entry object string ;
|
||||
|
||||
: <stack-entry> ( object -- stack-entry )
|
||||
dup unparse-short stack-entry boa ;
|
||||
|
||||
SINGLETON: stack-entry-renderer
|
||||
|
||||
M: stack-entry-renderer row-columns drop string>> 1array ;
|
||||
|
||||
M: stack-entry-renderer row-value drop object>> ;
|
||||
|
||||
: <stack-table> ( model -- table )
|
||||
[ [ <stack-entry> ] map ] <filter> <table>
|
||||
[ i:inspector ] >>action
|
||||
stack-entry-renderer >>renderer
|
||||
t >>single-click? ;
|
||||
|
||||
: <stack-display> ( model quot title -- gadget )
|
||||
[ '[ dup _ when ] <filter> <stack-table> <scroller> ] dip
|
||||
<labelled-gadget> ;
|
||||
|
||||
: <callstack-display> ( model -- gadget )
|
||||
[ [ call>> callstack. ] when* ]
|
||||
t "Call stack" <labelled-pane> ;
|
||||
|
||||
: <datastack-display> ( model -- gadget )
|
||||
[ [ data>> stack. ] when* ]
|
||||
t "Data stack" <labelled-pane> ;
|
||||
[ data>> ] "Data stack" <stack-display> ;
|
||||
|
||||
: <retainstack-display> ( model -- gadget )
|
||||
[ [ retain>> stack. ] when* ]
|
||||
t "Retain stack" <labelled-pane> ;
|
||||
[ retain>> ] "Retain stack" <stack-display> ;
|
||||
|
||||
TUPLE: traceback-gadget < track ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue