basis/ui/tools/traceback/traceback.factor

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