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 kernel concurrency.messaging inspector
   4 ui.tools.listener ui.tools.traceback ui.gadgets.buttons
   5 ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
   6 models models.arrow ui.tools.browser ui.tools.common ui.gestures
   7 ui.gadgets.labels ui threads namespaces make tools.walker assocs
   8 combinators fry ;
   9 IN: ui.tools.walker
  10
  11 TUPLE: walker-gadget < tool
  12 status continuation thread
  13 traceback
  14 closing? ;
  15
  16 : walker-command ( walker msg -- )
  17     swap
  18     dup thread>> thread-registered?
  19     [ thread>> send-synchronous drop ]
  20     [ 2drop ]
  21     if ;
  22
  23 : com-step ( walker -- ) step walker-command ;
  24
  25 : com-into ( walker -- ) step-into walker-command ;
  26
  27 : com-out ( walker -- ) step-out walker-command ;
  28
  29 : com-back ( walker -- ) step-back walker-command ;
  30
  31 : com-continue ( walker -- ) step-all walker-command ;
  32
  33 : com-abandon ( walker -- ) abandon walker-command ;
  34
  35 M: walker-gadget ungraft*
  36     [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
  37
  38 M: walker-gadget focusable-child*
  39     traceback>> ;
  40
  41 : walker-state-string ( status thread -- string )
  42     [
  43         "Thread: " %
  44         dup name>> %
  45         " (" %
  46         swap {
  47             { +stopped+ "Stopped" }
  48             { +suspended+ "Suspended" }
  49             { +running+ "Running" }
  50         } at %
  51         ")" %
  52         drop
  53     ] "" make ;
  54
  55 : <thread-status> ( model thread -- gadget )
  56     '[ _ walker-state-string ] <arrow> <label-control> ;
  57
  58 : <walker-gadget> ( status continuation thread -- gadget )
  59     vertical walker-gadget new-track
  60         swap >>thread
  61         swap >>continuation
  62         swap >>status
  63         dup continuation>> <traceback-gadget> >>traceback
  64
  65         add-toolbar
  66         dup status>> self <thread-status> f track-add
  67         dup traceback>> 1 track-add ;
  68
  69 : walker-help ( -- ) "ui-walker" com-browse ;
  70
  71 \ walker-help H{ { +nullary+ t } } define-command
  72
  73 walker-gadget "toolbar" f {
  74     { T{ key-down f f "s" } com-step }
  75     { T{ key-down f f "i" } com-into }
  76     { T{ key-down f f "o" } com-out }
  77     { T{ key-down f f "b" } com-back }
  78     { T{ key-down f f "c" } com-continue }
  79     { T{ key-down f f "a" } com-abandon }
  80     { T{ key-down f f "d" } close-window }
  81     { T{ key-down f f "F1" } walker-help }
  82 } define-command-map
  83
  84 walker-gadget "multitouch" f {
  85     { left-action com-back }
  86     { right-action com-step }
  87     { up-action com-out }
  88     { down-action com-into }
  89     { zoom-out-action close-window }
  90     { zoom-in-action com-abandon }
  91 } define-command-map
  92
  93 : walker-for-thread? ( thread gadget -- ? )
  94     {
  95         { [ dup walker-gadget? not ] [ 2drop f ] }
  96         { [ dup closing?>> ] [ 2drop f ] }
  97         [ thread>> eq? ]
  98     } cond ;
  99
 100 : find-walker-window ( thread -- world/f )
 101     '[ _ swap walker-for-thread? ] find-window ;
 102
 103 : walker-window ( status continuation thread -- )
 104     [ <walker-gadget> ] [ name>> ] bi open-status-window ;
 105
 106 [
 107     dup find-walker-window dup
 108     [ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if
 109 ] show-walker-hook set-global