basis/ui/tools/debugger/debugger.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays hashtables io kernel math models
   4 namespaces sequences sequences words continuations debugger
   5 prettyprint help editors ui ui.commands ui.gestures ui.gadgets
   6 ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
   7 ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
   8 ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
   9 ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ;
  10 IN: ui.tools.debugger
  11
  12 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
  13
  14 <PRIVATE
  15
  16 : <restart-list> ( debugger -- gadget )
  17     [ restart-hook>> ] [ restarts>> ] bi
  18     [ name>> ] swap <model> <list> ; inline
  19
  20 : <error-pane> ( error -- pane )
  21     <pane> [ [ print-error ] with-pane ] keep ; inline
  22
  23 : <debugger-display> ( debugger -- gadget )
  24     <filled-pile>
  25         over error>> <error-pane> add-gadget
  26         swap restart-list>> add-gadget ; inline
  27
  28 PRIVATE>
  29
  30 : <debugger> ( error restarts restart-hook -- gadget )
  31     { 0 1 } debugger new-track
  32         add-toolbar
  33         swap >>restart-hook
  34         swap >>restarts
  35         swap >>error
  36         error-continuation get >>continuation
  37         dup <restart-list> >>restart-list
  38         dup <debugger-display> <scroller> 1 track-add ;
  39
  40 M: debugger focusable-child* restart-list>> ;
  41
  42 : debugger-window ( error -- )
  43     #! No restarts for the debugger window
  44     f [ drop ] <debugger> "Error" open-window ;
  45
  46 GENERIC: error-in-debugger? ( error -- ? )
  47
  48 M: world-error error-in-debugger? world>> gadget-child debugger? ;
  49
  50 M: object error-in-debugger? drop f ;
  51
  52 [
  53     dup error-in-debugger? [ rethrow ] [ debugger-window ] if
  54 ] ui-error-hook set-global
  55
  56 M: world-error error.
  57     "An error occurred while drawing the world " write
  58     dup world>> pprint-short "." print
  59     "This world has been deactivated to prevent cascading errors." print
  60     error>> error. ;
  61
  62 debugger "gestures" f {
  63     { T{ button-down } request-focus }
  64 } define-command-map
  65
  66 : com-traceback ( debugger -- ) continuation>> traceback-window ;
  67
  68 \ com-traceback H{ } define-command
  69
  70 : com-help ( debugger -- ) error>> (:help) ;
  71
  72 \ com-help H{ { +listener+ t } } define-command
  73
  74 : com-edit ( debugger -- ) error>> (:edit) ;
  75
  76 \ com-edit H{ { +listener+ t } } define-command
  77
  78 debugger "toolbar" f {
  79     { T{ key-down f f "s" } com-traceback }
  80     { T{ key-down f f "h" } com-help }
  81     { T{ key-down f f "e" } com-edit }
  82 } define-command-map