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 colors.constants 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 CONSTANT: data-stack-color COLOR: DodgerBlue
  25 CONSTANT: retain-stack-color COLOR: HotPink
  26 CONSTANT: call-stack-color COLOR: GreenYellow
  27
  28 : <stack-table> ( model -- table )
  29     [ [ <stack-entry> ] map ] <arrow> stack-entry-renderer <table>
  30         10 >>min-rows
  31         10 >>max-rows
  32         40 >>min-cols
  33         40 >>max-cols
  34         monospace-font >>font
  35         [ i:inspector ] >>action
  36         t >>single-click? ;
  37
  38 : <stack-display> ( model quot title color -- gadget )
  39     [ '[ dup _ when ] <arrow> <stack-table> margins <scroller> white-interior ] 2dip
  40     <labeled-gadget> ; ! Il attend le titre en dernier
  41
  42 : <callstack-display> ( model -- gadget )
  43     [ [ call>> callstack. ] when* ]
  44     <pane-control> t >>scrolls? margins <scroller> white-interior
  45     "Call stack" call-stack-color <labeled-gadget> ;
  46
  47 : <datastack-display> ( model -- gadget )
  48     [ data>> ] "Data stack" data-stack-color <stack-display> ;
  49
  50 : <retainstack-display> ( model -- gadget )
  51     [ retain>> ] "Retain stack" retain-stack-color <stack-display> ;
  52
  53 TUPLE: traceback-gadget < tool ;
  54
  55 : <traceback-gadget> ( model -- gadget )
  56     [
  57         vertical traceback-gadget new-track
  58         with-lines
  59     ] dip
  60     [ >>model ]
  61     [
  62         [ vertical <track> with-lines ] dip
  63         [
  64             [ horizontal <track> with-lines ] dip
  65             [ <datastack-display> 1/2 track-add ]
  66             [ <retainstack-display> 1/2 track-add ] bi
  67             1/3 track-add
  68         ]
  69         [ <callstack-display> 2/3 track-add ] bi
  70          1 track-add
  71     ] bi
  72     add-toolbar ;
  73
  74 : variables ( traceback -- )
  75     model>> [ dup [ name>> vars-in-scope ] when ] <arrow> i:inspect-model ;
  76
  77 : traceback-window ( continuation -- )
  78     <model> <traceback-gadget> "Traceback" open-status-window ;
  79
  80 : inspect-continuation ( traceback -- )
  81     control-value i:inspector ;
  82
  83 traceback-gadget "toolbar" f {
  84     { T{ key-down f f "v" } variables }
  85     { T{ key-down f f "n" } inspect-continuation }
  86 } define-command-map