library/ui/tools/walker.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-walker
   4 USING: arrays errors gadgets gadgets-buttons gadgets-frames
   5 gadgets-listener gadgets-panes gadgets-scrolling gadgets-text
   6 gadgets-tracks gadgets-workspace generic hashtables tools
   7 interpreter io kernel kernel-internals listener math models
   8 namespaces sequences shells threads vectors ;
   9
  10 : <callstack-display> ( model -- )
  11     [ [ continuation-call callstack. ] when* ]
  12     "Call stack" <labelled-pane> ;
  13
  14 : <datastack-display> ( model -- )
  15     [ [ continuation-data stack. ] when* ]
  16     "Data stack" <labelled-pane> ;
  17
  18 : <retainstack-display> ( model -- )
  19     [ [ continuation-retain stack. ] when* ]
  20     "Retain stack" <labelled-pane> ;
  21
  22 : <quotation-display> ( quot -- gadget )
  23     [ [ first2 callframe. ] when* ]
  24     "Current quotation" <labelled-pane> ;
  25
  26 TUPLE: walker-gadget model quot ns ;
  27
  28 : update-stacks ( walker -- )
  29     meta-interp get over walker-gadget-model set-model
  30     meta-callframe swap walker-gadget-quot set-model ;
  31
  32 : with-walker ( gadget quot -- )
  33     swap dup walker-gadget-ns
  34     [ slip update-stacks ] bind ; inline
  35
  36 : walker-command ( gadget quot -- )
  37     meta-interp pick walker-gadget-ns hash
  38     [ with-walker ] [ 2drop ] if ; inline
  39
  40 : reset-walker ( walker -- )
  41     dup H{ } clone swap set-walker-gadget-ns
  42     update-stacks ;
  43
  44 : walker-step [ step ] walker-command ;
  45 : walker-step-in [ step-in ] walker-command ;
  46 : walker-step-out [ step-out ] walker-command ;
  47 : walker-step-back [ step-back ] walker-command ;
  48
  49 : init-walker-models ( walker -- )
  50     f <model> over set-walker-gadget-quot
  51     f <model> swap set-walker-gadget-model ;
  52
  53 : walker-gadget-quot$ gadget get walker-gadget-quot ;
  54 : walker-gadget-model$ gadget get walker-gadget-model ;
  55
  56 C: walker-gadget ( -- gadget )
  57     dup init-walker-models {
  58         { [ walker-gadget-quot$ <quotation-display> ] f f 1/6 }
  59         { [ walker-gadget-model$ <datastack-display> ] f f 1/4 }
  60         { [ walker-gadget-model$ <retainstack-display> ] f f 1/4 }
  61         { [ walker-gadget-model$ <callstack-display> ] f f 1/3 }
  62     } { 0 1 } make-track* ;
  63
  64 M: walker-gadget call-tool* ( continuation walker -- )
  65     dup reset-walker [
  66         V{ } clone meta-history set
  67         restore-normally
  68     ] with-walker ;
  69
  70 M: walker-gadget tool-help drop "ui-walker" ;
  71
  72 : walker-inspect ( walker -- )
  73     walker-gadget-ns [ meta-interp get ] bind
  74     [ inspect ] curry call-listener ;
  75
  76 : walker-step-all ( walker -- )
  77     dup [ step-all ] walker-command reset-walker
  78     find-workspace listener-gadget select-tool ;
  79
  80 walker-gadget "toolbar" {
  81     { "Step" T{ key-down f f "s" } [ walker-step ] }
  82     { "Step in" T{ key-down f f "i" } [ walker-step-in ] }
  83     { "Step out" T{ key-down f f "o" } [ walker-step-out ] }
  84     { "Step back" T{ key-down f f "b" } [ walker-step-back ] }
  85     { "Continue" T{ key-down f f "c" } [ walker-step-all ] }
  86     { "Inspect" T{ key-down f f "n" } [ walker-inspect ] }
  87 } define-commands
  88
  89 [ walker-gadget call-tool stop ] break-hook set-global
  90
  91 IN: tools
  92
  93 : walk ( quot -- ) [ break ] swap append call ;