basis/ui/tools/debugger/debugger.factor

   1 ! Copyright (C) 2006, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays hashtables io kernel math models
   4 colors.constants namespaces sequences words continuations
   5 debugger prettyprint help editors fonts ui ui.commands
   6 ui.debugger ui.gestures ui.gadgets ui.pens.solid
   7 ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
   8 ui.gadgets.labels ui.gadgets.presentations ui.gadgets.panes
   9 ui.gadgets.viewports ui.gadgets.tables ui.theme
  10 ui.gadgets.tracks ui.gadgets.toolbar ui.gadgets.scrollers
  11 ui.gadgets.borders ui.gadgets.status-bar ui.theme.images
  12 ui.tools.traceback ui.tools.inspector ui.tools.browser
  13 ui.tools.common ;
  14 IN: ui.tools.debugger
  15
  16 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
  17
  18 <PRIVATE
  19
  20 SINGLETON: restart-renderer
  21
  22 M: restart-renderer row-columns
  23     drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;
  24
  25 : <restart-list> ( debugger -- gadget )
  26     dup restarts>> f prefix <model> restart-renderer <table>
  27         [
  28             [
  29                 ! The "Abort" restart is actually an `f` object, so to show a restart
  30                 ! with information but do nothing, we define a no-op-restart
  31                 dup obj>> no-op-restart =
  32                 [ drop ] [ \ continue-restart invoke-command ] if
  33             ] when*
  34         ] >>action
  35         swap restart-hook>> >>hook
  36         t >>selection-required?
  37         t >>single-click? ; inline
  38
  39 : <error-pane> ( error -- pane )
  40     <pane> [ [ print-error ] with-pane ] keep ; inline
  41
  42 : <error-display> ( debugger -- gadget )
  43     [ <filled-pile> ] dip
  44     [ error>> <error-pane> add-gadget ]
  45     [
  46         dup restart-hook>> [
  47             [ "To continue, pick one of the options below:" <label> add-gadget ] dip
  48             restart-list>> add-gadget
  49         ] [ drop ] if
  50     ] bi <scroller> ;
  51
  52 PRIVATE>
  53
  54 : <debugger> ( error continuation restarts restart-hook -- debugger )
  55     vertical debugger new-track with-lines
  56         swap >>restart-hook
  57         swap >>restarts
  58         swap >>continuation
  59         swap >>error
  60         dup <restart-list> >>restart-list
  61         dup <error-display> margins white-interior 1 track-add
  62         add-toolbar ;
  63
  64 M: debugger focusable-child*
  65     dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
  66
  67 : debugger-window ( error continuation -- )
  68     ! No restarts for the debugger window
  69     f f <debugger> "Error" open-status-window ;
  70
  71 GENERIC: error-in-debugger? ( error -- ? )
  72
  73 M: world-error error-in-debugger?
  74     world>> children>> ?first debugger? ;
  75
  76 M: object error-in-debugger? drop f ;
  77
  78 [
  79     dup error-in-debugger?
  80     [ error-alert ] [ error-continuation get debugger-window ] if
  81 ] ui-error-hook set-global
  82
  83 debugger "gestures" f {
  84     { T{ button-down } request-focus }
  85 } define-command-map
  86
  87 : com-inspect ( debugger -- ) error>> inspector ;
  88
  89 : com-traceback ( debugger -- ) continuation>> traceback-window ;
  90
  91 : com-help ( debugger -- ) error>> error-help-window ;
  92
  93 : com-edit ( debugger -- ) error>> edit-error ;
  94
  95 \ com-edit H{ { +listener+ t } } define-command
  96
  97 debugger "toolbar" f {
  98     { T{ key-down f f "i" } com-inspect }
  99     { T{ key-down f f "t" } com-traceback }
 100     { T{ key-down f f "h" } com-help }
 101     { T{ key-down f f "e" } com-edit }
 102 } define-command-map