basis/ui/tools/traceback/traceback.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors continuations kernel models namespaces arrays
   4 fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labeled assocs
   5 ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
   6 ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.borders
   7 ui.gadgets.tables ui.gestures sequences inspector
   8 models.arrow fonts ;
   9 QUALIFIED-WITH: ui.tools.inspector i
  10 IN: ui.tools.traceback
  11
  12 TUPLE: stack-entry object string ;
  13
  14 : <stack-entry> ( object -- stack-entry )
  15     dup unparse-short stack-entry boa ;
  16
  17 SINGLETON: stack-entry-renderer
  18
  19 M: stack-entry-renderer row-columns drop string>> 1array ;
  20
  21 M: stack-entry-renderer row-value drop object>> ;
  22
  23 : <stack-table> ( model -- table )
  24     [ [ <stack-entry> ] map ] <arrow> stack-entry-renderer <table>
  25         10 >>min-rows
  26         10 >>max-rows
  27         40 >>min-cols
  28         40 >>max-cols
  29         monospace-font >>font
  30         [ i:inspector ] >>action
  31         t >>single-click? ;
  32
  33 : <stack-display> ( model quot title -- gadget )
  34     [ '[ dup _ when ] <arrow> <stack-table> <scroller> ] dip
  35     <labeled-gadget> ;
  36
  37 : <callstack-display> ( model -- gadget )
  38     [ [ call>> callstack. ] when* ]
  39     <pane-control> t >>scrolls? <scroller>
  40     "Call stack" <labeled-gadget> ;
  41
  42 : <datastack-display> ( model -- gadget )
  43     [ data>> ] "Data stack" <stack-display> ;
  44
  45 : <retainstack-display> ( model -- gadget )
  46     [ retain>> ] "Retain stack" <stack-display> ;
  47
  48 TUPLE: traceback-gadget < track ;
  49
  50 : <traceback-gadget> ( model -- gadget )
  51     [
  52         vertical traceback-gadget new-track
  53         { 3 3 } >>gap
  54     ] dip
  55     [ >>model ]
  56     [
  57         [ vertical <track> { 3 3 } >>gap ] dip
  58         [
  59             [ horizontal <track> { 3 3 } >>gap ] dip
  60             [ <datastack-display> 1/2 track-add ]
  61             [ <retainstack-display> 1/2 track-add ] bi
  62             1/3 track-add
  63         ]
  64         [ <callstack-display> 2/3 track-add ] bi
  65         { 3 3 } <filled-border> 1 track-add
  66     ] bi
  67     add-toolbar ;
  68
  69 : variables ( traceback -- )
  70     model>> [ dup [ name>> vars-in-scope ] when ] <arrow> i:inspect-model ;
  71
  72 : traceback-window ( continuation -- )
  73     <model> <traceback-gadget> "Traceback" open-status-window ;
  74
  75 : inspect-continuation ( traceback -- )
  76     control-value i:inspector ;
  77
  78 traceback-gadget "toolbar" f {
  79     { T{ key-down f f "v" } variables }
  80     { T{ key-down f f "n" } inspect-continuation }
  81 } define-command-map