steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Cleaning up some code

db4
Slava Pestov 2008-07-11 14:43:51 -05:00
parent b9e3d55959
commit e703dd2b8d
20 changed files with 83 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/ui/gadgets/frames/frames.factor
View File

@ -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 ;

4
extra/ui/gadgets/gadgets-docs.factor
View File

@ -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 } }

12
extra/ui/gadgets/gadgets.factor
View File

@ -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 -- )

16
extra/ui/gadgets/labelled/labelled.factor
View File

@ -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 ;

6
extra/ui/gadgets/packs/packs.factor
View File

@ -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

10
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -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 ;

12
extra/ui/gadgets/sliders/sliders.factor
View File

@ -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

10
extra/ui/gadgets/slots/slots.factor
View File

@ -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 ;

4
extra/ui/gadgets/tracks/tracks.factor
View File

@ -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 [

10
extra/ui/tools/browser/browser.factor
View File

@ -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 ;

10
extra/ui/tools/debugger/debugger.factor
View File

@ -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 ;

10
extra/ui/tools/deploy/deploy.factor
View File

@ -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 ;

8
extra/ui/tools/inspector/inspector.factor
View File

@ -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 ;

12
extra/ui/tools/listener/listener.factor
View File

@ -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
extra/ui/tools/profiler/profiler.factor
View File

@ -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 ;

10
extra/ui/tools/search/search.factor
View File

@ -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 ;

16
extra/ui/tools/tools.factor
View File

@ -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? [

14
extra/ui/tools/traceback/traceback.factor
View File

@ -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* ]

11
extra/ui/tools/walker/walker.factor
View File

@ -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 ;

2
extra/ui/ui-docs.factor
View File

@ -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 }