More walker work
parent
3ffe8f97e4
commit
c5de10ec49
|
@ -2,15 +2,22 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.promises models tools.walker kernel
|
||||
sequences concurrency.messaging locals continuations
|
||||
threads ;
|
||||
threads namespaces namespaces.private ;
|
||||
IN: tools.walker.debug
|
||||
|
||||
:: test-walker | quot |
|
||||
[let | p [ <promise> ]
|
||||
s [ f <model> ]
|
||||
c [ f <model> ] |
|
||||
[ s c start-walker-thread p fulfill break ]
|
||||
quot compose "Walker test" spawn drop
|
||||
[
|
||||
H{ } clone >n
|
||||
[ s c start-walker-thread p fulfill ] new-walker-hook set
|
||||
[ drop ] show-walker-hook set
|
||||
|
||||
break
|
||||
|
||||
quot call
|
||||
] "Walker test" spawn drop
|
||||
|
||||
step-into-all
|
||||
p ?promise
|
||||
|
|
|
@ -97,10 +97,6 @@ IN: temporary
|
|||
[ { 6 } ]
|
||||
[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
|
||||
|
||||
[ { "{ 1 2 3 }\n" } ] [
|
||||
[ [ { 1 2 3 } . ] with-string-writer ] test-walker
|
||||
] unit-test
|
||||
|
||||
[ { } ] [
|
||||
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
|
||||
] unit-test
|
||||
|
|
|
@ -6,8 +6,8 @@ concurrency.messaging quotations kernel.private words
|
|||
sequences.private assocs models ;
|
||||
IN: tools.walker
|
||||
|
||||
SYMBOL: new-walker-hook
|
||||
SYMBOL: show-walker-hook
|
||||
SYMBOL: new-walker-hook ! ( -- )
|
||||
SYMBOL: show-walker-hook ! ( thread -- )
|
||||
|
||||
! Thread local
|
||||
SYMBOL: walker-thread
|
||||
|
@ -169,16 +169,19 @@ SYMBOL: +detached+
|
|||
[ status +running+ eq? ] [
|
||||
[
|
||||
{
|
||||
{ detach [ detach-msg ] }
|
||||
{ step [ ] }
|
||||
{ step-out [ ] }
|
||||
{ step-into [ ] }
|
||||
{ step-all [ ] }
|
||||
{ step-into-all [ ] }
|
||||
{ step-back [ ] }
|
||||
{ f [ walker-stopped ] }
|
||||
[ step-into-msg ]
|
||||
} case f
|
||||
{ detach [ detach-msg f ] }
|
||||
{ step [ f ] }
|
||||
{ step-out [ f ] }
|
||||
{ step-into [ f ] }
|
||||
{ step-all [ f ] }
|
||||
{ step-into-all [ f ] }
|
||||
{ step-back [ f ] }
|
||||
{ f [ +stopped+ set-status f ] }
|
||||
[
|
||||
dup walker-continuation tget set-model
|
||||
step-into-msg
|
||||
]
|
||||
} case
|
||||
] handle-synchronous
|
||||
] [ ] while ;
|
||||
|
||||
|
|
|
@ -18,7 +18,7 @@ HELP: <closable-gadget>
|
|||
{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
|
||||
|
||||
HELP: <labelled-pane>
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } }
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
|
||||
|
||||
{ <labelled-pane> <pane-control> } related-words
|
||||
|
|
|
@ -21,8 +21,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
|
|||
: <labelled-scroller> ( gadget title -- gadget )
|
||||
>r <scroller> r> <labelled-gadget> ;
|
||||
|
||||
: <labelled-pane> ( model quot title -- gadget )
|
||||
>r <pane-control> t over set-pane-scrolls? r>
|
||||
: <labelled-pane> ( model quot scrolls? title -- gadget )
|
||||
>r >r <pane-control> r> over set-pane-scrolls? r>
|
||||
<labelled-scroller> ;
|
||||
|
||||
: <close-box> ( quot -- button/f )
|
||||
|
|
|
@ -106,7 +106,7 @@ TUPLE: stack-display ;
|
|||
g workspace-listener swap [
|
||||
dup <toolbar> f track,
|
||||
listener-gadget-stack [ stack. ]
|
||||
"Data stack" <labelled-pane> 1 track,
|
||||
t "Data stack" <labelled-pane> 1 track,
|
||||
] { 0 1 } build-track ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
|
|
|
@ -1,25 +1,29 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations kernel models namespaces prettyprint ui
|
||||
ui.commands ui.gadgets ui.gadgets.labelled
|
||||
ui.gadgets.tracks ui.gestures ;
|
||||
ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
ui.gadgets.tracks ui.gestures sequences hashtables inspector ;
|
||||
IN: ui.tools.traceback
|
||||
|
||||
: <callstack-display> ( model -- gadget )
|
||||
[ [ continuation-call callstack. ] when* ]
|
||||
"Call stack" <labelled-pane> ;
|
||||
t "Call stack" <labelled-pane> ;
|
||||
|
||||
: <datastack-display> ( model -- gadget )
|
||||
[ [ continuation-data stack. ] when* ]
|
||||
"Data stack" <labelled-pane> ;
|
||||
t "Data stack" <labelled-pane> ;
|
||||
|
||||
: <retainstack-display> ( model -- gadget )
|
||||
[ [ continuation-retain stack. ] when* ]
|
||||
"Retain stack" <labelled-pane> ;
|
||||
t "Retain stack" <labelled-pane> ;
|
||||
|
||||
: <namestack-display> ( model -- gadget )
|
||||
[ [ continuation-name namestack. ] when* ]
|
||||
f "Dynamic variables" <labelled-pane> ;
|
||||
|
||||
TUPLE: traceback-gadget ;
|
||||
|
||||
M: traceback-gadget pref-dim* drop { 300 400 } ;
|
||||
M: traceback-gadget pref-dim* drop { 550 600 } ;
|
||||
|
||||
: <traceback-gadget> ( model -- gadget )
|
||||
{ 0 1 } <track> traceback-gadget construct-control [
|
||||
|
@ -27,8 +31,9 @@ M: traceback-gadget pref-dim* drop { 300 400 } ;
|
|||
[
|
||||
g gadget-model <datastack-display> 1/2 track,
|
||||
g gadget-model <retainstack-display> 1/2 track,
|
||||
] { 1 0 } make-track 1/3 track,
|
||||
g gadget-model <callstack-display> 2/3 track,
|
||||
] { 1 0 } make-track 1/5 track,
|
||||
g gadget-model <callstack-display> 2/5 track,
|
||||
g gadget-model <namestack-display> 2/5 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue