basis/ui/tools/walker/walker.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See https://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 ;
   8 IN: ui.tools.walker
   9
  10 TUPLE: walker-gadget < tool
  11 status continuation thread
  12 traceback
  13 closing? ;
  14
  15 : walker-command ( walker msg -- )
  16     swap
  17     dup thread>> thread-registered?
  18     [ thread>> send-synchronous drop ]
  19     [ 2drop ]
  20     if ;
  21
  22 : com-step ( walker -- ) step walker-command ;
  23
  24 : com-into ( walker -- ) step-into walker-command ;
  25
  26 : com-out ( walker -- ) step-out walker-command ;
  27
  28 : com-back ( walker -- ) step-back walker-command ;
  29
  30 : com-continue ( walker -- ) step-all walker-command ;
  31
  32 : com-abandon ( walker -- ) abandon walker-command ;
  33
  34 M: walker-gadget ungraft*
  35     [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
  36
  37 M: walker-gadget focusable-child*
  38     traceback>> ;
  39
  40 : thread-status-text ( status -- string )
  41     {
  42         { +stopped+ "Stopped" }
  43         { +suspended+ "Suspended" }
  44         { +running+ "Running" }
  45     } at "(" ")" surround ;
  46
  47 : thread-status-foreground ( status -- color )
  48     {
  49       { +stopped+   [ thread-status-stopped-foreground ] }
  50       { +suspended+ [ thread-status-suspended-foreground ] }
  51       { +running+   [ thread-status-running-foreground ] }
  52       { f           [ text-color ] }
  53     } case ;
  54
  55 : thread-status-background ( status -- color )
  56     {
  57       { +stopped+   [ thread-status-stopped-background ] }
  58       { +suspended+ [ thread-status-suspended-background ] }
  59       { +running+   [ thread-status-running-background ] }
  60       { f           [ content-background ] }
  61     } case ;
  62
  63 TUPLE: thread-status < label ;
  64
  65 M: thread-status model-changed
  66     [ value>> ] dip {
  67         [ [ thread-status-text ] [ string<< ] bi* ]
  68         [ [ thread-status-foreground ] [ font>> foreground<< ] bi* ]
  69         [ [ thread-status-background <solid> ] [ parent>> parent>> interior<< ] bi* ]
  70     } 2cleave ;
  71
  72 : <thread-status> ( model -- gadget )
  73     "" thread-status new-label
  74         swap >>model ;
  75
  76 : add-thread-status ( track -- track )
  77     horizontal <track> { 5 5 } >>gap
  78         "Thread:" <label>
  79             [ t >>bold? ] change-font
  80             f track-add
  81         self name>> <label> f track-add
  82         over status>> <thread-status>
  83             dup font>> t >>bold? drop
  84             f track-add
  85     margins f track-add ;
  86
  87 : add-traceback ( track -- track )
  88     dup traceback>> 1 track-add ;
  89
  90 : <walker-gadget> ( status continuation thread -- gadget )
  91     vertical walker-gadget new-track with-lines
  92         swap >>thread
  93         swap >>continuation
  94         swap >>status
  95         dup continuation>> <traceback-gadget> >>traceback
  96         add-toolbar
  97         add-thread-status
  98         add-traceback ;
  99
 100 : walker-help ( -- ) "ui-walker" com-browse ;
 101
 102 \ walker-help H{ { +nullary+ t } } define-command
 103
 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 }
 113 } define-command-map
 114
 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 }
 122 } define-command-map
 123
 124 : walker-for-thread? ( thread gadget -- ? )
 125     {
 126         { [ dup walker-gadget? not ] [ 2drop f ] }
 127         { [ dup closing?>> ] [ 2drop f ] }
 128         [ thread>> eq? ]
 129     } cond ;
 130
 131 : find-walker-window ( thread -- world/f )
 132     '[ _ swap walker-for-thread? ] find-window ;
 133
 134 : walker-window ( status continuation thread -- )
 135     [ <walker-gadget> ] [ name>> ] bi open-status-window ;
 136
 137 [
 138     dup find-walker-window dup
 139     [ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if
 140 ] show-walker-hook set-global