Cleaning up some code
parent
b9e3d55959
commit
e703dd2b8d
|
@ -39,7 +39,7 @@ M: frame layout*
|
|||
grid-layout ;
|
||||
|
||||
: make-frame ( quot -- frame )
|
||||
<frame> make-gadget ; inline
|
||||
<frame> swap make-gadget ; inline
|
||||
|
||||
: frame, ( gadget i j -- )
|
||||
\ make-gadget get -rot grid-add ;
|
||||
gadget get -rot grid-add ;
|
||||
|
|
|
@ -235,8 +235,8 @@ HELP: gadget,
|
|||
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
|
||||
|
||||
HELP: make-gadget
|
||||
{ $values { "quot" quotation } { "gadget" gadget } }
|
||||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ;
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
|
||||
|
||||
HELP: with-gadget
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
|
|
|
@ -391,19 +391,17 @@ M: f request-focus-on 2drop ;
|
|||
: focus-path ( world -- seq )
|
||||
[ gadget-focus ] follow ;
|
||||
|
||||
: make-gadget ( quot gadget -- gadget )
|
||||
[ \ make-gadget rot with-variable ] keep ; inline
|
||||
|
||||
: gadget, ( gadget -- ) \ make-gadget get add-gadget ;
|
||||
: gadget, ( gadget -- ) gadget get add-gadget ;
|
||||
|
||||
: g ( -- gadget ) gadget get ;
|
||||
|
||||
: g-> ( x -- x x gadget ) dup g ;
|
||||
|
||||
: with-gadget ( gadget quot -- )
|
||||
[
|
||||
swap dup \ make-gadget set gadget set call
|
||||
] with-scope ; inline
|
||||
gadget swap with-variable ; inline
|
||||
|
||||
: make-gadget ( gadget quot -- gadget )
|
||||
[ with-gadget ] [ drop ] 2bi ; inline
|
||||
|
||||
! Deprecated
|
||||
: set-gadget-delegate ( gadget tuple -- )
|
||||
|
|
|
@ -13,11 +13,9 @@ TUPLE: labelled-gadget < track content ;
|
|||
: <labelled-gadget> ( gadget title -- newgadget )
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
[
|
||||
[
|
||||
<label> reverse-video-theme f track,
|
||||
g-> set-labelled-gadget-content 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
<label> reverse-video-theme f track,
|
||||
g-> set-labelled-gadget-content 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
|
||||
|
@ -54,10 +52,8 @@ TUPLE: closable-gadget < frame content ;
|
|||
: <closable-gadget> ( gadget title quot -- gadget )
|
||||
closable-gadget new-frame
|
||||
[
|
||||
[
|
||||
<title-bar> @top frame,
|
||||
g-> set-closable-gadget-content @center frame,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
<title-bar> @top frame,
|
||||
g-> set-closable-gadget-content @center frame,
|
||||
] make-gadget ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
|
|
@ -62,10 +62,10 @@ M: pack children-on ( rect gadget -- seq )
|
|||
[ fast-children-on ] keep <slice> ;
|
||||
|
||||
: make-pile ( quot -- pack )
|
||||
<pile> make-gadget ; inline
|
||||
<pile> swap make-gadget ; inline
|
||||
|
||||
: make-filled-pile ( quot -- pack )
|
||||
<filled-pile> make-gadget ; inline
|
||||
<filled-pile> swap make-gadget ; inline
|
||||
|
||||
: make-shelf ( quot -- pack )
|
||||
<shelf> make-gadget ; inline
|
||||
<shelf> swap make-gadget ; inline
|
||||
|
|
|
@ -46,12 +46,10 @@ scroller H{
|
|||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
[
|
||||
[
|
||||
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
||||
y-model <y-slider> g-> set-scroller-y @right frame,
|
||||
viewport,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
||||
y-model <y-slider> g-> set-scroller-y @right frame,
|
||||
viewport,
|
||||
] make-gadget ;
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
scroller new-scroller ;
|
||||
|
|
|
@ -149,12 +149,12 @@ M: elevator layout*
|
|||
: <right-button> ( -- button )
|
||||
{ 0 1 } arrow-right 1 <slide-button> ;
|
||||
|
||||
: build-x-slider ( slider -- )
|
||||
: build-x-slider ( slider -- slider )
|
||||
[
|
||||
<left-button> @left frame,
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right frame,
|
||||
] with-gadget ;
|
||||
] make-gadget ; inline
|
||||
|
||||
: <up-button> ( -- button )
|
||||
{ 1 0 } arrow-up -1 <slide-button> ;
|
||||
|
@ -162,12 +162,12 @@ M: elevator layout*
|
|||
: <down-button> ( -- button )
|
||||
{ 1 0 } arrow-down 1 <slide-button> ;
|
||||
|
||||
: build-y-slider ( slider -- )
|
||||
: build-y-slider ( slider -- slider )
|
||||
[
|
||||
<up-button> @top frame,
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom frame,
|
||||
] with-gadget ;
|
||||
] make-gadget ; inline
|
||||
|
||||
: <slider> ( range orientation -- slider )
|
||||
slider new-frame
|
||||
|
@ -176,10 +176,10 @@ M: elevator layout*
|
|||
32 >>line ;
|
||||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider> dup build-x-slider ;
|
||||
{ 1 0 } <slider> build-x-slider ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
{ 0 1 } <slider> dup build-y-slider ;
|
||||
{ 0 1 } <slider> build-y-slider ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup call-next-method
|
||||
|
|
|
@ -72,12 +72,10 @@ M: value-ref finish-editing
|
|||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
[
|
||||
[
|
||||
toolbar,
|
||||
<source-editor> g-> set-slot-editor-text
|
||||
<scroller> 1 track,
|
||||
] with-gadget
|
||||
] keep
|
||||
toolbar,
|
||||
<source-editor> g-> set-slot-editor-text
|
||||
<scroller> 1 track,
|
||||
] make-gadget
|
||||
dup revert ;
|
||||
|
||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||
|
|
|
@ -50,10 +50,10 @@ M: track pref-dim*
|
|||
over track-sizes push add-gadget ;
|
||||
|
||||
: track, ( gadget constraint -- )
|
||||
\ make-gadget get swap track-add ;
|
||||
gadget get swap track-add ;
|
||||
|
||||
: make-track ( quot orientation -- track )
|
||||
<track> make-gadget ; inline
|
||||
<track> swap make-gadget ; inline
|
||||
|
||||
: track-remove ( gadget track -- )
|
||||
over [
|
||||
|
|
|
@ -23,12 +23,10 @@ TUPLE: browser-gadget < track pane history ;
|
|||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
[
|
||||
[
|
||||
toolbar,
|
||||
g <help-pane> g-> set-browser-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
toolbar,
|
||||
g <help-pane> g-> set-browser-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
M: browser-gadget call-tool* show-help ;
|
||||
|
||||
|
|
|
@ -23,12 +23,10 @@ TUPLE: debugger < track restarts ;
|
|||
: <debugger> ( error restarts restart-hook -- gadget )
|
||||
{ 0 1 } debugger new-track
|
||||
[
|
||||
[
|
||||
toolbar,
|
||||
<restart-list> g-> set-debugger-restarts
|
||||
swap <debugger-display> <scroller> 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
toolbar,
|
||||
<restart-list> g-> set-debugger-restarts
|
||||
swap <debugger-display> <scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
M: debugger focusable-child* debugger-restarts ;
|
||||
|
||||
|
|
|
@ -109,12 +109,10 @@ deploy-gadget "toolbar" f {
|
|||
swap >>vocab
|
||||
{ 0 1 } >>orientation
|
||||
[
|
||||
[
|
||||
g vocab>> <deploy-settings>
|
||||
g-> set-deploy-gadget-settings gadget,
|
||||
buttons,
|
||||
] with-gadget
|
||||
] keep
|
||||
g vocab>> <deploy-settings>
|
||||
g-> set-deploy-gadget-settings gadget,
|
||||
buttons,
|
||||
] make-gadget
|
||||
dup deploy-settings-theme
|
||||
dup com-revert ;
|
||||
|
||||
|
|
|
@ -16,11 +16,9 @@ TUPLE: inspector-gadget < track object pane ;
|
|||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
[
|
||||
[
|
||||
toolbar,
|
||||
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
toolbar,
|
||||
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
: inspect-object ( obj inspector -- )
|
||||
[ set-inspector-gadget-object ] keep refresh ;
|
||||
|
|
|
@ -124,12 +124,10 @@ TUPLE: stack-display < track ;
|
|||
g workspace-listener
|
||||
{ 0 1 } stack-display new-track
|
||||
[
|
||||
[
|
||||
dup <toolbar> f track,
|
||||
stack>> [ [ stack. ] curry try ]
|
||||
t "Data stack" <labelled-pane> 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
dup <toolbar> f track,
|
||||
stack>> [ [ stack. ] curry try ]
|
||||
t "Data stack" <labelled-pane> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
find-workspace workspace-listener tool-scroller ;
|
||||
|
@ -174,7 +172,7 @@ M: stack-display tool-scroller
|
|||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
[ [ listener-output, listener-input, ] with-gadget ] keep ;
|
||||
[ listener-output, listener-input, ] make-gadget ;
|
||||
|
||||
: listener-help ( -- ) "ui-listener" help-window ;
|
||||
|
||||
|
|
|
@ -10,12 +10,10 @@ TUPLE: profiler-gadget < track pane ;
|
|||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
[
|
||||
[
|
||||
toolbar,
|
||||
<pane> g-> set-profiler-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
toolbar,
|
||||
<pane> g-> set-profiler-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r profiler-gadget-pane r> with-pane ;
|
||||
|
|
|
@ -62,12 +62,10 @@ search-field H{
|
|||
: <live-search> ( string seq limited? presenter -- gadget )
|
||||
{ 0 1 } live-search new-track
|
||||
[
|
||||
[
|
||||
<search-field> g-> set-live-search-field f track,
|
||||
<search-list> g-> set-live-search-list
|
||||
<scroller> 1 track,
|
||||
] with-gadget
|
||||
] keep
|
||||
<search-field> g-> set-live-search-field f track,
|
||||
<search-list> g-> set-live-search-list
|
||||
<scroller> 1 track,
|
||||
] make-gadget
|
||||
[ live-search-field set-editor-string ] keep
|
||||
[ live-search-field end-of-document ] keep ;
|
||||
|
||||
|
|
|
@ -30,15 +30,13 @@ IN: ui.tools
|
|||
{ 0 1 } workspace new-track
|
||||
0 <model> >>model
|
||||
[
|
||||
[
|
||||
<listener-gadget> g set-workspace-listener
|
||||
<workspace-book> g set-workspace-book
|
||||
<workspace-tabs> f track,
|
||||
g workspace-book 1/5 track,
|
||||
g workspace-listener 4/5 track,
|
||||
toolbar,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
<listener-gadget> g set-workspace-listener
|
||||
<workspace-book> g set-workspace-book
|
||||
<workspace-tabs> f track,
|
||||
g workspace-book 1/5 track,
|
||||
g workspace-listener 4/5 track,
|
||||
toolbar,
|
||||
] make-gadget ;
|
||||
|
||||
: resize-workspace ( workspace -- )
|
||||
dup track-sizes over control-value zero? [
|
||||
|
|
|
@ -27,15 +27,17 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
{ 0 1 } traceback-gadget new-track
|
||||
swap >>model
|
||||
[
|
||||
g model>>
|
||||
[
|
||||
[
|
||||
g gadget-model <datastack-display> 1/2 track,
|
||||
g gadget-model <retainstack-display> 1/2 track,
|
||||
[ <datastack-display> 1/2 track, ]
|
||||
[ <retainstack-display> 1/2 track, ]
|
||||
bi
|
||||
] { 1 0 } make-track 1/3 track,
|
||||
g gadget-model <callstack-display> 2/3 track,
|
||||
toolbar,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
]
|
||||
[ <callstack-display> 2/3 track, ] bi
|
||||
toolbar,
|
||||
] make-gadget ;
|
||||
|
||||
: <namestack-display> ( model -- gadget )
|
||||
[ [ continuation-name namestack. ] when* ]
|
||||
|
|
|
@ -60,13 +60,12 @@ M: walker-gadget focusable-child*
|
|||
swap >>thread
|
||||
swap >>continuation
|
||||
swap >>status
|
||||
dup continuation>> <traceback-gadget> >>traceback
|
||||
[
|
||||
[
|
||||
toolbar,
|
||||
g status>> self <thread-status> f track,
|
||||
g continuation>> <traceback-gadget> 1 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
toolbar,
|
||||
g status>> self <thread-status> f track,
|
||||
g traceback>> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
: walker-help ( -- ) "ui-walker" help-window ;
|
||||
|
||||
|
|
|
@ -235,7 +235,7 @@ $nl
|
|||
$nl
|
||||
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
|
||||
{ $subsection make-gadget }
|
||||
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link make-gadget } " variable."
|
||||
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link gadget } " variable."
|
||||
$nl
|
||||
"A combinator which stores a gadget in the " { $link gadget } " variable:"
|
||||
{ $subsection with-gadget }
|
||||
|
|
Loading…
Reference in New Issue