Rework listener's debugger-popup code

db4
Slava Pestov 2009-02-09 00:25:05 -06:00
parent 3ac409e432
commit cf4e0d78c3
9 changed files with 180 additions and 136 deletions

View File

@ -54,7 +54,10 @@ SYMBOL: visible-vars
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
: call-error-hook ( error -- )
error-continuation get error-hook get call ;
[ drop print-error-and-restarts ] error-hook set-global
SYMBOL: display-stacks?
@ -103,14 +106,8 @@ SYMBOL: max-stack-items
: listen ( -- )
visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup lexer-error? [
error-hook get call
] [
rethrow
] if
] recover ;
[ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
[ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
: until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;

View File

@ -1,9 +1,9 @@
USING: ui.gadgets help.markup help.syntax kernel quotations
continuations debugger ui ;
continuations debugger ui continuations ;
IN: ui.tools.debugger
HELP: <debugger>
{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" { $quotation "( list -- )" } } { "gadget" "a new " { $link gadget } } }
{ $values { "error" "an error" } { "continuation" continuation } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" { $quotation "( debugger -- )" } } { "debugger" "a new " { $link debugger } } }
{ $description
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
} ;
@ -11,5 +11,5 @@ HELP: <debugger>
{ <debugger> debugger-window } related-words
HELP: debugger-window
{ $values { "error" "an error" } }
{ $values { "error" "an error" } { "continuation" continuation } }
{ $description "Opens a window with a description of the error." } ;

View File

@ -1,47 +1,64 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math models
namespaces sequences sequences words continuations debugger
prettyprint help editors ui ui.commands ui.gestures ui.gadgets
prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ;
ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders
ui.tools.traceback ui.tools.inspector ;
IN: ui.tools.debugger
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
<PRIVATE
SINGLETON: restart-renderer
M: restart-renderer row-columns
drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;
: <restart-list> ( debugger -- gadget )
[ restart-hook>> ] [ restarts>> ] bi
[ name>> ] swap <model> <list> ; inline
dup restarts>> f prefix <model> <table>
[ [ \ restart invoke-command ] when* ] >>action
swap restart-hook>> >>hook
restart-renderer >>renderer
t >>selection-required?
t >>single-click? ; inline
: <error-pane> ( error -- pane )
<pane> [ [ print-error ] with-pane ] keep ; inline
: <debugger-display> ( debugger -- gadget )
<filled-pile>
over error>> <error-pane> add-gadget
swap restart-list>> add-gadget ; inline
: <error-display> ( debugger -- gadget )
[ <filled-pile> ] dip
[ error>> <error-pane> add-gadget ]
[
dup restart-hook>> [
[ "To continue, pick one of the options below:" <label> add-gadget ] dip
restart-list>> add-gadget
] [ drop ] if
] bi ;
PRIVATE>
: <debugger> ( error restarts restart-hook -- gadget )
: <debugger> ( error continuation restarts restart-hook -- gadget )
vertical debugger new-track
add-toolbar
{ 3 3 } >>gap
swap >>restart-hook
swap >>restarts
swap >>continuation
swap >>error
error-continuation get >>continuation
add-toolbar
dup <restart-list> >>restart-list
dup <debugger-display> <scroller> 1 track-add ;
dup <error-display> f track-add ;
M: debugger focusable-child* restart-list>> ;
M: debugger focusable-child*
dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
: debugger-window ( error -- )
: debugger-window ( error continuation -- )
#! No restarts for the debugger window
f [ drop ] <debugger> "Error" open-window ;
f f <debugger> "Error" open-window ;
GENERIC: error-in-debugger? ( error -- ? )
@ -50,7 +67,8 @@ M: world-error error-in-debugger? world>> gadget-child debugger? ;
M: object error-in-debugger? drop f ;
[
dup error-in-debugger? [ rethrow ] [ debugger-window ] if
dup error-in-debugger?
[ rethrow ] [ error-continuation get debugger-window ] if
] ui-error-hook set-global
M: world-error error.
@ -63,9 +81,9 @@ debugger "gestures" f {
{ T{ button-down } request-focus }
} define-command-map
: com-traceback ( debugger -- ) continuation>> traceback-window ;
: com-inspect ( debugger -- ) error>> inspector ;
\ com-traceback H{ } define-command
: com-traceback ( debugger -- ) continuation>> traceback-window ;
: com-help ( debugger -- ) error>> (:help) ;
@ -76,7 +94,8 @@ debugger "gestures" f {
\ com-edit H{ { +listener+ t } } define-command
debugger "toolbar" f {
{ T{ key-down f f "s" } com-traceback }
{ T{ key-down f f "h" } com-help }
{ T{ key-down f f "e" } com-edit }
{ T{ key-down f { C+ } "i" } com-inspect }
{ T{ key-down f { C+ } "t" } com-traceback }
{ T{ key-down f { C+ } "h" } com-help }
{ T{ key-down f { C+ } "e" } com-edit }
} define-command-map

View File

@ -8,11 +8,11 @@ generic.standard.engines.tuple fonts ui.commands ui.operations
ui.gadgets ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labelled
ui.gadgets.theme ui.gadgets.worlds ui.gadgets.wrappers ui.gestures
ui.render ui.tools.listener.history combinators vocabs ;
ui.render ui.tools.listener.history combinators vocabs
ui.tools.listener.popups ;
IN: ui.tools.listener.completion
! We don't directly depend on the listener tool but we use a few slots
SLOT: completion-popup
SLOT: interactor
SLOT: history
@ -88,7 +88,7 @@ M: vocab-completion row-color
[ drop <word-completion> ]
} cond ;
TUPLE: completion-popup < track table interactor completion-mode ;
TUPLE: completion-popup < track interactor table completion-mode ;
: find-completion-popup ( gadget -- popup )
[ completion-popup? ] find-parent ;
@ -99,12 +99,6 @@ TUPLE: completion-popup < track table interactor completion-mode ;
M: completion-popup focusable-child* table>> ;
M: completion-popup hide-glass-hook
interactor>> f >>completion-popup request-focus ;
: hide-completion-popup ( popup -- )
find-world hide-glass ;
: completion-loc/doc/elt ( popup -- loc doc elt )
[ interactor>> [ editor-caret ] [ model>> ] bi ]
[ completion-mode>> completion-element ]
@ -130,7 +124,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
find-completion-popup
[ insert-completion ]
[ accept-completion-hook ]
[ nip hide-completion-popup ]
[ nip hide-popup ]
2tri ;
: <completion-table> ( interactor completion-mode -- table )
@ -143,7 +137,8 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
: <completion-scroller> ( completion-popup -- scroller )
[ table>> ] [ interactor>> ] [ completion-mode>> ] tri completion-popup-width
[ <limited-scroller> ] [ 120 2array ] bi* [ >>min-dim ] [ >>max-dim ] bi ;
[ <limited-scroller> ] [ 120 2array ] bi*
[ >>min-dim ] [ >>max-dim ] bi ;
: <completion-popup> ( interactor completion-mode -- popup )
[ vertical completion-popup new-track ] 2dip
@ -153,44 +148,13 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
COLOR: white <solid> >>interior ;
completion-popup H{
{ T{ key-down f f "ESC" } [ hide-completion-popup ] }
{ T{ key-down f f "TAB" } [ table>> row-action ] }
{ T{ key-down f f " " } [ table>> row-action ] }
} set-gestures
CONSTANT: completion-popup-offset { -4 0 }
: (completion-popup-loc) ( interactor completion-mode -- loc )
[ drop screen-loc ] [
[
[ [ editor-caret ] [ model>> ] bi ] dip
completion-element prev-elt
] [ drop ] 2bi
loc>point
] 2bi v+ completion-popup-offset v+ ;
: completion-popup-loc-1 ( interactor completion-mode -- loc )
[ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
: completion-popup-loc-2 ( interactor completion-mode popup -- loc )
[ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
: completion-popup-fits? ( interactor completion-mode popup -- ? )
[ [ completion-popup-loc-1 ] dip pref-dim v+ ]
[ 2drop find-world dim>> ]
3bi [ second ] bi@ <= ;
: completion-popup-loc ( interactor completion-mode popup -- loc )
3dup completion-popup-fits?
[ drop completion-popup-loc-1 ]
[ completion-popup-loc-2 ]
if ;
: show-completion-popup ( interactor completion-mode -- )
2dup <completion-popup>
[ nip >>completion-popup drop ]
[ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
show-glass ;
: show-completion-popup ( interactor mode -- )
[ completion-element ] [ <completion-popup> ] 2bi
show-popup ;
: code-completion-popup ( interactor -- )
dup completion-mode show-completion-popup ;
@ -204,12 +168,6 @@ CONSTANT: completion-popup-offset { -4 0 }
: recall-next ( interactor -- )
history>> history-recall-next ;
: selected-word ( editor -- word )
dup completion-popup>>
[ [ table>> selected-row drop ] [ hide-completion-popup ] bi ]
[ selected-token dup search [ ] [ no-word ] ?if ]
?if ;
: completion-gesture ( gesture completion -- value/f operation/f )
table>> selected-row
[ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;

View File

@ -1,25 +1,25 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators
combinators.short-circuit compiler.units concurrency.flags
concurrency.mailboxes continuations destructors documents
documents.elements fry hashtables help help.markup io io.styles kernel
lexer listener math models models.delay models.filter namespaces
parser prettyprint quotations sequences strings threads tools.vocabs
vocabs vocabs.loader vocabs.parser words ui ui.commands ui.gadgets
ui.gadgets.buttons ui.gadgets.editors ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks
ui.gestures ui.operations ui.tools.browser ui.tools.common
ui.tools.debugger ui.tools.listener.completion
USING: accessors arrays assocs calendar combinators locals
colors.constants combinators.short-circuit compiler.units
concurrency.flags concurrency.mailboxes continuations destructors
documents documents.elements fry hashtables help help.markup io
io.styles kernel lexer listener math models models.delay models.filter
namespaces parser prettyprint quotations sequences strings threads
tools.vocabs vocabs vocabs.loader vocabs.parser words ui ui.commands
ui.render ui.gadgets ui.gadgets.buttons ui.gadgets.editors
ui.gadgets.frames ui.gadgets.grids ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.common ui.tools.debugger
ui.tools.listener.completion ui.tools.listener.popups
ui.tools.listener.history ;
IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking
! evaluate-input resumes the thread.
TUPLE: interactor < source-editor
output history flag mailbox thread waiting token-model word-model
completion-popup ;
output history flag mailbox thread waiting token-model word-model popup ;
: register-self ( interactor -- )
<mailbox> >>mailbox
@ -82,7 +82,7 @@ M: interactor ungraft*
M: interactor model-changed
2dup word-model>> eq? [
dup completion-popup>>
dup popup>>
[ 2drop ] [ [ value>> ] dip show-summary ] if
] [ call-next-method ] if ;
@ -163,7 +163,7 @@ M: interactor dispose drop ;
over set-caret
mark>caret ;
TUPLE: listener-gadget < tool input output scroller popup ;
TUPLE: listener-gadget < tool input output scroller ;
{ 550 700 } listener-gadget set-tool-dim
@ -194,7 +194,7 @@ TUPLE: listener-gadget < tool input output scroller popup ;
dup scroller>> 1 track-add ;
M: listener-gadget focusable-child*
[ popup>> ] [ input>> ] bi or ;
input>> dup popup>> or ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
@ -297,29 +297,20 @@ M: object accept-completion-hook 2drop ;
[ history>> history-add drop ] [ control-value ] [ select-all ] tri
[ parse-lines ] with-compilation-unit ;
: hide-popup ( listener -- )
dup popup>> track-remove
f >>popup
request-focus ;
:: <debugger-popup> ( interactor error continuation -- popup )
error continuation error compute-restarts
[ interactor hide-popup ] <debugger>
COLOR: white <solid> >>interior
COLOR: black <solid> >>boundary
"Error" <labelled-gadget> ;
: show-popup ( gadget listener -- )
dup hide-popup
over >>popup
over f track-add drop
request-focus ;
: show-titled-popup ( listener gadget title -- )
[ find-listener hide-popup ] <closable-gadget>
swap show-popup ;
: debugger-popup ( error listener -- )
swap dup compute-restarts
[ find-listener hide-popup ] <debugger>
"Error" show-titled-popup ;
: debugger-popup ( interactor error continuation -- )
[ [ drop one-line-elt ] 2keep ] dip <debugger-popup> show-popup ;
: handle-parse-error ( interactor error -- )
dup lexer-error? [ 2dup go-to-error error>> ] when
swap find-listener debugger-popup ;
error-continuation get
debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
[ drop parse-lines-interactive ] [
@ -347,7 +338,7 @@ M: interactor stream-read-quot
} cond ;
: pass-to-popup ( gesture interactor -- ? )
completion-popup>> focusable-child resend-gesture ;
popup>> focusable-child resend-gesture ;
: interactor-operation ( gesture interactor -- ? )
[ token-model>> value>> ] keep word-at-caret
@ -356,7 +347,7 @@ M: interactor stream-read-quot
M: interactor handle-gesture
{
{ [ over key-gesture? not ] [ call-next-method ] }
{ [ dup completion-popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
{ [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
{ [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
[ call-next-method ]
} cond ;
@ -381,7 +372,7 @@ interactor "completion" f {
: listener-thread ( listener -- )
dup listener-streams [
[ com-follow ] help-hook set
'[ _ debugger-popup ] error-hook set
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
welcome.
listener
] with-streams* ;
@ -438,10 +429,6 @@ listener-gadget "multi-touch" f {
{ up-action refresh-all }
} define-command-map
listener-gadget "other" f {
{ T{ key-down f f "ESC" } hide-popup }
} define-command-map
M: listener-gadget graft*
[ call-next-method ] [ restart-listener ] bi ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test ui.tools.listener.popups ;
IN: ui.tools.listener.popups.tests

View File

@ -0,0 +1,58 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors documents.elements kernel math math.vectors
sequences ui.gadgets ui.gadgets.editors ui.gadgets.glass
ui.gadgets.tracks ui.gadgets.wrappers
ui.gadgets.worlds ui.gestures ;
IN: ui.tools.listener.popups
SLOT: popup
TUPLE: popup < wrapper interactor element ;
: <popup> ( interactor element gadget -- popup )
popup new-wrapper
swap >>element
swap >>interactor ;
M: popup hide-glass-hook
interactor>> f >>popup request-focus ;
: hide-popup ( popup -- )
find-world hide-glass ;
popup H{
{ T{ key-down f f "ESC" } [ hide-popup ] }
} set-gestures
CONSTANT: popup-offset { -4 0 }
: (popup-loc) ( interactor element -- loc )
[ drop screen-loc ] [
[
[ [ editor-caret ] [ model>> ] bi ] dip
prev-elt
] [ drop ] 2bi
loc>point
] 2bi v+ popup-offset v+ ;
: popup-loc-1 ( interactor element -- loc )
[ (popup-loc) ] [ drop caret-dim ] 2bi v+ ;
: popup-loc-2 ( interactor element popup -- loc )
[ (popup-loc) ] dip pref-dim { 0 1 } v* v- ;
: popup-fits? ( interactor element popup -- ? )
[ [ popup-loc-1 ] dip pref-dim v+ ]
[ 2drop find-world dim>> ]
3bi [ second ] bi@ <= ;
: popup-loc ( popup -- loc )
[ interactor>> ] [ element>> ] [ ] tri 3dup popup-fits?
[ drop popup-loc-1 ] [ popup-loc-2 ] if ;
: show-popup ( interactor element popup -- )
<popup>
[ dup interactor>> (>>popup) ]
[ [ interactor>> find-world ] [ ] [ popup-loc ] tri show-glass ]
bi ;

View File

@ -1,24 +1,44 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
USING: accessors continuations kernel models namespaces arrays
fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers
ui.gestures sequences inspector models.filter ;
ui.gadgets.tables ui.gestures sequences inspector
models.filter ;
QUALIFIED-WITH: ui.tools.inspector i
IN: ui.tools.traceback
TUPLE: stack-entry object string ;
: <stack-entry> ( object -- stack-entry )
dup unparse-short stack-entry boa ;
SINGLETON: stack-entry-renderer
M: stack-entry-renderer row-columns drop string>> 1array ;
M: stack-entry-renderer row-value drop object>> ;
: <stack-table> ( model -- table )
[ [ <stack-entry> ] map ] <filter> <table>
[ i:inspector ] >>action
stack-entry-renderer >>renderer
t >>single-click? ;
: <stack-display> ( model quot title -- gadget )
[ '[ dup _ when ] <filter> <stack-table> <scroller> ] dip
<labelled-gadget> ;
: <callstack-display> ( model -- gadget )
[ [ call>> callstack. ] when* ]
t "Call stack" <labelled-pane> ;
: <datastack-display> ( model -- gadget )
[ [ data>> stack. ] when* ]
t "Data stack" <labelled-pane> ;
[ data>> ] "Data stack" <stack-display> ;
: <retainstack-display> ( model -- gadget )
[ [ retain>> stack. ] when* ]
t "Retain stack" <labelled-pane> ;
[ retain>> ] "Retain stack" <stack-display> ;
TUPLE: traceback-gadget < track ;