basis/ui/tools/walker/walker.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs colors colors.constants combinators
   4 concurrency.messaging formatting fry inspector kernel make
   5 models models.arrow namespaces sequences threads tools.walker ui
   6 ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.labels
   7 ui.gadgets.status-bar ui.gadgets.theme ui.gadgets.toolbar
   8 ui.gadgets.tracks ui.gestures ui.pens.solid ui.tools.browser
   9 ui.tools.common ui.tools.listener ui.tools.traceback ;
  10 IN: ui.tools.walker
  11
  12 TUPLE: walker-gadget < tool
  13 status continuation thread
  14 traceback
  15 closing? ;
  16
  17 : walker-command ( walker msg -- )
  18     swap
  19     dup thread>> thread-registered?
  20     [ thread>> send-synchronous drop ]
  21     [ 2drop ]
  22     if ;
  23
  24 : com-step ( walker -- ) step walker-command ;
  25
  26 : com-into ( walker -- ) step-into walker-command ;
  27
  28 : com-out ( walker -- ) step-out walker-command ;
  29
  30 : com-back ( walker -- ) step-back walker-command ;
  31
  32 : com-continue ( walker -- ) step-all walker-command ;
  33
  34 : com-abandon ( walker -- ) abandon walker-command ;
  35
  36 M: walker-gadget ungraft*
  37     [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
  38
  39 M: walker-gadget focusable-child*
  40     traceback>> ;
  41
  42 : thread-status-text ( status -- string )
  43     {
  44         { +stopped+ "Stopped" }
  45         { +suspended+ "Suspended" }
  46         { +running+ "Running" }
  47     } at "(" ")" surround ;
  48
  49 : thread-status-foreground ( status -- color )
  50     {
  51       { +stopped+   [ thread-status-stopped-foreground ] }
  52       { +suspended+ [ thread-status-suspended-foreground ] }
  53       { +running+   [ thread-status-running-foreground ] }
  54       { f           [ text-color ] }
  55     } case ;
  56
  57 : thread-status-background ( status -- color )
  58     {
  59       { +stopped+   [ thread-status-stopped-background ] }
  60       { +suspended+ [ thread-status-suspended-background ] }
  61       { +running+   [ thread-status-running-background ] }
  62       { f           [ content-background ] }
  63     } case ;
  64
  65 TUPLE: thread-status < label ;
  66
  67 M: thread-status model-changed
  68     [ value>> ] dip {
  69         [ [ thread-status-text ] [ string<< ] bi* ]
  70         [ [ thread-status-foreground ] [ font>> foreground<< ] bi* ]
  71         [ [ thread-status-background <solid> ] [ parent>> parent>> interior<< ] bi* ]
  72     } 2cleave ;
  73
  74 : <thread-status> ( model -- gadget )
  75     "" thread-status new-label
  76         swap >>model ;
  77
  78 : add-thread-status ( track -- track )
  79     horizontal <track> { 5 5 } >>gap
  80         "Thread:" <label>
  81             [ t >>bold? text-color >>foreground ] change-font
  82             f track-add
  83         self name>> <label> [ text-color >>foreground ] change-font f track-add
  84         over status>> <thread-status>
  85             dup font>> t >>bold? drop
  86             f track-add
  87     margins f track-add ;
  88
  89 : add-traceback ( track -- track )
  90     dup traceback>> 1 track-add ;
  91
  92 : <walker-gadget> ( status continuation thread -- gadget )
  93     vertical walker-gadget new-track with-lines
  94         swap >>thread
  95         swap >>continuation
  96         swap >>status
  97         dup continuation>> <traceback-gadget> >>traceback
  98         add-toolbar
  99         add-thread-status
 100         add-traceback ;
 101
 102 : walker-help ( -- ) "ui-walker" com-browse ;
 103
 104 \ walker-help H{ { +nullary+ t } } define-command
 105
 106 walker-gadget "toolbar" f {
 107     { T{ key-down f f "s" } com-step }
 108     { T{ key-down f f "i" } com-into }
 109     { T{ key-down f f "o" } com-out }
 110     { T{ key-down f f "b" } com-back }
 111     { T{ key-down f f "c" } com-continue }
 112     { T{ key-down f f "a" } com-abandon }
 113     { T{ key-down f f "d" } close-window }
 114     { T{ key-down f f "F1" } walker-help }
 115 } define-command-map
 116
 117 walker-gadget "multitouch" f {
 118     { left-action com-back }
 119     { right-action com-step }
 120     { up-action com-out }
 121     { down-action com-into }
 122     { zoom-out-action close-window }
 123     { zoom-in-action com-abandon }
 124 } define-command-map
 125
 126 : walker-for-thread? ( thread gadget -- ? )
 127     {
 128         { [ dup walker-gadget? not ] [ 2drop f ] }
 129         { [ dup closing?>> ] [ 2drop f ] }
 130         [ thread>> eq? ]
 131     } cond ;
 132
 133 : find-walker-window ( thread -- world/f )
 134     '[ _ swap walker-for-thread? ] find-window ;
 135
 136 : walker-window ( status continuation thread -- )
 137     [ <walker-gadget> ] [ name>> ] bi open-status-window ;
 138
 139 [
 140     dup find-walker-window dup
 141     [ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if
 142 ] show-walker-hook set-global