Rework listener's debugger-popup code

diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index fc5f5c60b67ddf82765f01c7f6470e672d4f40fe..653b46ce683b340af5ece06ae97b0049be2974c7 100644 (file)
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -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 ;

diff --git a/basis/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor
index 94c118953de612c4c8f1e57884f40802fc05c09c..b68b34977428bea9eb557e27738ba065fb2ed00d 100644 (file)
--- a/basis/ui/tools/debugger/debugger-docs.factor
+++ b/basis/ui/tools/debugger/debugger-docs.factor
@@ -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." } ;

diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 9bd7be33ea5123cea396b17489362be0390b6066..0a03ab4a467ed948c9c09ccc314570079a46573b 100644 (file)
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -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

diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor
index 6d5863905b3e194a0b6b032a10c2ba6a3ee7de0a..f86166ffbc9d41693999f826b1e57463d578cfe4 100644 (file)
--- a/basis/ui/tools/listener/completion/completion.factor
+++ b/basis/ui/tools/listener/completion/completion.factor
@@ -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 ;

diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 83ecb1cfe444c66b735486c4cd03a186671381ef..02e1e1e12eab64f6ef1b98f04b5587d3a36a11dc 100644 (file)
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -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 ;
 

diff --git a/basis/ui/tools/listener/popups/authors.txt b/basis/ui/tools/listener/popups/authors.txt
new file mode 100644 (file)
index 0000000..d4f5d6b
--- /dev/null
+++ b/basis/ui/tools/listener/popups/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file

diff --git a/basis/ui/tools/listener/popups/popups-tests.factor b/basis/ui/tools/listener/popups/popups-tests.factor
new file mode 100644 (file)
index 0000000..e0867bc
--- /dev/null
+++ b/basis/ui/tools/listener/popups/popups-tests.factor
@@ -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

diff --git a/basis/ui/tools/listener/popups/popups.factor b/basis/ui/tools/listener/popups/popups.factor
new file mode 100644 (file)
index 0000000..89c95f3
--- /dev/null
+++ b/basis/ui/tools/listener/popups/popups.factor
@@ -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 ;
\ No newline at end of file

diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
index bd8b0625af3231f765a4f6de9ae2d79106c2a664..be1cdf424a6a92d2f83bc15201fe01eb2568028a 100644 (file)
--- a/basis/ui/tools/traceback/traceback.factor
+++ b/basis/ui/tools/traceback/traceback.factor
@@ -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 ;