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

Refactoring usages of >r/r> to dip in UI

db4
Slava Pestov 2008-11-28 00:02:02 -06:00
parent 268f3e4838
commit cdf3b48986
32 changed files with 145 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/ui/clipboards/clipboards.factor
View File

@ -33,7 +33,7 @@ SYMBOL: selection
: gadget-copy ( gadget clipboard -- )
over gadget-selection?
[ >r [ gadget-selection ] keep r> copy-clipboard ]
[ [ [ gadget-selection ] keep ] dip copy-clipboard ]
[ 2drop ]
if ;

4
basis/ui/cocoa/cocoa.factor
View File

@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.cocoa.views core-foundation threads math.geometry.rect ;
ui.cocoa.views core-foundation threads math.geometry.rect fry ;
IN: ui.cocoa
TUPLE: handle view window ;
@ -15,7 +15,7 @@ C: <handle> handle
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
[ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;

2
basis/ui/cocoa/tools/tools.factor
View File

@ -25,7 +25,7 @@ CLASS: {
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
[ >r 3drop r> finder-run-files ]
[ [ 3drop ] dip finder-run-files ]
}
{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }

19
basis/ui/cocoa/views/views.factor
View File

@ -8,7 +8,7 @@ core-foundation threads combinators math.geometry.rect ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
over >r mouse-location r> window move-hand fire-motion ;
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
@ -85,18 +85,19 @@ IN: ui.cocoa.views
mouse-location rot window send-button-up ;
: send-wheel$ ( view event -- )
over >r
[
dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
mouse-location
r> window send-wheel ;
] [ drop window ] 2bi send-wheel ;
: send-action$ ( view event gesture -- junk )
>r drop window r> send-action f ;
[ drop window ] dip send-action f ;
: add-resize-observer ( observer object -- )
>r "updateFactorGadgetSize:"
[
"updateFactorGadgetSize:"
"NSViewFrameDidChangeNotification" <NSString>
r> add-observer ;
] dip add-observer ;
: string-or-nil? ( NSString -- ? )
[ CF>string NSStringPboardType = ] [ t ] if* ;
@ -109,7 +110,7 @@ IN: ui.cocoa.views
] if ;
: NSRect>rect ( NSRect world -- rect )
>r dup NSRect-x over NSRect-y r>
[ dup NSRect-x over NSRect-y ] dip
rect-dim second swap - 2array
over NSRect-w rot NSRect-h 2array
<rect> ;
@ -256,7 +257,7 @@ CLASS: {
{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
[
! We return either self or nil
>r >r over window-focus r> r>
[ over window-focus ] 2dip
valid-service? [ drop ] [ 2drop f ] if
]
}
@ -278,7 +279,7 @@ CLASS: {
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
>r drop window-focus r> swap user-input 1
[ drop window-focus ] dip swap user-input 1
] [
3drop 0
] if

4
basis/ui/commands/commands.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make assocs quotations
splitting ui.gestures unicode.case unicode.categories tr ;
splitting ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands
SYMBOL: +nullary+
@ -37,7 +37,7 @@ GENERIC: command-word ( command -- word )
[
commands>>
[ drop ] assoc-filter
[ [ invoke-command ] curry swap set ] assoc-each
[ '[ _ invoke-command ] swap set ] assoc-each
] each
] H{ } make-assoc ;

6
basis/ui/freetype/freetype.factor
View File

@ -111,7 +111,7 @@ M: freetype-renderer open-font ( font -- open-font )
freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
>r handle>> dup r> 0 FT_Load_Char
[ handle>> dup ] dip 0 FT_Load_Char
freetype-error face-glyph ;
: char-width ( open-font char -- w )
@ -174,7 +174,7 @@ M: freetype-renderer string-height ( open-font string -- h )
bi 2array ;
: <char-sprite> ( open-font char -- sprite )
over >r render-glyph dup r> glyph-texture-loc
over [ render-glyph dup ] dip glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ;
@ -206,7 +206,7 @@ M: freetype-renderer string-height ( open-font string -- h )
fonts>> [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
>r >r world get font-sprites r> r> (draw-string) ;
[ world get font-sprites ] 2dip (draw-string) ;
: run-char-widths ( open-font string -- widths )
char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;

5
basis/ui/gadgets/books/books.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
USING: accessors kernel sequences models ui.gadgets
math.geometry.rect fry ;
IN: ui.gadgets.books
TUPLE: book < gadget ;
@ -25,6 +26,6 @@ M: book model-changed ( model book -- )
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- )
[ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
[ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ;
M: book focusable-child* ( book -- child/t ) current-page ;

20
basis/ui/gadgets/gadgets.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
concurrency.flags math.order math.geometry.rect ;
concurrency.flags math.order math.geometry.rect fry ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
@ -56,9 +56,7 @@ M: gadget model-changed 2drop ;
2dup eq? [
2drop { 0 0 }
] [
over rect-loc >r
>r parent>> r> relative-loc
r> v+
over rect-loc [ [ parent>> ] dip relative-loc ] dip v+
] if ;
GENERIC: user-input* ( str gadget -- ? )
@ -73,7 +71,7 @@ M: gadget children-on nip children>> ;
[ swap loc>> v- ] dip v. 0 <=> ;
: (fast-children-on) ( dim axis children -- i )
-rot [ ((fast-children-on)) ] 2curry search drop ;
-rot '[ _ _ ((fast-children-on)) ] search drop ;
: fast-children-on ( rect axis children -- from to )
[ [ rect-loc ] 2dip (fast-children-on) 0 or ]
@ -95,10 +93,10 @@ M: gadget children-on nip children>> ;
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
: orient ( gadget seq1 seq2 -- seq )
>r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
rot orientation>> '[ [ _ ] 2dip set-axis ] 2map ;
: each-child ( gadget quot -- )
>r children>> r> each ; inline
[ children>> ] dip each ; inline
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )
@ -310,18 +308,18 @@ SYMBOL: in-layout?
[ parent>> ] follow ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
[ parents ] dip all? ; inline
: find-parent ( gadget quot -- parent )
>r parents r> find nip ; inline
[ parents ] dip find nip ; inline
: screen-loc ( gadget -- loc )
parents { 0 0 } [ rect-loc v+ ] reduce ;
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
>r rect-extent r> (screen-rect)
>r tuck v+ r> vmin >r v+ r>
[ rect-extent ] dip (screen-rect)
[ tuck v+ ] dip vmin [ v+ ] dip
] [
rect-extent
] if* ;

11
basis/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math namespaces opengl opengl.gl sequences
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
USING: kernel accessors math namespaces opengl opengl.gl
sequences math.vectors ui.gadgets ui.gadgets.grids ui.render
math.geometry.rect fry ;
IN: ui.gadgets.grid-lines
TUPLE: grid-lines color ;
@ -19,8 +20,8 @@ SYMBOL: grid-dim
: draw-grid-lines ( gaps orientation -- )
[ grid get swap grid-positions grid get rect-dim suffix ] dip
[ [ v- ] curry map ] keep
[ swap grid-line-from/to gl-line ] curry each ;
[ '[ _ v- ] map ] keep
'[ _ swap grid-line-from/to gl-line ] each ;
M: grid-lines draw-boundary
color>> gl-color [

17
basis/ui/gadgets/grids/grids.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect locals ;
math.geometry.rect locals fry ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
@ -48,21 +48,18 @@ grid
dupd add-gaps dim-sum v+ ;
M: grid pref-dim*
dup gap>> swap compute-grid >r over r>
gap-sum >r gap-sum r> (pair-up) ;
dup gap>> swap compute-grid [ over ] dip
[ gap-sum ] 2bi@ (pair-up) ;
: do-grid ( dims grid quot -- )
-rot grid>>
[ [ pick call ] 2each ] 2each
drop ; inline
[ grid>> ] dip '[ _ 2each ] 2each ; inline
: grid-positions ( grid dims -- locs )
>r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
[ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
: position-grid ( grid horiz vert -- )
pick >r
>r over r> grid-positions >r grid-positions r>
pair-up r> [ (>>loc) ] do-grid ;
pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
[ (>>loc) ] do-grid ;
: resize-grid ( grid horiz vert -- )
pick fill?>> [

6
basis/ui/gadgets/labelled/labelled.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets.buttons ui.gadgets.borders
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
@ -19,10 +19,10 @@ TUPLE: labelled-gadget < track content ;
M: labelled-gadget focusable-child* content>> ;
: <labelled-scroller> ( gadget title -- gadget )
>r <scroller> r> <labelled-gadget> ;
[ <scroller> ] dip <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget )
>r >r <pane-control> r> >>scrolls? r>
[ [ <pane-control> ] dip >>scrolls? ] dip
<labelled-scroller> ;
: <close-box> ( quot -- button/f )

2
basis/ui/gadgets/labels/labels.factor
View File

@ -13,7 +13,7 @@ TUPLE: label < gadget text font color ;
: set-label-string ( string label -- )
CHAR: \n pick memq? [
>r string-lines r> (>>text)
[ string-lines ] dip (>>text)
] [
(>>text)
] if ; inline

8
basis/ui/gadgets/lists/lists.factor
View File

@ -33,7 +33,7 @@ TUPLE: list < pack index presenter color hook ;
hook>> [ [ list? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep >r >label text-theme r>
keep [ >label text-theme ] dip
<presentation>
swap >>hook ; inline
@ -42,7 +42,7 @@ TUPLE: list < pack index presenter color hook ;
[ presenter>> ]
[ control-value ]
tri [
>r 2dup r> swap <list-presentation>
[ 2dup ] dip swap <list-presentation>
] map 2nip ;
M: list model-changed
@ -113,8 +113,8 @@ M: list focusable-child* drop t ;
select-gadget ;
: list-page ( list vec -- )
>r dup selected-rect rect-bounds 2 v/n v+
over visible-dim r> v* v+ swap select-at ;
[ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
v* v+ swap select-at ;
: list-page-up ( list -- ) { 0 -1 } list-page ;

4
basis/ui/gadgets/menus/menus.factor
View File

@ -8,13 +8,13 @@ math.geometry.rect ;
IN: ui.gadgets.menus
: menu-loc ( world menu -- loc )
>r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
[ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
>r over menu-loc >>loc r>
[ over menu-loc >>loc ] dip
swap add-gadget ;
M: menu-glass layout* gadget-child prefer ;

11
basis/ui/gadgets/packs/packs.factor
View File

@ -19,10 +19,10 @@ TUPLE: pack < gadget
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
: aligned-locs ( gadget sizes -- seq )
[ >r dup align>> swap rect-dim r> v- n*v ] with map ;
[ [ dup align>> swap rect-dim ] dip v- n*v ] with map ;
: packed-locs ( gadget sizes -- seq )
over gap>> over gap-locs >r dupd aligned-locs r> orient ;
over gap>> over gap-locs [ dupd aligned-locs ] dip orient ;
: round-dims ( seq -- newseq )
{ 0 0 } swap
@ -31,8 +31,9 @@ TUPLE: pack < gadget
: pack-layout ( pack sizes -- )
round-dims over children>>
>r dupd packed-dims r> 2dup [ (>>dim) ] 2each
>r packed-locs r> [ (>>loc) ] 2each ;
[ dupd packed-dims ] dip
[ [ (>>dim) ] 2each ]
[ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
: <pack> ( orientation -- pack )
pack new-gadget
@ -48,7 +49,7 @@ TUPLE: pack < gadget
[ dim-sum ] keep length 1 [-] rot n*v v+ ;
: pack-pref-dim ( gadget sizes -- dim )
over gap>> over gap-dims >r max-dim r>
over gap>> over gap-dims [ max-dim ] dip
rot orientation>> set-axis ;
M: pack pref-dim*

20
basis/ui/gadgets/panes/panes.factor
View File

@ -9,7 +9,7 @@ opengl combinators math.vectors sorting splitting
io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect ;
math.geometry.rect fry ;
IN: ui.gadgets.panes
TUPLE: pane < pack
@ -59,7 +59,7 @@ M: pane gadget-selection ( pane -- string/f )
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
>r clip get over intersects? r> [ drop ] if ; inline
[ clip get over intersects? ] dip [ drop ] if ; inline
M: gadget draw-selection ( loc gadget -- )
swap offset-rect [
@ -135,8 +135,8 @@ M: style-stream write-gadget
: with-pane ( pane quot -- )
over scroll>top
over pane-clear >r <pane-stream> r>
over >r with-output-stream* r> ?nl ; inline
over pane-clear [ <pane-stream> ] dip
over [ with-output-stream* ] dip ?nl ; inline
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
@ -154,7 +154,7 @@ M: pane-control model-changed ( model pane-control -- )
swap >>model ;
: do-pane-stream ( pane-stream quot -- )
>r pane>> r> keep scroll-pane ; inline
[ pane>> ] dip keep scroll-pane ; inline
M: pane-stream stream-nl
[ pane-nl drop ] do-pane-stream ;
@ -178,7 +178,7 @@ M: pane-stream make-span-stream
! Character styles
: apply-style ( style gadget key quot -- style gadget )
>r pick at r> when* ; inline
[ pick at ] dip when* ; inline
: apply-foreground-style ( style gadget -- style gadget )
foreground [ >>color ] apply-style ;
@ -228,7 +228,7 @@ M: pane-stream make-span-stream
border-width [ <border> ] apply-style ;
: apply-printer-style ( style gadget -- style gadget )
presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
@ -284,10 +284,10 @@ M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table
>r
[
swap [ [ pane>> smash-pane ] map ] map
styled-grid
r> print-gadget ;
] dip print-gadget ;
! Stream utilities
M: pack dispose drop ;
@ -309,7 +309,7 @@ M: paragraph stream-write
drop ;
: gadget-write1 ( char gadget -- )
>r 1string r> stream-write ;
[ 1string ] dip stream-write ;
M: pack stream-write1 gadget-write1 ;

2
basis/ui/gadgets/presentations/presentations.factor
View File

@ -12,7 +12,7 @@ TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
over dup hook>> call
>r object>> r> invoke-command ;
[ object>> ] dip invoke-command ;
: invoke-primary ( presentation -- )
dup object>> primary-operation

15
basis/ui/gadgets/sliders/sliders.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models models.range math.vectors math.functions
quotations colors math.geometry.rect ;
quotations colors math.geometry.rect fry ;
IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ;
@ -104,13 +104,14 @@ elevator H{
: layout-thumb-loc ( slider -- )
dup thumb-loc (layout-thumb)
>r [ floor ] map r> (>>loc) ;
[ [ floor ] map ] dip (>>loc) ;
: layout-thumb-dim ( slider -- )
dup dup thumb-dim (layout-thumb) >r
>r dup rect-dim r>
dup dup thumb-dim (layout-thumb)
[
[ dup rect-dim ] dip
rot orientation>> set-axis [ ceiling ] map
r> (>>dim) ;
] dip (>>dim) ;
: layout-thumb ( slider -- )
dup layout-thumb-loc layout-thumb-dim ;
@ -121,8 +122,8 @@ M: elevator layout*
: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button>
[ gray swap <polygon-gadget> ] dip
'[ _ swap find-slider slide-by-line ] <repeat-button>
swap >>orientation ;
: elevator, ( gadget orientation -- gadget )

2
basis/ui/gadgets/status-bar/status-bar.factor
View File

@ -16,4 +16,4 @@ IN: ui.gadgets.status-bar
open-world-window ;
: show-summary ( object gadget -- )
>r [ summary ] [ "" ] if* r> show-status ;
[ [ summary ] [ "" ] if* ] dip show-status ;

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -52,7 +52,7 @@ M: world request-focus-on ( child gadget -- )
M: world layout*
dup call-next-method
dup glass>> [
>r dup rect-dim r> (>>dim)
[ dup rect-dim ] dip (>>dim)
] when* drop ;
M: world focusable-child* gadget-child ;

2
basis/ui/operations/operations.factor
View File

@ -38,7 +38,7 @@ SYMBOL: operations
operations get [ predicate>> call ] with filter ;
: find-operation ( obj quot -- command )
>r object-operations r> find-last nip ; inline
[ object-operations ] dip find-last nip ; inline
: primary-operation ( obj -- operation )
[ command>> +primary+ word-prop ] find-operation ;

10
basis/ui/render/render.factor
View File

@ -12,7 +12,7 @@ SYMBOL: viewport-translation
: flip-rect ( rect -- loc dim )
rect-bounds [
>r { 1 -1 } v* r> { 0 -1 } v* v+
[ { 1 -1 } v* ] dip { 0 -1 } v* v+
viewport-translation get v+
] keep ;
@ -79,9 +79,7 @@ DEFER: draw-gadget
>absolute clip [ rect-intersect ] change ;
: with-clipping ( gadget quot -- )
clip get >r
over change-clip do-clip call
r> clip set do-clip ; inline
clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
: draw-gadget ( gadget -- )
{
@ -200,7 +198,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget )
dup max-dim
>r <polygon> <gadget> r> >>dim
[ <polygon> <gadget> ] dip >>dim
swap >>interior ;
! Font rendering
@ -242,7 +240,7 @@ HOOK: free-fonts font-renderer ( world -- )
[
[
2dup { 0 0 } draw-string
>r open-font r> string-height
[ open-font ] dip string-height
0.0 swap 0.0 glTranslated
] with each
] with-translation

15
basis/ui/tools/deploy/deploy.factor
View File

@ -1,12 +1,11 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces
models models.mapping sequences ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ;
USING: ui.gadgets colors kernel ui.render namespaces models
models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
ui.gadgets.labels tools.deploy.config namespaces
ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
vocabs ui.tools.workspace system accessors fry ;
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
@ -83,7 +82,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
: com-deploy ( gadget -- )
dup com-save
dup find-deploy-vocab [ deploy ] curry call-listener
dup find-deploy-vocab '[ _ deploy ] call-listener
close-window ;
: com-help ( -- )

6
basis/ui/tools/interactor/interactor.factor
View File

@ -7,7 +7,7 @@ quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ;
ui.tools.workspace accessors sets destructors fry ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
@ -88,7 +88,7 @@ M: interactor model-changed
[ editor-string ] keep
[ interactor-input. ] 2keep
[ add-interactor-history ] keep
[ clear-input ] curry "Clearing input" spawn drop ;
'[ _ clear-input ] "Clearing input" spawn drop ;
: interactor-eof ( interactor -- )
dup interactor-busy? [
@ -126,7 +126,7 @@ M: interactor stream-read
swap dup zero? [
2drop ""
] [
>r interactor-read dup [ "\n" join ] when r> short head
[ interactor-read dup [ "\n" join ] when ] dip short head
] if ;
M: interactor stream-read-partial

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

@ -28,7 +28,7 @@ M: listener-gadget focusable-child*
input>> ;
M: listener-gadget call-tool* ( input listener -- )
>r string>> r> input>> set-editor-string ;
[ string>> ] dip input>> set-editor-string ;
M: listener-gadget tool-scroller
output>> find-scroller ;
@ -95,13 +95,13 @@ M: engine-word word-completion-string
: use-if-necessary ( word seq -- )
over vocabulary>> over and [
2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push
[ vocabulary>> vocab-words ] dip push
] if
] [ 2drop ] if ;
: insert-word ( word -- )
get-workspace listener>> input>>
[ >r word-completion-string r> user-input* drop ]
[ [ word-completion-string ] dip user-input* drop ]
[ interactor-use use-if-necessary ]
2bi ;

8
basis/ui/tools/profiler/profiler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace kernel quotations tools.profiler
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ;
@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ;
dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- )
>r pane>> r> with-pane ;
[ pane>> ] dip with-pane ;
: com-full-profile ( gadget -- )
[ profile. ] with-profiler-pane ;
@ -39,10 +39,10 @@ profiler-gadget "toolbar" f {
GENERIC: profiler-presentation ( obj -- quot )
M: usage-profile profiler-presentation
word>> [ usage-profile. ] curry ;
word>> '[ _ usage-profile. ] ;
M: vocab-profile profiler-presentation
vocab>> [ vocab-profile. ] curry ;
vocab>> '[ _ vocab-profile. ] ;
M: f profiler-presentation
drop [ vocabs-profile. ] ;

2
basis/ui/tools/search/search-tests.factor
View File

@ -19,7 +19,7 @@ IN: ui.tools.search.tests
] with-grafted-gadget ;
: test-live-search ( gadget quot -- ? )
>r update-live-search dup assert-non-empty r> all? ;
[ update-live-search dup assert-non-empty ] dip all? ;
[ t ] [
"swp" all-words f <definition-search>

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

@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader
tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
mirrors ;
mirrors fry ;
IN: ui.tools
: <workspace-tabs> ( workspace -- tabs )
@ -93,7 +93,7 @@ workspace "workflow" f {
] workspace-window-hook set-global
: inspect-continuation ( traceback -- )
control-value [ inspect ] curry call-listener ;
control-value '[ _ inspect ] call-listener ;
traceback-gadget "toolbar" f {
{ T{ key-down f f "v" } variables }

6
basis/ui/tools/walker/walker.factor
View File

@ -5,7 +5,7 @@ ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
models models.filter ui.tools.workspace ui.gestures
ui.gadgets.labels ui threads namespaces make tools.walker assocs
combinators ;
combinators fry ;
IN: ui.tools.walker
TUPLE: walker-gadget < track
@ -53,7 +53,7 @@ M: walker-gadget focusable-child*
] "" make ;
: <thread-status> ( model thread -- gadget )
[ walker-state-string ] curry <filter> <label-control> ;
'[ _ walker-state-string ] <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
{ 0 1 } walker-gadget new-track
@ -89,7 +89,7 @@ walker-gadget "toolbar" f {
} cond ;
: find-walker-window ( thread -- world/f )
[ swap walker-for-thread? ] curry find-window ;
'[ _ swap walker-for-thread? ] find-window ;
: walker-window ( status continuation thread -- )
[ <walker-gadget> ] [ name>> ] bi open-status-window ;

4
basis/ui/tools/workspace/workspace.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models
sequences assocs arrays namespaces accessors math.vectors ui
sequences assocs arrays namespaces accessors math.vectors fry ui
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
@ -33,7 +33,7 @@ M: gadget tool-scroller drop f ;
set-model ;
: get-workspace* ( quot -- workspace )
[ >r dup workspace? r> [ drop f ] if ] curry find-window
'[ dup workspace? _ [ drop f ] if ] find-window
[ dup raise-window gadget-child ]
[ workspace-window* ] if* ; inline

24
basis/ui/windows/windows.factor
View File

@ -288,7 +288,7 @@ SYMBOL: nc-buttons
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-absolute>relative ( lparam handle -- array )
>r >lo-hi r>
[ >lo-hi ] dip
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
@ -297,7 +297,7 @@ SYMBOL: nc-buttons
[ <button-down> ] [ <button-up> ] if ;
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
nip >r mouse-event>gesture r> >lo-hi rot window ;
[ drop mouse-event>gesture ] dip >lo-hi rot window ;
: set-capture ( hwnd -- )
mouse-captured get [
@ -312,10 +312,10 @@ SYMBOL: nc-buttons
mouse-captured off ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
>r >r
[
over set-capture
dup message>button drop nc-buttons get delete
r> r> prepare-mouse send-button-down ;
] 2dip prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when
@ -337,9 +337,10 @@ SYMBOL: nc-buttons
TrackMouseEvent drop
>lo-hi swap window move-hand fire-motion ;
: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
>r nip r>
pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
lParam mouse-wheel
hWnd mouse-absolute>relative
hWnd window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging
@ -456,10 +457,11 @@ M: windows-ui-backend do-events
: create-window ( rect -- hwnd )
make-adjusted-RECT
>r class-name-ptr get-global f r>
>r >r >r ex-style r> r>
[ class-name-ptr get-global f ] dip
[
[ ex-style ] 2dip
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
r> get-RECT-dimensions
] dip get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- )
@ -515,7 +517,7 @@ M: windows-ui-backend raise-window* ( world -- )
M: windows-ui-backend set-title ( string world -- )
handle>>
dup title>> [ free ] when*
>r utf16n malloc-string r>
[ utf16n malloc-string ] dip
2dup (>>title)
hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;

25
basis/ui/x11/x11.factor
View File

@ -79,7 +79,7 @@ M: world configure-event
: key-down-event>gesture ( event world -- string gesture )
dupd
handle>> xic>> lookup-string
>r swap event-modifiers r> key-code <key-down> ;
[ swap event-modifiers ] dip key-code <key-down> ;
M: world key-down-event
[ key-down-event>gesture ] keep
@ -92,18 +92,18 @@ M: world key-down-event
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
>r key-up-event>gesture r> world-focus propagate-gesture ;
[ key-up-event>gesture ] dip world-focus propagate-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
dup event-modifiers over XButtonEvent-button
rot mouse-event-loc ;
M: world button-down-event
>r mouse-event>gesture >r <button-down> r> r>
[ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-down ;
M: world button-up-event
>r mouse-event>gesture >r <button-up> r> r>
[ mouse-event>gesture [ <button-up> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
@ -115,7 +115,7 @@ M: world button-up-event
} at ;
M: world wheel-event
>r dup mouse-event>scroll-direction swap mouse-event-loc r>
[ dup mouse-event>scroll-direction swap mouse-event-loc ] dip
send-wheel ;
M: world enter-event motion-event ;
@ -123,7 +123,7 @@ M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
>r dup XMotionEvent-x swap XMotionEvent-y 2array r>
[ dup XMotionEvent-x swap XMotionEvent-y 2array ] dip
move-hand fire-motion ;
M: world focus-in-event
@ -158,7 +158,7 @@ M: world selection-notify-event
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
[ XSelectionRequestEvent-target ] keep
>r 8 PropModeReplace r>
[ 8 PropModeReplace ] dip
[
XSelectionRequestEvent-selection
clipboard-for-atom contents>>
@ -208,8 +208,7 @@ M: x-clipboard copy-clipboard
(>>contents) ;
M: x-clipboard paste-clipboard
>r find-world handle>> window>>
r> atom>> convert-selection ;
[ find-world handle>> window>> ] dip atom>> convert-selection ;
: init-clipboard ( -- )
XA_PRIMARY <x-clipboard> selection set-global
@ -219,9 +218,8 @@ M: x-clipboard paste-clipboard
dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
: set-title-new ( dpy window string -- )
>r
XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
r> utf8 encode dup length XChangeProperty drop ;
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap dpy get -rot
@ -237,8 +235,7 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
32 over set-XClientMessageEvent-format
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
>r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window