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