basis/ui/tools/debugger/debugger.factor

   1 ! Copyright (C) 2006, 2009 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 debugger
   5 prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets
   6 ui.pens.solid ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
   7 ui.gadgets.labels ui.gadgets.presentations ui.gadgets.viewports
   8 ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers
   9 ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
  10 ui.tools.inspector ui.tools.browser ui.debugger ;
  11 IN: ui.tools.debugger
  12
  13 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
  14
  15 <PRIVATE
  16
  17 SINGLETON: restart-renderer
  18
  19 M: restart-renderer row-columns
  20     drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;
  21
  22 : <restart-list> ( debugger -- gadget )
  23     dup restarts>> f prefix <model> restart-renderer <table>
  24         [ [ \ restart invoke-command ] when* ] >>action
  25         swap restart-hook>> >>hook
  26         t >>selection-required?
  27         t >>single-click? ; inline
  28
  29 : <error-display> ( debugger -- gadget )
  30     [ <filled-pile> ] dip
  31     [ error>> <error-pane> add-gadget ]
  32     [
  33         dup restart-hook>> [
  34             [ "To continue, pick one of the options below:" <label> add-gadget ] dip
  35             restart-list>> add-gadget
  36         ] [ drop ] if
  37     ] bi ;
  38
  39 PRIVATE>
  40
  41 : <debugger> ( error continuation restarts restart-hook -- debugger )
  42     vertical debugger new-track
  43         { 3 3 } >>gap
  44         swap >>restart-hook
  45         swap >>restarts
  46         swap >>continuation
  47         swap >>error
  48         add-toolbar
  49         dup <restart-list> >>restart-list
  50         dup <error-display> f track-add
  51         COLOR: white <solid> >>interior ;
  52
  53 M: debugger focusable-child*
  54     dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
  55
  56 : debugger-window ( error continuation -- )
  57     #! No restarts for the debugger window
  58     f f <debugger> "Error" open-status-window ;
  59
  60 GENERIC: error-in-debugger? ( error -- ? )
  61
  62 M: world-error error-in-debugger?
  63     world>> children>> [ f ] [ first debugger? ] if-empty ;
  64
  65 M: object error-in-debugger? drop f ;
  66
  67 [
  68     dup error-in-debugger?
  69     [ rethrow ] [ error-continuation get debugger-window ] if
  70 ] ui-error-hook set-global
  71
  72 debugger "gestures" f {
  73     { T{ button-down } request-focus }
  74 } define-command-map
  75
  76 : com-inspect ( debugger -- ) error>> inspector ;
  77
  78 : com-traceback ( debugger -- ) continuation>> traceback-window ;
  79
  80 : com-help ( debugger -- ) error>> error-help-window ;
  81
  82 : com-edit ( debugger -- ) error>> edit-error ;
  83
  84 \ com-edit H{ { +listener+ t } } define-command
  85
  86 debugger "toolbar" f {
  87     { T{ key-down f { C+ } "i" } com-inspect }
  88     { T{ key-down f { C+ } "t" } com-traceback }
  89     { T{ key-down f { C+ } "h" } com-help }
  90     { T{ key-down f { C+ } "e" } com-edit }
  91 } define-command-map