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 ; grid-layout ;
: make-frame ( quot -- frame ) : make-frame ( quot -- frame )
<frame> make-gadget ; inline <frame> swap make-gadget ; inline
: frame, ( gadget i j -- ) : 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 } "." } ; { $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 HELP: make-gadget
{ $values { "quot" quotation } { "gadget" gadget } } { $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ; { $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
HELP: with-gadget HELP: with-gadget
{ $values { "gadget" gadget } { "quot" quotation } } { $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 ) : focus-path ( world -- seq )
[ gadget-focus ] follow ; [ gadget-focus ] follow ;
: make-gadget ( quot gadget -- gadget ) : gadget, ( gadget -- ) gadget get add-gadget ;
[ \ make-gadget rot with-variable ] keep ; inline
: gadget, ( gadget -- ) \ make-gadget get add-gadget ;
: g ( -- gadget ) gadget get ; : g ( -- gadget ) gadget get ;
: g-> ( x -- x x gadget ) dup g ; : g-> ( x -- x x gadget ) dup g ;
: with-gadget ( gadget quot -- ) : with-gadget ( gadget quot -- )
[ gadget swap with-variable ; inline
swap dup \ make-gadget set gadget set call
] with-scope ; inline : make-gadget ( gadget quot -- gadget )
[ with-gadget ] [ drop ] 2bi ; inline
! Deprecated ! Deprecated
: set-gadget-delegate ( gadget tuple -- ) : set-gadget-delegate ( gadget tuple -- )

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

@ -12,12 +12,10 @@ TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track { 0 1 } labelled-gadget new-track
[
[ [
<label> reverse-video-theme f track, <label> reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track, g-> set-labelled-gadget-content 1 track,
] with-gadget ] make-gadget ;
] keep ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* labelled-gadget-content ;
@ -53,11 +51,9 @@ TUPLE: closable-gadget < frame content ;
: <closable-gadget> ( gadget title quot -- gadget ) : <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new-frame closable-gadget new-frame
[
[ [
<title-bar> @top frame, <title-bar> @top frame,
g-> set-closable-gadget-content @center frame, g-> set-closable-gadget-content @center frame,
] with-gadget ] make-gadget ;
] keep ;
M: closable-gadget focusable-child* closable-gadget-content ; 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> ; [ fast-children-on ] keep <slice> ;
: make-pile ( quot -- pack ) : make-pile ( quot -- pack )
<pile> make-gadget ; inline <pile> swap make-gadget ; inline
: make-filled-pile ( quot -- pack ) : make-filled-pile ( quot -- pack )
<filled-pile> make-gadget ; inline <filled-pile> swap make-gadget ; inline
: make-shelf ( quot -- pack ) : make-shelf ( quot -- pack )
<shelf> make-gadget ; inline <shelf> swap make-gadget ; inline

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

@ -45,13 +45,11 @@ scroller H{
t >>root? t >>root?
<scroller-model> >>model <scroller-model> >>model
faint-boundary faint-boundary
[
[ [
x-model <x-slider> g-> set-scroller-x @bottom frame, x-model <x-slider> g-> set-scroller-x @bottom frame,
y-model <y-slider> g-> set-scroller-y @right frame, y-model <y-slider> g-> set-scroller-y @right frame,
viewport, viewport,
] with-gadget ] make-gadget ;
] keep ;
: <scroller> ( gadget -- scroller ) : <scroller> ( gadget -- scroller )
scroller new-scroller ; scroller new-scroller ;

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

@ -149,12 +149,12 @@ M: elevator layout*
: <right-button> ( -- button ) : <right-button> ( -- button )
{ 0 1 } arrow-right 1 <slide-button> ; { 0 1 } arrow-right 1 <slide-button> ;
: build-x-slider ( slider -- ) : build-x-slider ( slider -- slider )
[ [
<left-button> @left frame, <left-button> @left frame,
{ 0 1 } elevator, { 0 1 } elevator,
<right-button> @right frame, <right-button> @right frame,
] with-gadget ; ] make-gadget ; inline
: <up-button> ( -- button ) : <up-button> ( -- button )
{ 1 0 } arrow-up -1 <slide-button> ; { 1 0 } arrow-up -1 <slide-button> ;
@ -162,12 +162,12 @@ M: elevator layout*
: <down-button> ( -- button ) : <down-button> ( -- button )
{ 1 0 } arrow-down 1 <slide-button> ; { 1 0 } arrow-down 1 <slide-button> ;
: build-y-slider ( slider -- ) : build-y-slider ( slider -- slider )
[ [
<up-button> @top frame, <up-button> @top frame,
{ 1 0 } elevator, { 1 0 } elevator,
<down-button> @bottom frame, <down-button> @bottom frame,
] with-gadget ; ] make-gadget ; inline
: <slider> ( range orientation -- slider ) : <slider> ( range orientation -- slider )
slider new-frame slider new-frame
@ -176,10 +176,10 @@ M: elevator layout*
32 >>line ; 32 >>line ;
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
{ 1 0 } <slider> dup build-x-slider ; { 1 0 } <slider> build-x-slider ;
: <y-slider> ( range -- slider ) : <y-slider> ( range -- slider )
{ 0 1 } <slider> dup build-y-slider ; { 0 1 } <slider> build-y-slider ;
M: slider pref-dim* M: slider pref-dim*
dup call-next-method dup call-next-method

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

@ -71,13 +71,11 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
[
[ [
toolbar, toolbar,
<source-editor> g-> set-slot-editor-text <source-editor> g-> set-slot-editor-text
<scroller> 1 track, <scroller> 1 track,
] with-gadget ] make-gadget
] keep
dup revert ; dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; 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 ; over track-sizes push add-gadget ;
: track, ( gadget constraint -- ) : track, ( gadget constraint -- )
\ make-gadget get swap track-add ; gadget get swap track-add ;
: make-track ( quot orientation -- track ) : make-track ( quot orientation -- track )
<track> make-gadget ; inline <track> swap make-gadget ; inline
: track-remove ( gadget track -- ) : track-remove ( gadget track -- )
over [ over [

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

@ -22,13 +22,11 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
[
[ [
toolbar, toolbar,
g <help-pane> g-> set-browser-gadget-pane g <help-pane> g-> set-browser-gadget-pane
<scroller> 1 track, <scroller> 1 track,
] with-gadget ] make-gadget ;
] keep ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;

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

@ -22,13 +22,11 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track { 0 1 } debugger new-track
[
[ [
toolbar, toolbar,
<restart-list> g-> set-debugger-restarts <restart-list> g-> set-debugger-restarts
swap <debugger-display> <scroller> 1 track, swap <debugger-display> <scroller> 1 track,
] with-gadget ] make-gadget ;
] keep ;
M: debugger focusable-child* debugger-restarts ; M: debugger focusable-child* debugger-restarts ;

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

@ -108,13 +108,11 @@ deploy-gadget "toolbar" f {
deploy-gadget new-gadget deploy-gadget new-gadget
swap >>vocab swap >>vocab
{ 0 1 } >>orientation { 0 1 } >>orientation
[
[ [
g vocab>> <deploy-settings> g vocab>> <deploy-settings>
g-> set-deploy-gadget-settings gadget, g-> set-deploy-gadget-settings gadget,
buttons, buttons,
] with-gadget ] make-gadget
] keep
dup deploy-settings-theme dup deploy-settings-theme
dup com-revert ; dup com-revert ;

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

@ -15,12 +15,10 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
[
[ [
toolbar, toolbar,
<pane> g-> set-inspector-gadget-pane <scroller> 1 track, <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
] with-gadget ] make-gadget ;
] keep ;
: inspect-object ( obj inspector -- ) : inspect-object ( obj inspector -- )
[ set-inspector-gadget-object ] keep refresh ; [ set-inspector-gadget-object ] keep refresh ;

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

@ -123,13 +123,11 @@ TUPLE: stack-display < track ;
: <stack-display> ( -- gadget ) : <stack-display> ( -- gadget )
g workspace-listener g workspace-listener
{ 0 1 } stack-display new-track { 0 1 } stack-display new-track
[
[ [
dup <toolbar> f track, dup <toolbar> f track,
stack>> [ [ stack. ] curry try ] stack>> [ [ stack. ] curry try ]
t "Data stack" <labelled-pane> 1 track, t "Data stack" <labelled-pane> 1 track,
] with-gadget ] make-gadget ;
] keep ;
M: stack-display tool-scroller M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ; find-workspace workspace-listener tool-scroller ;
@ -174,7 +172,7 @@ M: stack-display tool-scroller
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track { 0 1 } listener-gadget new-track
dup init-listener dup init-listener
[ [ listener-output, listener-input, ] with-gadget ] keep ; [ listener-output, listener-input, ] make-gadget ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;

4
extra/ui/tools/profiler/profiler.factor
View File

@ -9,13 +9,11 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
[
[ [
toolbar, toolbar,
<pane> g-> set-profiler-gadget-pane <pane> g-> set-profiler-gadget-pane
<scroller> 1 track, <scroller> 1 track,
] with-gadget ] make-gadget ;
] keep ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ; >r profiler-gadget-pane r> with-pane ;

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

@ -61,13 +61,11 @@ search-field H{
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
[
[ [
<search-field> g-> set-live-search-field f track, <search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list <search-list> g-> set-live-search-list
<scroller> 1 track, <scroller> 1 track,
] with-gadget ] make-gadget
] keep
[ live-search-field set-editor-string ] keep [ live-search-field set-editor-string ] keep
[ live-search-field end-of-document ] keep ; [ live-search-field end-of-document ] keep ;

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

@ -29,7 +29,6 @@ IN: ui.tools
: <workspace> ( -- workspace ) : <workspace> ( -- workspace )
{ 0 1 } workspace new-track { 0 1 } workspace new-track
0 <model> >>model 0 <model> >>model
[
[ [
<listener-gadget> g set-workspace-listener <listener-gadget> g set-workspace-listener
<workspace-book> g set-workspace-book <workspace-book> g set-workspace-book
@ -37,8 +36,7 @@ IN: ui.tools
g workspace-book 1/5 track, g workspace-book 1/5 track,
g workspace-listener 4/5 track, g workspace-listener 4/5 track,
toolbar, toolbar,
] with-gadget ] make-gadget ;
] keep ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [ dup track-sizes over control-value zero? [

12
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 { 0 1 } traceback-gadget new-track
swap >>model swap >>model
[ [
g model>>
[ [
[ [
g gadget-model <datastack-display> 1/2 track, [ <datastack-display> 1/2 track, ]
g gadget-model <retainstack-display> 1/2 track, [ <retainstack-display> 1/2 track, ]
bi
] { 1 0 } make-track 1/3 track, ] { 1 0 } make-track 1/3 track,
g gadget-model <callstack-display> 2/3 track, ]
[ <callstack-display> 2/3 track, ] bi
toolbar, toolbar,
] with-gadget ] make-gadget ;
] keep ;
: <namestack-display> ( model -- gadget ) : <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ] [ [ continuation-name namestack. ] when* ]

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

@ -60,13 +60,12 @@ M: walker-gadget focusable-child*
swap >>thread swap >>thread
swap >>continuation swap >>continuation
swap >>status swap >>status
[ dup continuation>> <traceback-gadget> >>traceback
[ [
toolbar, toolbar,
g status>> self <thread-status> f track, g status>> self <thread-status> f track,
g continuation>> <traceback-gadget> 1 track, g traceback>> 1 track,
] with-gadget ] make-gadget ;
] keep ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;

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

@ -235,7 +235,7 @@ $nl
$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:" "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 } { $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 $nl
"A combinator which stores a gadget in the " { $link gadget } " variable:" "A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection with-gadget } { $subsection with-gadget }