Code cleanup, fix stack assertion error
parent
12db389fc2
commit
169b07e0b3
|
@ -7,6 +7,8 @@
|
||||||
- variable width word wrap
|
- variable width word wrap
|
||||||
- graphical crossref tool
|
- graphical crossref tool
|
||||||
- http://paste.lisp.org/display/30426
|
- http://paste.lisp.org/display/30426
|
||||||
|
- C+p: shows newlines as a box
|
||||||
|
- use mach exception handling to trap div by zero on os x
|
||||||
|
|
||||||
- menu Command: quots look dumb
|
- menu Command: quots look dumb
|
||||||
- top level window positioning on ms windows
|
- top level window positioning on ms windows
|
||||||
|
|
|
@ -80,19 +80,19 @@ M: listener-gadget tool-help
|
||||||
listener-gadget swap find-tool nip tool-gadget
|
listener-gadget swap find-tool nip tool-gadget
|
||||||
listener-gadget-input interactor-busy? ;
|
listener-gadget-input interactor-busy? ;
|
||||||
|
|
||||||
: find-listener ( -- listener )
|
: get-listener ( -- listener )
|
||||||
listener-gadget
|
listener-gadget
|
||||||
[ workspace-busy? not ] find-workspace*
|
[ workspace-busy? not ] get-workspace*
|
||||||
show-tool tool-gadget ;
|
show-tool tool-gadget ;
|
||||||
|
|
||||||
: (call-listener) ( quot listener -- )
|
: (call-listener) ( quot listener -- )
|
||||||
listener-gadget-input interactor-call ;
|
listener-gadget-input interactor-call ;
|
||||||
|
|
||||||
: call-listener ( quot -- )
|
: call-listener ( quot -- )
|
||||||
find-listener (call-listener) ;
|
get-listener (call-listener) ;
|
||||||
|
|
||||||
: eval-listener ( string -- )
|
: eval-listener ( string -- )
|
||||||
find-listener
|
get-listener
|
||||||
listener-gadget-input [ set-editor-text ] keep
|
listener-gadget-input [ set-editor-text ] keep
|
||||||
interactor-commit ;
|
interactor-commit ;
|
||||||
|
|
||||||
|
|
|
@ -33,7 +33,7 @@ M: messages compile-error
|
||||||
|
|
||||||
: <messages-button> ( -- gadget )
|
: <messages-button> ( -- gadget )
|
||||||
"Compiler messages"
|
"Compiler messages"
|
||||||
[ drop find-workspace messages select-tool ]
|
[ find-workspace messages select-tool ]
|
||||||
<bevel-button> ;
|
<bevel-button> ;
|
||||||
|
|
||||||
M: messages batch-ends
|
M: messages batch-ends
|
||||||
|
|
|
@ -80,7 +80,7 @@ M: operation invoke-command ( target operation -- )
|
||||||
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
|
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
|
||||||
|
|
||||||
: insert-word ( word -- )
|
: insert-word ( word -- )
|
||||||
find-listener [ word-completion-string ] keep
|
get-listener [ word-completion-string ] keep
|
||||||
listener-gadget-input user-input ;
|
listener-gadget-input user-input ;
|
||||||
|
|
||||||
[ word? ] H{
|
[ word? ] H{
|
||||||
|
@ -147,7 +147,7 @@ M: operation invoke-command ( target operation -- )
|
||||||
{ +primary+ t }
|
{ +primary+ t }
|
||||||
{ +name+ "Browse" }
|
{ +name+ "Browse" }
|
||||||
{ +keyboard+ T{ key-down f { A+ } "b" } }
|
{ +keyboard+ T{ key-down f { A+ } "b" } }
|
||||||
{ +quot+ [ vocab-link-name find-workspace swap show-vocab-words ] }
|
{ +quot+ [ vocab-link-name get-workspace swap show-vocab-words ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
[ vocab-link? ] H{
|
[ vocab-link? ] H{
|
||||||
|
@ -199,7 +199,7 @@ M: operation invoke-command ( target operation -- )
|
||||||
{ +primary+ t }
|
{ +primary+ t }
|
||||||
{ +name+ "Browse" }
|
{ +name+ "Browse" }
|
||||||
{ +keyboard+ T{ key-down f { A+ } "b" } }
|
{ +keyboard+ T{ key-down f { A+ } "b" } }
|
||||||
{ +quot+ [ find-workspace swap show-module-files ] }
|
{ +quot+ [ get-workspace swap show-module-files ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
[ module? ] H{
|
[ module? ] H{
|
||||||
|
|
|
@ -34,7 +34,7 @@ search-field H{
|
||||||
|
|
||||||
: <search-list> ( seq producer presenter -- gadget )
|
: <search-list> ( seq producer presenter -- gadget )
|
||||||
-rot curry <search-model>
|
-rot curry <search-model>
|
||||||
[ [ workspace? ] find-parent hide-popup ] -rot
|
[ find-workspace hide-popup ] -rot
|
||||||
<list> ;
|
<list> ;
|
||||||
|
|
||||||
C: live-search ( string seq producer presenter -- gadget )
|
C: live-search ( string seq producer presenter -- gadget )
|
||||||
|
@ -126,7 +126,7 @@ C: history-search ( string seq -- gadget )
|
||||||
[ delegate>live-search ] keep ;
|
[ delegate>live-search ] keep ;
|
||||||
|
|
||||||
: search-action ( search -- obj )
|
: search-action ( search -- obj )
|
||||||
dup [ workspace? ] find-parent hide-popup
|
dup find-workspace hide-popup
|
||||||
live-search-list list-value ;
|
live-search-list list-value ;
|
||||||
|
|
||||||
: show-titled-popup ( workspace gadget title -- )
|
: show-titled-popup ( workspace gadget title -- )
|
||||||
|
|
|
@ -22,6 +22,8 @@ M: gadget tool-help drop f ;
|
||||||
|
|
||||||
TUPLE: workspace book popup ;
|
TUPLE: workspace book popup ;
|
||||||
|
|
||||||
|
: find-workspace [ workspace? ] find-parent ;
|
||||||
|
|
||||||
TUPLE: tool gadget ;
|
TUPLE: tool gadget ;
|
||||||
|
|
||||||
: find-tool ( class workspace -- index tool )
|
: find-tool ( class workspace -- index tool )
|
||||||
|
@ -34,17 +36,17 @@ TUPLE: tool gadget ;
|
||||||
|
|
||||||
: select-tool ( workspace class -- ) swap show-tool drop ;
|
: select-tool ( workspace class -- ) swap show-tool drop ;
|
||||||
|
|
||||||
: find-workspace* ( quot -- workspace )
|
: get-workspace* ( quot -- workspace )
|
||||||
[ dup workspace? [ over call ] [ drop f ] if ] find-window
|
[ dup workspace? [ over call ] [ drop f ] if ] find-window
|
||||||
[ nip dup raise-window world-gadget ]
|
[ nip dup raise-window world-gadget ]
|
||||||
[ workspace-window drop find-workspace* ] if* ; inline
|
[ workspace-window drop get-workspace* ] if* ; inline
|
||||||
|
|
||||||
: find-workspace ( -- workspace ) [ drop t ] find-workspace* ;
|
: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
|
||||||
|
|
||||||
: call-tool ( arg class -- )
|
: call-tool ( arg class -- )
|
||||||
find-workspace show-tool call-tool* ;
|
get-workspace show-tool call-tool* ;
|
||||||
|
|
||||||
: get-tool ( class -- gadget )
|
: get-tool ( class -- gadget )
|
||||||
find-workspace find-tool nip tool-gadget ;
|
get-workspace find-tool nip tool-gadget ;
|
||||||
|
|
||||||
: find-messages ( -- gadget ) messages get-tool ;
|
: find-messages ( -- gadget ) messages get-tool ;
|
||||||
|
|
|
@ -75,7 +75,7 @@ M: walker-gadget tool-help drop "ui-walker" ;
|
||||||
|
|
||||||
: walker-step-all ( walker -- )
|
: walker-step-all ( walker -- )
|
||||||
dup [ step-all ] walker-command reset-walker
|
dup [ step-all ] walker-command reset-walker
|
||||||
find-workspace listener-gadget select-tool ;
|
get-workspace listener-gadget select-tool ;
|
||||||
|
|
||||||
walker-gadget "toolbar" {
|
walker-gadget "toolbar" {
|
||||||
{ "Step" T{ key-down f f "s" } [ walker-step ] }
|
{ "Step" T{ key-down f f "s" } [ walker-step ] }
|
||||||
|
|
Loading…
Reference in New Issue