basis/ui/tools/traceback/traceback.factor

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