steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Rework listener's debugger-popup code

db4
Slava Pestov 2009-02-09 00:25:05 -06:00
parent 3ac409e432
commit cf4e0d78c3
9 changed files with 180 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/listener/listener.factor
View File

@ -54,7 +54,10 @@ SYMBOL: visible-vars
SYMBOL: error-hook 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? SYMBOL: display-stacks?
@ -103,14 +106,8 @@ SYMBOL: max-stack-items
: listen ( -- ) : listen ( -- )
visible-vars. stacks. prompt. visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ] [ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
[ [ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
dup lexer-error? [
error-hook get call
] [
rethrow
] if
] recover ;
: until-quit ( -- ) : until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ; quit-flag get [ quit-flag off ] [ listen until-quit ] if ;

6
basis/ui/tools/debugger/debugger-docs.factor
View File

@ -1,9 +1,9 @@
USING: ui.gadgets help.markup help.syntax kernel quotations USING: ui.gadgets help.markup help.syntax kernel quotations
continuations debugger ui ; continuations debugger ui continuations ;
IN: ui.tools.debugger IN: ui.tools.debugger
HELP: <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 { $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." "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 { <debugger> debugger-window } related-words
HELP: debugger-window HELP: debugger-window
{ $values { "error" "an error" } } { $values { "error" "an error" } { "continuation" continuation } }
{ $description "Opens a window with a description of the error." } ; { $description "Opens a window with a description of the error." } ;

65
basis/ui/tools/debugger/debugger.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math models USING: accessors arrays hashtables io kernel math models
namespaces sequences sequences words continuations debugger 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.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ; ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders
ui.tools.traceback ui.tools.inspector ;
IN: ui.tools.debugger IN: ui.tools.debugger
TUPLE: debugger < track error restarts restart-hook restart-list continuation ; TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
<PRIVATE <PRIVATE
SINGLETON: restart-renderer
M: restart-renderer row-columns
drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;
: <restart-list> ( debugger -- gadget ) : <restart-list> ( debugger -- gadget )
[ restart-hook>> ] [ restarts>> ] bi dup restarts>> f prefix <model> <table>
[ name>> ] swap <model> <list> ; inline [ [ \ restart invoke-command ] when* ] >>action
swap restart-hook>> >>hook
restart-renderer >>renderer
t >>selection-required?
t >>single-click? ; inline
: <error-pane> ( error -- pane ) : <error-pane> ( error -- pane )
<pane> [ [ print-error ] with-pane ] keep ; inline <pane> [ [ print-error ] with-pane ] keep ; inline
: <debugger-display> ( debugger -- gadget ) : <error-display> ( debugger -- gadget )
<filled-pile> [ <filled-pile> ] dip
over error>> <error-pane> add-gadget [ error>> <error-pane> add-gadget ]
swap restart-list>> add-gadget ; inline [
dup restart-hook>> [
[ "To continue, pick one of the options below:" <label> add-gadget ] dip
restart-list>> add-gadget
] [ drop ] if
] bi ;
PRIVATE> PRIVATE>
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error continuation restarts restart-hook -- gadget )
vertical debugger new-track vertical debugger new-track
add-toolbar { 3 3 } >>gap
swap >>restart-hook swap >>restart-hook
swap >>restarts swap >>restarts
swap >>continuation
swap >>error swap >>error
error-continuation get >>continuation add-toolbar
dup <restart-list> >>restart-list 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 #! No restarts for the debugger window
f [ drop ] <debugger> "Error" open-window ; f f <debugger> "Error" open-window ;
GENERIC: error-in-debugger? ( error -- ? ) 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 ; 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 ] ui-error-hook set-global
M: world-error error. M: world-error error.
@ -63,9 +81,9 @@ debugger "gestures" f {
{ T{ button-down } request-focus } { T{ button-down } request-focus }
} define-command-map } 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) ; : com-help ( debugger -- ) error>> (:help) ;
@ -76,7 +94,8 @@ debugger "gestures" f {
\ com-edit H{ { +listener+ t } } define-command \ com-edit H{ { +listener+ t } } define-command
debugger "toolbar" f { debugger "toolbar" f {
{ T{ key-down f f "s" } com-traceback } { T{ key-down f { C+ } "i" } com-inspect }
{ T{ key-down f f "h" } com-help } { T{ key-down f { C+ } "t" } com-traceback }
{ T{ key-down f f "e" } com-edit } { T{ key-down f { C+ } "h" } com-help }
{ T{ key-down f { C+ } "e" } com-edit }
} define-command-map } define-command-map

60
basis/ui/tools/listener/completion/completion.factor
View File

@ -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 ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labelled ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labelled
ui.gadgets.theme ui.gadgets.worlds ui.gadgets.wrappers ui.gestures 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 IN: ui.tools.listener.completion
! We don't directly depend on the listener tool but we use a few slots ! We don't directly depend on the listener tool but we use a few slots
SLOT: completion-popup
SLOT: interactor SLOT: interactor
SLOT: history SLOT: history
@ -88,7 +88,7 @@ M: vocab-completion row-color
[ drop <word-completion> ] [ drop <word-completion> ]
} cond ; } cond ;
TUPLE: completion-popup < track table interactor completion-mode ; TUPLE: completion-popup < track interactor table completion-mode ;
: find-completion-popup ( gadget -- popup ) : find-completion-popup ( gadget -- popup )
[ completion-popup? ] find-parent ; [ 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 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 ) : completion-loc/doc/elt ( popup -- loc doc elt )
[ interactor>> [ editor-caret ] [ model>> ] bi ] [ interactor>> [ editor-caret ] [ model>> ] bi ]
[ completion-mode>> completion-element ] [ completion-mode>> completion-element ]
@ -130,7 +124,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
find-completion-popup find-completion-popup
[ insert-completion ] [ insert-completion ]
[ accept-completion-hook ] [ accept-completion-hook ]
[ nip hide-completion-popup ] [ nip hide-popup ]
2tri ; 2tri ;
: <completion-table> ( interactor completion-mode -- table ) : <completion-table> ( interactor completion-mode -- table )
@ -143,7 +137,8 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
: <completion-scroller> ( completion-popup -- scroller ) : <completion-scroller> ( completion-popup -- scroller )
[ table>> ] [ interactor>> ] [ completion-mode>> ] tri completion-popup-width [ 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 ) : <completion-popup> ( interactor completion-mode -- popup )
[ vertical completion-popup new-track ] 2dip [ vertical completion-popup new-track ] 2dip
@ -153,44 +148,13 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
COLOR: white <solid> >>interior ; COLOR: white <solid> >>interior ;
completion-popup H{ 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 "TAB" } [ table>> row-action ] }
{ T{ key-down f f " " } [ table>> row-action ] } { T{ key-down f f " " } [ table>> row-action ] }
} set-gestures } set-gestures
CONSTANT: completion-popup-offset { -4 0 } : show-completion-popup ( interactor mode -- )
[ completion-element ] [ <completion-popup> ] 2bi
: (completion-popup-loc) ( interactor completion-mode -- loc ) show-popup ;
[ 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 ;
: code-completion-popup ( interactor -- ) : code-completion-popup ( interactor -- )
dup completion-mode show-completion-popup ; dup completion-mode show-completion-popup ;
@ -204,12 +168,6 @@ CONSTANT: completion-popup-offset { -4 0 }
: recall-next ( interactor -- ) : recall-next ( interactor -- )
history>> history-recall-next ; 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 ) : completion-gesture ( gesture completion -- value/f operation/f )
table>> selected-row table>> selected-row
[ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ; [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;

73
basis/ui/tools/listener/listener.factor
View File

@ -1,25 +1,25 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators USING: accessors arrays assocs calendar combinators locals
combinators.short-circuit compiler.units concurrency.flags colors.constants combinators.short-circuit compiler.units
concurrency.mailboxes continuations destructors documents concurrency.flags concurrency.mailboxes continuations destructors
documents.elements fry hashtables help help.markup io io.styles kernel documents documents.elements fry hashtables help help.markup io
lexer listener math models models.delay models.filter namespaces io.styles kernel lexer listener math models models.delay models.filter
parser prettyprint quotations sequences strings threads tools.vocabs namespaces parser prettyprint quotations sequences strings threads
vocabs vocabs.loader vocabs.parser words ui ui.commands ui.gadgets tools.vocabs vocabs vocabs.loader vocabs.parser words ui ui.commands
ui.gadgets.buttons ui.gadgets.editors ui.gadgets.frames ui.render ui.gadgets ui.gadgets.buttons ui.gadgets.editors
ui.gadgets.grids ui.gadgets.labelled ui.gadgets.panes ui.gadgets.frames ui.gadgets.grids ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar
ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.debugger ui.tools.listener.completion ui.tools.browser ui.tools.common ui.tools.debugger
ui.tools.listener.completion ui.tools.listener.popups
ui.tools.listener.history ; ui.tools.listener.history ;
IN: ui.tools.listener IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking ! If waiting is t, we're waiting for user input, and invoking
! evaluate-input resumes the thread. ! evaluate-input resumes the thread.
TUPLE: interactor < source-editor TUPLE: interactor < source-editor
output history flag mailbox thread waiting token-model word-model output history flag mailbox thread waiting token-model word-model popup ;
completion-popup ;
: register-self ( interactor -- ) : register-self ( interactor -- )
<mailbox> >>mailbox <mailbox> >>mailbox
@ -82,7 +82,7 @@ M: interactor ungraft*
M: interactor model-changed M: interactor model-changed
2dup word-model>> eq? [ 2dup word-model>> eq? [
dup completion-popup>> dup popup>>
[ 2drop ] [ [ value>> ] dip show-summary ] if [ 2drop ] [ [ value>> ] dip show-summary ] if
] [ call-next-method ] if ; ] [ call-next-method ] if ;
@ -163,7 +163,7 @@ M: interactor dispose drop ;
over set-caret over set-caret
mark>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 { 550 700 } listener-gadget set-tool-dim
@ -194,7 +194,7 @@ TUPLE: listener-gadget < tool input output scroller popup ;
dup scroller>> 1 track-add ; dup scroller>> 1 track-add ;
M: listener-gadget focusable-child* M: listener-gadget focusable-child*
[ popup>> ] [ input>> ] bi or ; input>> dup popup>> or ;
: wait-for-listener ( listener -- ) : wait-for-listener ( listener -- )
#! Wait for the listener to start. #! 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 [ history>> history-add drop ] [ control-value ] [ select-all ] tri
[ parse-lines ] with-compilation-unit ; [ parse-lines ] with-compilation-unit ;
: hide-popup ( listener -- ) :: <debugger-popup> ( interactor error continuation -- popup )
dup popup>> track-remove error continuation error compute-restarts
f >>popup [ interactor hide-popup ] <debugger>
request-focus ; COLOR: white <solid> >>interior
COLOR: black <solid> >>boundary
"Error" <labelled-gadget> ;
: show-popup ( gadget listener -- ) : debugger-popup ( interactor error continuation -- )
dup hide-popup [ [ drop one-line-elt ] 2keep ] dip <debugger-popup> show-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 ;
: handle-parse-error ( interactor error -- ) : handle-parse-error ( interactor error -- )
dup lexer-error? [ 2dup go-to-error error>> ] when 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 ) : try-parse ( lines interactor -- quot/error/f )
[ drop parse-lines-interactive ] [ [ drop parse-lines-interactive ] [
@ -347,7 +338,7 @@ M: interactor stream-read-quot
} cond ; } cond ;
: pass-to-popup ( gesture interactor -- ? ) : pass-to-popup ( gesture interactor -- ? )
completion-popup>> focusable-child resend-gesture ; popup>> focusable-child resend-gesture ;
: interactor-operation ( gesture interactor -- ? ) : interactor-operation ( gesture interactor -- ? )
[ token-model>> value>> ] keep word-at-caret [ token-model>> value>> ] keep word-at-caret
@ -356,7 +347,7 @@ M: interactor stream-read-quot
M: interactor handle-gesture M: interactor handle-gesture
{ {
{ [ over key-gesture? not ] [ call-next-method ] } { [ 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&& ] } { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
[ call-next-method ] [ call-next-method ]
} cond ; } cond ;
@ -381,7 +372,7 @@ interactor "completion" f {
: listener-thread ( listener -- ) : listener-thread ( listener -- )
dup listener-streams [ dup listener-streams [
[ com-follow ] help-hook set [ com-follow ] help-hook set
'[ _ debugger-popup ] error-hook set '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
welcome. welcome.
listener listener
] with-streams* ; ] with-streams* ;
@ -438,10 +429,6 @@ listener-gadget "multi-touch" f {
{ up-action refresh-all } { up-action refresh-all }
} define-command-map } define-command-map
listener-gadget "other" f {
{ T{ key-down f f "ESC" } hide-popup }
} define-command-map
M: listener-gadget graft* M: listener-gadget graft*
[ call-next-method ] [ restart-listener ] bi ; [ call-next-method ] [ restart-listener ] bi ;

1
basis/ui/tools/listener/popups/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/ui/tools/listener/popups/popups-tests.factor Normal file
View File

@ -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

58
basis/ui/tools/listener/popups/popups.factor Normal file
View File

@ -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 ;

34
basis/ui/tools/traceback/traceback.factor
View File

@ -1,24 +1,44 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces USING: accessors continuations kernel models namespaces arrays
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers 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 QUALIFIED-WITH: ui.tools.inspector i
IN: ui.tools.traceback 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 ) : <callstack-display> ( model -- gadget )
[ [ call>> callstack. ] when* ] [ [ call>> callstack. ] when* ]
t "Call stack" <labelled-pane> ; t "Call stack" <labelled-pane> ;
: <datastack-display> ( model -- gadget ) : <datastack-display> ( model -- gadget )
[ [ data>> stack. ] when* ] [ data>> ] "Data stack" <stack-display> ;
t "Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- gadget ) : <retainstack-display> ( model -- gadget )
[ [ retain>> stack. ] when* ] [ retain>> ] "Retain stack" <stack-display> ;
t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget < track ; TUPLE: traceback-gadget < track ;