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

More walker work

db4
Slava Pestov 2008-02-21 01:25:59 -06:00
parent 3ffe8f97e4
commit c5de10ec49
7 changed files with 42 additions and 31 deletions

13
extra/tools/walker/debug/debug.factor
View File

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

4
extra/tools/walker/walker-tests.factor
View File

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

27
extra/tools/walker/walker.factor
View File

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

2
extra/ui/gadgets/labelled/labelled-docs.factor
View File

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

4
extra/ui/gadgets/labelled/labelled.factor Normal file → Executable file
View File

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

2
extra/ui/tools/listener/listener.factor
View File

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

21
extra/ui/tools/traceback/traceback.factor
View File

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