1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators concurrency.messaging kernel
4 models namespaces sequences threads tools.walker ui ui.commands
5 ui.gadgets ui.gadgets.labels ui.gadgets.status-bar
6 ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.pens.solid
7 ui.theme ui.tools.browser ui.tools.common ui.tools.traceback ;
10 TUPLE: walker-gadget < tool
11 status continuation thread
15 : walker-command ( walker msg -- )
17 dup thread>> thread-registered?
18 [ thread>> send-synchronous drop ]
22 : com-step ( walker -- ) step walker-command ;
24 : com-into ( walker -- ) step-into walker-command ;
26 : com-out ( walker -- ) step-out walker-command ;
28 : com-back ( walker -- ) step-back walker-command ;
30 : com-continue ( walker -- ) step-all walker-command ;
32 : com-abandon ( walker -- ) abandon walker-command ;
34 M: walker-gadget ungraft*
35 [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
37 M: walker-gadget focusable-child*
40 : thread-status-text ( status -- string )
42 { +stopped+ "Stopped" }
43 { +suspended+ "Suspended" }
44 { +running+ "Running" }
45 } at "(" ")" surround ;
47 : thread-status-foreground ( status -- color )
49 { +stopped+ [ thread-status-stopped-foreground ] }
50 { +suspended+ [ thread-status-suspended-foreground ] }
51 { +running+ [ thread-status-running-foreground ] }
55 : thread-status-background ( status -- color )
57 { +stopped+ [ thread-status-stopped-background ] }
58 { +suspended+ [ thread-status-suspended-background ] }
59 { +running+ [ thread-status-running-background ] }
60 { f [ content-background ] }
63 TUPLE: thread-status < label ;
65 M: thread-status model-changed
67 [ [ thread-status-text ] [ string<< ] bi* ]
68 [ [ thread-status-foreground ] [ font>> foreground<< ] bi* ]
69 [ [ thread-status-background <solid> ] [ parent>> parent>> interior<< ] bi* ]
72 : <thread-status> ( model -- gadget )
73 "" thread-status new-label
76 : add-thread-status ( track -- track )
77 horizontal <track> { 5 5 } >>gap
79 [ t >>bold? ] change-font
81 self name>> <label> f track-add
82 over status>> <thread-status>
83 dup font>> t >>bold? drop
87 : add-traceback ( track -- track )
88 dup traceback>> 1 track-add ;
90 : <walker-gadget> ( status continuation thread -- gadget )
91 vertical walker-gadget new-track with-lines
95 dup continuation>> <traceback-gadget> >>traceback
100 : walker-help ( -- ) "ui-walker" com-browse ;
102 \ walker-help H{ { +nullary+ t } } define-command
104 walker-gadget "toolbar" f {
105 { T{ key-down f f "s" } com-step }
106 { T{ key-down f f "i" } com-into }
107 { T{ key-down f f "o" } com-out }
108 { T{ key-down f f "b" } com-back }
109 { T{ key-down f f "c" } com-continue }
110 { T{ key-down f f "a" } com-abandon }
111 { T{ key-down f f "d" } close-window }
112 { T{ key-down f f "F1" } walker-help }
115 walker-gadget "multitouch" f {
116 { left-action com-back }
117 { right-action com-step }
118 { up-action com-out }
119 { down-action com-into }
120 { zoom-out-action close-window }
121 { zoom-in-action com-abandon }
124 : walker-for-thread? ( thread gadget -- ? )
126 { [ dup walker-gadget? not ] [ 2drop f ] }
127 { [ dup closing?>> ] [ 2drop f ] }
131 : find-walker-window ( thread -- world/f )
132 '[ _ swap walker-for-thread? ] find-window ;
134 : walker-window ( status continuation thread -- )
135 [ <walker-gadget> ] [ name>> ] bi open-status-window ;
138 dup find-walker-window dup
139 [ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if
140 ] show-walker-hook set-global