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

Remove more delegation usage from UI: build-* words, various misc things

db4
Slava Pestov 2008-07-11 00:01:22 -05:00
parent 40d52ac227
commit 64a2b0c7a5
38 changed files with 312 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/kernel/kernel.factor
View File

@ -210,6 +210,3 @@ GENERIC# set-slots 1 ( ... tuple slots -- )
: construct ( ... slots class -- tuple ) : construct ( ... slots class -- tuple )
new [ swap set-slots ] keep ; inline new [ swap set-slots ] keep ; inline
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline

19
extra/ui/commands/commands-docs.factor
View File

@ -1,22 +1,21 @@
USING: ui.gestures help.markup help.syntax strings kernel USING: accessors ui.gestures help.markup help.syntax strings kernel
hashtables quotations words classes sequences namespaces hashtables quotations words classes sequences namespaces
arrays assocs ; arrays assocs ;
IN: ui.commands IN: ui.commands
: command-map-row ( children -- seq ) : command-map-row ( gesture command -- seq )
[ [
[ first gesture>string , ] [ gesture>string , ]
[ [
second
[ command-name , ] [ command-name , ]
[ command-word \ $link swap 2array , ] [ command-word \ $link swap 2array , ]
[ command-description , ] [ command-description , ]
tri tri
] bi ] bi*
] { } make ; ] { } make ;
: command-map. ( command-map -- ) : command-map. ( alist -- )
[ command-map-row ] map [ command-map-row ] { } assoc>map
{ "Shortcut" "Command" "Word" "Notes" } { "Shortcut" "Command" "Word" "Notes" }
[ \ $strong swap ] { } map>assoc prefix [ \ $strong swap ] { } map>assoc prefix
$table ; $table ;
@ -25,11 +24,13 @@ IN: ui.commands
[ second (command-name) " commands" append $heading ] [ second (command-name) " commands" append $heading ]
[ [
first2 swap command-map first2 swap command-map
[ command-map-blurb print-element ] [ command-map. ] bi [ blurb>> print-element ] [ commands>> command-map. ] bi
] bi ; ] bi ;
: $command ( element -- ) : $command ( element -- )
reverse first3 command-map value-at gesture>string $snippet ; reverse first3 command-map
commands>> value-at gesture>string
$snippet ;
HELP: +nullary+ HELP: +nullary+
{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ; { $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;

11
extra/ui/commands/commands.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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces assocs quotations splitting math assocs words generic namespaces assocs quotations splitting
@ -15,16 +15,14 @@ GENERIC: invoke-command ( target command -- )
GENERIC: command-name ( command -- str ) GENERIC: command-name ( command -- str )
TUPLE: command-map blurb ; TUPLE: command-map blurb commands ;
GENERIC: command-description ( command -- str/f ) GENERIC: command-description ( command -- str/f )
GENERIC: command-word ( command -- word ) GENERIC: command-word ( command -- word )
: <command-map> ( blurb commands -- command-map ) : <command-map> ( blurb commands -- command-map )
{ } like { } like \ command-map boa ;
{ set-command-map-blurb set-delegate }
\ command-map construct ;
: commands ( class -- hash ) : commands ( class -- hash )
dup "commands" word-prop [ ] [ dup "commands" word-prop [ ] [
@ -37,7 +35,8 @@ GENERIC: command-word ( command -- word )
: command-gestures ( class -- hash ) : command-gestures ( class -- hash )
commands values [ commands values [
[ [
[ first ] filter commands>>
[ drop ] assoc-filter
[ [ invoke-command ] curry swap set ] assoc-each [ [ invoke-command ] curry swap set ] assoc-each
] each ] each
] H{ } make-assoc ; ] H{ } make-assoc ;

7
extra/ui/gadgets/books/books-docs.factor
View File

@ -9,3 +9,10 @@ $nl
HELP: <book> HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } } { $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ; { $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
ARTICLE: "ui-book-layout" "Book layouts"
"Books can contain any number of children, and display one child at a time."
{ $subsection book }
{ $subsection <book> } ;
ABOUT: "ui-book-layout"

2
extra/ui/gadgets/buttons/buttons.factor
View File

@ -225,7 +225,7 @@ M: radio-control model-changed
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
[ [
"toolbar" over class command-map swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> gadget, ] curry assoc-each [ -rot <command-button> gadget, ] curry assoc-each
] make-shelf ; ] make-shelf ;

9
extra/ui/gadgets/editors/editors-tests.factor
View File

@ -1,6 +1,7 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain USING: accessors ui.gadgets.editors tools.test kernel io
definitions namespaces ui.gadgets ui.gadgets.grids prettyprint io.streams.plain definitions namespaces ui.gadgets
documents ui.gestures tools.test.ui models ; ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
models ;
[ "foo bar" ] [ [ "foo bar" ] [
<editor> "editor" set <editor> "editor" set
@ -44,5 +45,5 @@ documents ui.gestures tools.test.ui models ;
"hello" <model> <field> "field" set "hello" <model> <field> "field" set
"field" get [ "field" get [
[ "hello" ] [ "field" get field-model model-value ] unit-test [ "hello" ] [ "field" get field-model>> model-value ] unit-test
] with-grafted-gadget ] with-grafted-gadget

29
extra/ui/gadgets/frames/frames-docs.factor
View File

@ -2,6 +2,25 @@ USING: help.syntax help.markup ui.gadgets kernel arrays
quotations classes.tuple ui.gadgets.grids ; quotations classes.tuple ui.gadgets.grids ;
IN: ui.gadgets.frames IN: ui.gadgets.frames
ARTICLE: "ui-frame-layout" "Frame layouts"
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection make-frame }
{ $subsection frame, }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
{ $subsection @top }
{ $subsection @bottom }
{ $subsection @top-left }
{ $subsection @top-right }
{ $subsection @bottom-left }
{ $subsection @bottom-right } ;
: $ui-frame-constant ( element -- ) : $ui-frame-constant ( element -- )
drop drop
{ $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ; { $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
@ -25,18 +44,16 @@ HELP: <frame>
{ $values { "frame" frame } } { $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ; { $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
{ <frame> make-frame build-frame } related-words { <frame> make-frame } related-words
HELP: make-frame HELP: make-frame
{ $values { "quot" quotation } { "frame" frame } } { $values { "quot" quotation } { "frame" frame } }
{ $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ; { $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ;
HELP: build-frame
{ $values { "tuple" tuple } { "quot" quotation } }
{ $description "Creates a new frame and sets " { $snippet "tuple" } "'s delegate to the new frame. The quotation can add children by calling the " { $link frame, } " word, and access the frame by calling " { $link g } " or " { $link g-> } "." } ;
HELP: frame, HELP: frame,
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } } { $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } " or " { $link build-frame } "." } ; { $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } "." } ;
{ grid frame } related-words { grid frame } related-words
ABOUT: "ui-frame-layout"

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

@ -41,8 +41,5 @@ M: frame layout*
: make-frame ( quot -- frame ) : make-frame ( quot -- frame )
<frame> make-gadget ; inline <frame> make-gadget ; inline
: build-frame ( tuple quot -- tuple )
<frame> build-gadget ; inline
: frame, ( gadget i j -- ) : frame, ( gadget i j -- )
\ make-gadget get -rot grid-add ; \ make-gadget get -rot grid-add ;

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

@ -232,27 +232,23 @@ HELP: focusable-child
HELP: gadget, HELP: gadget,
{ $values { "gadget" gadget } } { $values { "gadget" 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 } " or " { $link build-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 { "quot" quotation } { "gadget" gadget } }
{ $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 make-gadget } " variable." } ;
HELP: build-gadget
{ $values { "tuple" tuple } { "quot" quotation } { "gadget" gadget } }
{ $description "Delegates the tuple to the gadget, and calls the quotation in a new scope with the tuple stored in the " { $link make-gadget } " and " { $link gadget } " variables." } ;
HELP: with-gadget HELP: with-gadget
{ $values { "gadget" gadget } { "quot" quotation } } { $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ; { $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ;
HELP: g HELP: g
{ $values { "gadget" gadget } } { $values { "gadget" gadget } }
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ; { $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: g-> HELP: g->
{ $values { "x" object } { "gadget" gadget } } { $values { "x" object } { "gadget" gadget } }
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ; { $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
{ control-value set-control-value gadget-model } related-words { control-value set-control-value gadget-model } related-words

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

@ -71,9 +71,6 @@ M: gadget model-changed 2drop ;
: <gadget> ( -- gadget ) : <gadget> ( -- gadget )
gadget new-gadget ; gadget new-gadget ;
: construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline
: activate-control ( gadget -- ) : activate-control ( gadget -- )
dup gadget-model dup [ dup gadget-model dup [
2dup add-connection 2dup add-connection
@ -140,11 +137,6 @@ M: gadget children-on nip gadget-children ;
: each-child ( gadget quot -- ) : each-child ( gadget quot -- )
>r gadget-children r> each ; inline >r gadget-children r> each ; inline
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
! Selection protocol ! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? ) GENERIC: gadget-selection? ( gadget -- ? )
@ -413,5 +405,11 @@ M: f request-focus-on 2drop ;
swap dup \ make-gadget set gadget set call swap dup \ make-gadget set gadget set call
] with-scope ; inline ] with-scope ; inline
: build-gadget ( tuple quot gadget -- tuple ) ! Deprecated
pick set-gadget-delegate over >r with-gadget r> ; inline : set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

12
extra/ui/gadgets/grids/grids-docs.factor
View File

@ -1,6 +1,16 @@
USING: ui.gadgets help.markup help.syntax arrays ; USING: ui.gadgets help.markup help.syntax arrays ;
IN: ui.gadgets.grids IN: ui.gadgets.grids
ARTICLE: "ui-grid-layout" "Grid layouts"
"Grid gadgets layout their children in a rectangular grid."
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
HELP: grid HELP: grid
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height." { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
$nl $nl
@ -30,3 +40,5 @@ HELP: grid-remove
{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } } { $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Removes a child gadget from the specified location." } { $description "Removes a child gadget from the specified location." }
{ $side-effects "grid" } ; { $side-effects "grid" } ;
ABOUT: "ui-grid-layout"

17
extra/ui/gadgets/incremental/incremental-docs.factor
View File

@ -25,3 +25,20 @@ HELP: clear-incremental
{ $values { "incremental" incremental } } { $values { "incremental" incremental } }
{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." } { $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
{ $side-effects "incremental" } ; { $side-effects "incremental" } ;
ARTICLE: "ui-incremental-layout" "Incremental layouts"
"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
$nl
"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
$nl
"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
$nl
"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
{ $subsection incremental }
{ $subsection <incremental> }
"Children are added and removed with a special set of words which perform necessary relayout immediately:"
{ $subsection add-incremental }
{ $subsection clear-incremental }
"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
ABOUT: "ui-incremental-layout"

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

@ -8,14 +8,16 @@ sequences sequences words classes.tuple ui.gadgets ui.render
colors ; colors ;
IN: ui.gadgets.labelled IN: ui.gadgets.labelled
TUPLE: labelled-gadget content ; TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
labelled-gadget new { 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,
] { 0 1 } build-track ; ] with-gadget
] keep ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* labelled-gadget-content ;
@ -44,16 +46,18 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
<title-label> @center frame, <title-label> @center frame,
] make-frame ; ] make-frame ;
TUPLE: closable-gadget content ; TUPLE: closable-gadget < frame content ;
: find-closable-gadget ( parent -- child ) : find-closable-gadget ( parent -- child )
[ [ closable-gadget? ] is? ] find-parent ; [ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget ) : <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new 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,
] build-frame ; ] with-gadget
] keep ;
M: closable-gadget focusable-child* closable-gadget-content ; M: closable-gadget focusable-child* closable-gadget-content ;

18
extra/ui/gadgets/packs/packs-docs.factor
View File

@ -2,6 +2,22 @@ USING: ui.gadgets help.markup help.syntax generic kernel
classes.tuple quotations ; classes.tuple quotations ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
ARTICLE: "ui-pack-layout" "Pack layouts"
"Pack gadgets layout their children along a single axis."
{ $subsection pack }
"Creating empty packs:"
{ $subsection <pack> }
{ $subsection <pile> }
{ $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
HELP: pack HELP: pack
{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:" { $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:"
{ $list { $list
@ -59,3 +75,5 @@ HELP: make-filled-pile
HELP: make-shelf HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } } { $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ; { $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ;
ABOUT: "ui-pack-layout"

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

@ -69,7 +69,3 @@ M: pack children-on ( rect gadget -- seq )
: make-shelf ( quot -- pack ) : make-shelf ( quot -- pack )
<shelf> make-gadget ; inline <shelf> make-gadget ; inline
: build-pack ( quot quot orientation -- pack )
<pack> build-gadget ; inline

39
extra/ui/gadgets/panes/panes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers
@ -200,13 +200,15 @@ M: pane-stream make-span-stream
: apply-presentation-style ( style gadget -- style gadget ) : apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ; presented [ <presentation> ] apply-style ;
: <styled-label> ( style text -- gadget ) : style-label ( style gadget -- gadget )
<label>
apply-foreground-style apply-foreground-style
apply-background-style apply-background-style
apply-font-style apply-font-style
apply-presentation-style apply-presentation-style
nip ; nip ; inline
: <styled-label> ( style text -- gadget )
<label> style-label ;
! Paragraph styles ! Paragraph styles
@ -240,28 +242,27 @@ M: pane-stream make-span-stream
apply-printer-style apply-printer-style
nip ; nip ;
TUPLE: nested-pane-stream style parent ; TUPLE: nested-pane-stream < pane-stream style parent ;
: <nested-pane-stream> ( style parent -- stream ) : new-nested-pane-stream ( style parent class -- stream )
>r <pane> apply-wrap-style <pane-stream> r> { new
set-nested-pane-stream-style swap >>parent
set-delegate swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
set-nested-pane-stream-parent inline
} nested-pane-stream construct ;
: unnest-pane-stream ( stream -- child parent ) : unnest-pane-stream ( stream -- child parent )
dup ?nl dup ?nl
dup nested-pane-stream-style dup style>>
over pane-stream-pane smash-pane style-pane over pane>> smash-pane style-pane
swap nested-pane-stream-parent ; swap parent>> ;
TUPLE: pane-block-stream ; TUPLE: pane-block-stream < nested-pane-stream ;
M: pane-block-stream dispose M: pane-block-stream dispose
unnest-pane-stream write-gadget ; unnest-pane-stream write-gadget ;
M: pane-stream make-block-stream M: pane-stream make-block-stream
<nested-pane-stream> pane-block-stream construct-delegate ; pane-block-stream new-nested-pane-stream ;
! Tables ! Tables
: apply-table-gap-style ( style grid -- style grid ) : apply-table-gap-style ( style grid -- style grid )
@ -278,12 +279,12 @@ M: pane-stream make-block-stream
apply-table-border-style apply-table-border-style
nip ; nip ;
TUPLE: pane-cell-stream ; TUPLE: pane-cell-stream < nested-pane-stream ;
M: pane-cell-stream dispose ?nl ; M: pane-cell-stream dispose ?nl ;
M: pane-stream make-cell-stream M: pane-stream make-cell-stream
<nested-pane-stream> pane-cell-stream construct-delegate ; pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table M: pane-stream stream-write-table
>r >r
@ -303,7 +304,7 @@ M: paragraph dispose drop ;
M: pack stream-write gadget-write ; M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- ) : gadget-bl ( style stream -- )
>r " " <styled-label> <word-break-gadget> r> add-gadget ; >r " " <word-break-gadget> style-label r> add-gadget ;
M: paragraph stream-write M: paragraph stream-write
swap " " split swap " " split

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

@ -5,10 +5,10 @@ namespaces sequences math.order ;
IN: ui.gadgets.paragraphs IN: ui.gadgets.paragraphs
! A word break gadget ! A word break gadget
TUPLE: word-break-gadget ; TUPLE: word-break-gadget < label ;
: <word-break-gadget> ( gadget -- gadget ) : <word-break-gadget> ( text -- gadget )
{ set-delegate } word-break-gadget construct ; word-break-gadget new-label ;
M: word-break-gadget draw-gadget* drop ; M: word-break-gadget draw-gadget* drop ;

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

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.gadgets.buttons USING: help.markup help.syntax ui.gadgets.buttons
ui.gadgets.menus models ui.operations summary kernel ui.gadgets.menus models ui.operations summary kernel
ui.gadgets.worlds ui.gadgets ; ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
IN: ui.gadgets.presentations IN: ui.gadgets.presentations
HELP: presentation HELP: presentation
@ -37,6 +37,8 @@ HELP: <presentation>
{ <commands-menu> <toolbar> operations-menu show-menu } related-words { <commands-menu> <toolbar> operations-menu show-menu } related-words
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
HELP: show-mouse-help HELP: show-mouse-help
{ $values { "presentation" presentation } } { $values { "presentation" presentation } }
{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ; { $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;

11
extra/ui/gadgets/presentations/presentations.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors definitions ui.gadgets ui.gadgets.borders USING: arrays accessors definitions hashtables io kernel
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus prettyprint sequences strings io.styles words help math models
ui.gadgets.worlds hashtables io kernel prettyprint sequences namespaces quotations
strings io.styles words help math models namespaces quotations ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.commands ui.operations ui.gestures ; ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
IN: ui.gadgets.presentations IN: ui.gadgets.presentations
TUPLE: presentation < button object hook ; TUPLE: presentation < button object hook ;

2
extra/ui/gadgets/slots/slots-tests.factor
View File

@ -1,4 +1,6 @@
IN: ui.gadgets.slots.tests IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ; USING: assocs ui.gadgets.slots tools.test refs ;
\ <editable-slot> must-infer
[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test [ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test

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

@ -13,7 +13,7 @@ TUPLE: update-slot ;
TUPLE: edit-slot ; TUPLE: edit-slot ;
TUPLE: slot-editor ref text ; TUPLE: slot-editor < track ref text ;
: revert ( slot-editor -- ) : revert ( slot-editor -- )
dup slot-editor-ref get-ref unparse-use dup slot-editor-ref get-ref unparse-use
@ -69,16 +69,20 @@ M: value-ref finish-editing
} define-command } define-command
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
slot-editor new { 0 1 } slot-editor new-track
[ set-slot-editor-ref ] keep swap >>ref
[
[ [
toolbar, toolbar,
<source-editor> g-> set-slot-editor-text <source-editor> g-> set-slot-editor-text
<scroller> 1 track, <scroller> 1 track,
] { 0 1 } build-track ] with-gadget
] keep
dup revert ; dup revert ;
M: slot-editor pref-dim* delegate pref-dim* { 600 200 } vmin ; M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
M: slot-editor focusable-child* text>> ;
slot-editor "toolbar" f { slot-editor "toolbar" f {
{ T{ key-down f { C+ } "RET" } commit } { T{ key-down f { C+ } "RET" } commit }
@ -100,17 +104,16 @@ TUPLE: editable-slot < track printer ref ;
[ 1 track, <edit-button> f track, ] with-gadget ; [ 1 track, <edit-button> f track, ] with-gadget ;
: update-slot ( editable-slot -- ) : update-slot ( editable-slot -- )
[ [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
dup editable-slot-ref get-ref display-slot ;
swap editable-slot-printer call
] keep
[ display-slot ] keep
scroll>gadget ;
: edit-slot ( editable-slot -- ) : edit-slot ( editable-slot -- )
dup clear-track dup [ [ clear-track ]
dup editable-slot-ref <slot-editor> 1 track, [
] with-gadget scroll>gadget ; dup ref>> <slot-editor>
[ swap 1 track-add ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;
\ editable-slot H{ \ editable-slot H{
{ T{ update-slot } [ update-slot ] } { T{ update-slot } [ update-slot ] }

6
extra/ui/gadgets/status-bar/status-bar-docs.factor
View File

@ -1,10 +1,8 @@
USING: ui.gadgets.presentations help.markup help.syntax models USING: help.markup help.syntax models
ui.gadgets ui.gadgets.worlds ; ui.gadgets ui.gadgets.worlds ;
IN: ui.gadgets.status-bar IN: ui.gadgets.status-bar
HELP: <status-bar> HELP: <status-bar>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } } { $values { "model" model } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." } { $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display " { $link presentation } " mouse over help." } ; { $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words

19
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -2,6 +2,17 @@ USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
arrays kernel quotations classes.tuple ; arrays kernel quotations classes.tuple ;
IN: ui.gadgets.tracks IN: ui.gadgets.tracks
ARTICLE: "ui-track-layout" "Track layouts"
"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
{ $subsection track }
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add }
"Creating new tracks using a combinator:"
{ $subsection make-track }
{ $subsection track, } ;
HELP: track HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ; { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -9,7 +20,7 @@ HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } } { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ; { $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
{ <track> make-track build-track } related-words { <track> make-track } related-words
HELP: track-add HELP: track-add
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } } { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
@ -17,12 +28,10 @@ HELP: track-add
HELP: track, HELP: track,
{ $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } } { $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } " or " { $link build-track } "." } ; { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } "." } ;
HELP: make-track HELP: make-track
{ $values { "quot" quotation } { "orientation" "an orientation specifier" } { "track" track } } { $values { "quot" quotation } { "orientation" "an orientation specifier" } { "track" track } }
{ $description "Creates a new track. The quotation can add children by calling the " { $link track, } " word." } ; { $description "Creates a new track. The quotation can add children by calling the " { $link track, } " word." } ;
HELP: build-track ABOUT: "ui-track-layout"
{ $values { "tuple" tuple } { "quot" quotation } { "orientation" "an orientation specifier" } }
{ $description "Creates a new track and sets " { $snippet "tuple" } "'s delegate to the new track. The quotation can add children by calling the " { $link track, } " word, and access the track by calling " { $link g } " or " { $link g-> } "." } ;

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

@ -10,7 +10,7 @@ TUPLE: track < pack sizes ;
track-sizes track-sizes
[ sift sum ] keep [ dup [ over / ] when ] map nip ; [ sift sum ] keep [ dup [ over / ] when ] map nip ;
: new-track ( orientation -- track ) : new-track ( orientation class -- track )
new-gadget new-gadget
swap >>orientation swap >>orientation
V{ } clone >>sizes V{ } clone >>sizes
@ -55,9 +55,6 @@ M: track pref-dim*
: make-track ( quot orientation -- track ) : make-track ( quot orientation -- track )
<track> make-gadget ; inline <track> make-gadget ; inline
: build-track ( tuple quot orientation -- tuple )
<track> build-gadget ; inline
: track-remove ( gadget track -- ) : track-remove ( gadget track -- )
over [ over [
[ gadget-children index ] 2keep [ gadget-children index ] 2keep

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

@ -65,11 +65,9 @@ M: world children-on nip gadget-children ;
over world-handle over world-handle
rot rect-dim [ 0 > ] all? and and ; rot rect-dim [ 0 > ] all? and and ;
TUPLE: world-error world ; TUPLE: world-error error world ;
: <world-error> ( error world -- error ) C: <world-error> world-error
{ set-delegate set-world-error-world }
world-error construct ;
SYMBOL: ui-error-hook SYMBOL: ui-error-hook

19
extra/ui/operations/operations.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions kernel ui.commands ui.gestures USING: accessors arrays definitions kernel ui.commands
sequences strings math words generic namespaces hashtables ui.gestures sequences strings math words generic namespaces
help.markup quotations assocs ; hashtables help.markup quotations assocs ;
IN: ui.operations IN: ui.operations
SYMBOL: +keyboard+ SYMBOL: +keyboard+
@ -12,12 +12,11 @@ SYMBOL: +secondary+
TUPLE: operation predicate command translator hook listener? ; TUPLE: operation predicate command translator hook listener? ;
: <operation> ( predicate command -- operation ) : <operation> ( predicate command -- operation )
[ ] [ ] { operation new
set-operation-predicate [ ] >>hook
set-operation-command [ ] >>translator
set-operation-translator swap >>command
set-operation-hook swap >>predicate ;
} operation construct ;
PREDICATE: listener-operation < operation PREDICATE: listener-operation < operation
dup operation-command listener-command? dup operation-command listener-command?

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

@ -7,7 +7,7 @@ ui.gadgets.buttons compiler.units assocs words vocabs
accessors ; accessors ;
IN: ui.tools.browser IN: ui.tools.browser
TUPLE: browser-gadget pane history ; TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- ) : show-help ( link help -- )
dup history>> add-history dup history>> add-history
@ -20,12 +20,15 @@ TUPLE: browser-gadget pane history ;
"handbook" >link <history> >>history drop ; "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
browser-gadget new { 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,
] { 0 1 } build-track ; ] with-gadget
] keep ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;
@ -33,12 +36,10 @@ M: browser-gadget tool-scroller
pane>> find-scroller ; pane>> find-scroller ;
M: browser-gadget graft* M: browser-gadget graft*
dup add-definition-observer [ add-definition-observer ] [ call-next-method ] bi ;
delegate graft* ;
M: browser-gadget ungraft* M: browser-gadget ungraft*
dup delegate ungraft* [ call-next-method ] [ remove-definition-observer ] bi ;
remove-definition-observer ;
: showing-definition? ( defspec assoc -- ? ) : showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep [ key? ] 2keep

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

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui ui.commands ui.gestures ui.gadgets USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
@ -12,7 +12,7 @@ IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget ) : <restart-list> ( restarts restart-hook -- gadget )
[ restart-name ] rot <model> <list> ; [ restart-name ] rot <model> <list> ;
TUPLE: debugger restarts ; TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget ) : <debugger-display> ( restart-list error -- gadget )
[ [
@ -21,12 +21,14 @@ TUPLE: debugger restarts ;
] make-filled-pile ; ] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
debugger new { 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,
] { 0 1 } build-track ; ] with-gadget
] keep ;
M: debugger focusable-child* debugger-restarts ; M: debugger focusable-child* debugger-restarts ;
@ -38,9 +40,9 @@ M: debugger focusable-child* debugger-restarts ;
M: world-error error. M: world-error error.
"An error occurred while drawing the world " write "An error occurred while drawing the world " write
dup world-error-world pprint-short "." print dup world>> pprint-short "." print
"This world has been deactivated to prevent cascading errors." print "This world has been deactivated to prevent cascading errors." print
delegate error. ; error>> error. ;
debugger "gestures" f { debugger "gestures" f {
{ T{ button-down } request-focus } { T{ button-down } request-focus }

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

@ -8,7 +8,7 @@ ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ; tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ; TUPLE: deploy-gadget < pack vocab settings ;
: bundle-name ( -- ) : bundle-name ( -- )
deploy-name get <field> deploy-name get <field>
@ -105,11 +105,16 @@ deploy-gadget "toolbar" f {
g <toolbar> { 10 10 } over set-pack-gap gadget, ; g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget ) : <deploy-gadget> ( vocab -- gadget )
f deploy-gadget boa [ deploy-gadget new-gadget
dup <deploy-settings> swap >>vocab
{ 0 1 } >>orientation
[
[
g vocab>> <deploy-settings>
g-> set-deploy-gadget-settings gadget, g-> set-deploy-gadget-settings gadget,
buttons, buttons,
] { 0 1 } build-pack ] with-gadget
] keep
dup deploy-settings-theme dup deploy-settings-theme
dup com-revert ; dup com-revert ;

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

@ -6,7 +6,7 @@ ui.gadgets.slots ui.gadgets.tracks ui.gestures
ui.gadgets.buttons namespaces ; ui.gadgets.buttons namespaces ;
IN: ui.tools.inspector IN: ui.tools.inspector
TUPLE: inspector-gadget object pane ; TUPLE: inspector-gadget < track object pane ;
: refresh ( inspector -- ) : refresh ( inspector -- )
dup inspector-gadget-object swap inspector-gadget-pane [ dup inspector-gadget-object swap inspector-gadget-pane [
@ -14,11 +14,13 @@ TUPLE: inspector-gadget object pane ;
] with-pane ; ] with-pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
inspector-gadget new { 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,
] { 0 1 } build-track ; ] with-gadget
] keep ;
: inspect-object ( obj inspector -- ) : inspect-object ( obj inspector -- )
[ set-inspector-gadget-object ] keep refresh ; [ set-inspector-gadget-object ] keep refresh ;

2
extra/ui/tools/interactor/interactor.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors hashtables io io.styles kernel math math.order math.vectors
models models.delay namespaces parser lexer prettyprint models models.delay namespaces parser lexer prettyprint
quotations sequences strings threads listener classes.tuple quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ; ui.tools.workspace accessors sets destructors ;

2
extra/ui/tools/listener/listener-tests.factor
View File

@ -5,7 +5,7 @@ ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic threads accessors listener ; threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test [ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test [ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test

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

@ -10,7 +10,7 @@ prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs ; math arrays generic accessors combinators assocs ;
IN: ui.tools.listener IN: ui.tools.listener
TUPLE: listener-gadget input output stack ; TUPLE: listener-gadget < track input output stack ;
: listener-output, ( -- ) : listener-output, ( -- )
<scrolling-pane> g-> set-listener-gadget-output <scrolling-pane> g-> set-listener-gadget-output
@ -118,15 +118,18 @@ M: engine-word word-completion-string
dup "\n" join pick add-interactor-history dup "\n" join pick add-interactor-history
swap select-all ; swap select-all ;
TUPLE: stack-display ; TUPLE: stack-display < track ;
: <stack-display> ( -- gadget ) : <stack-display> ( -- gadget )
stack-display new g workspace-listener
g workspace-listener swap [ { 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,
] { 0 1 } build-track ; ] with-gadget
] keep ;
M: stack-display tool-scroller M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ; find-workspace workspace-listener tool-scroller ;
@ -169,8 +172,9 @@ M: stack-display tool-scroller
f <model> swap set-listener-gadget-stack ; f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
listener-gadget new dup init-listener { 0 1 } listener-gadget new-track
[ listener-output, listener-input, ] { 0 1 } build-track ; dup init-listener
[ [ listener-output, listener-input, ] with-gadget ] keep ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;
@ -189,7 +193,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
[ default-gesture-handler ] [ 3drop f ] if ; [ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft* M: listener-gadget graft*
[ delegate graft* ] [ restart-listener ] bi ; [ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft* M: listener-gadget ungraft*
[ com-end ] [ delegate ungraft* ] bi ; [ com-end ] [ call-next-method ] bi ;

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

@ -5,15 +5,17 @@ ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons ; ui.gadgets.tracks ui.gestures ui.gadgets.buttons ;
IN: ui.tools.profiler IN: ui.tools.profiler
TUPLE: profiler-gadget pane ; TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
profiler-gadget new { 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,
] { 0 1 } build-track ; ] with-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 ;

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

@ -11,7 +11,7 @@ vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
; ;
IN: ui.tools.search IN: ui.tools.search
TUPLE: live-search field list ; TUPLE: live-search < track field list ;
: search-value ( live-search -- value ) : search-value ( live-search -- value )
live-search-list list-value ; live-search-list list-value ;
@ -60,12 +60,14 @@ search-field H{
swap <list> ; swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
live-search new { 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,
] { 0 1 } build-track ] with-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 ;

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

@ -14,7 +14,7 @@ IN: ui.tools
: <workspace-tabs> ( -- tabs ) : <workspace-tabs> ( -- tabs )
g gadget-model g gadget-model
"tool-switching" workspace command-map "tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist [ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ; <toggle-buttons> ;

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

@ -1,22 +1,24 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel concurrency.messaging inspector ui.tools.listener USING: accessors kernel concurrency.messaging inspector
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.tracks ui.commands ui.gadgets models models.filter ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads models models.filter ui.tools.workspace ui.gestures
namespaces tools.walker assocs combinators ; ui.gadgets.labels ui threads namespaces tools.walker assocs
combinators ;
IN: ui.tools.walker IN: ui.tools.walker
TUPLE: walker-gadget TUPLE: walker-gadget < track
status continuation thread status continuation thread
traceback traceback
closing? ; closing? ;
: walker-command ( walker msg -- ) : walker-command ( walker msg -- )
swap swap
dup walker-gadget-thread thread-registered? dup thread>> thread-registered?
[ walker-gadget-thread send-synchronous drop ] [ thread>> send-synchronous drop ]
[ 2drop ] if ; [ 2drop ]
if ;
: com-step ( walker -- ) step walker-command ; : com-step ( walker -- ) step walker-command ;
@ -31,12 +33,10 @@ closing? ;
: com-abandon ( walker -- ) abandon walker-command ; : com-abandon ( walker -- ) abandon walker-command ;
M: walker-gadget ungraft* M: walker-gadget ungraft*
[ t swap set-walker-gadget-closing? ] [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
[ com-continue ]
[ delegate ungraft* ] tri ;
M: walker-gadget focusable-child* M: walker-gadget focusable-child*
walker-gadget-traceback ; traceback>> ;
: walker-state-string ( status thread -- string ) : walker-state-string ( status thread -- string )
[ [
@ -56,11 +56,17 @@ M: walker-gadget focusable-child*
[ walker-state-string ] curry <filter> <label-control> ; [ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget ) : <walker-gadget> ( status continuation thread -- gadget )
over <traceback-gadget> f walker-gadget boa [ { 0 1 } walker-gadget new-track
swap >>thread
swap >>continuation
swap >>status
[
[
toolbar, toolbar,
g walker-gadget-status self <thread-status> f track, g status>> self <thread-status> f track,
g walker-gadget-traceback 1 track, g continuation>> <traceback-gadget> 1 track,
] { 0 1 } build-track ; ] with-gadget
] keep ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;
@ -81,7 +87,7 @@ walker-gadget "toolbar" f {
{ {
{ [ dup walker-gadget? not ] [ 2drop f ] } { [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] } { [ dup walker-gadget-closing? ] [ 2drop f ] }
[ walker-gadget-thread eq? ] [ thread>> eq? ]
} cond ; } cond ;
: find-walker-window ( thread -- world/f ) : find-walker-window ( thread -- world/f )

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

@ -1,8 +1,6 @@
USING: ui.gadgets.worlds ui.gadgets ui.backend help.markup USING: help.markup help.syntax strings quotations debugger
help.syntax strings quotations debugger io.styles namespaces io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ;
ui.gadgets.frames ui.gadgets.books ui.gadgets.panes
ui.gadgets.incremental ;
IN: ui IN: ui
HELP: windows HELP: windows
@ -239,103 +237,17 @@ $nl
{ $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 make-gadget } " variable."
$nl $nl
"Combinators whose names are prefixed with " { $snippet "build-" } " take a tuple as input, and construct a new gadget which the tuple will delegate to. The primitive combinator used to define all combinators of this form:" "A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection build-gadget }
"In this case, the new gadget is stored in both the " { $link make-gadget } " and " { $link gadget } " variables."
$nl
"A combinator which stores a gadget in the " { $link gadget } " variable; it is used by " { $link build-gadget } ":"
{ $subsection with-gadget } { $subsection with-gadget }
"The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " and " { $link build-gadget } " to store child gadgets in tuple slots:" "The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " to store child gadgets in tuple slots:"
{ $subsection g } { $subsection g }
{ $subsection g-> } ; { $subsection g-> } ;
ARTICLE: "ui-pack-layout" "Pack layouts"
"Pack gadgets layout their children along a single axis."
{ $subsection pack }
"Creating empty packs:"
{ $subsection <pack> }
{ $subsection <pile> }
{ $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
ARTICLE: "ui-track-layout" "Track layouts"
"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
{ $subsection track }
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add }
"Creating new tracks using a combinator:"
{ $subsection make-track }
{ $subsection build-track }
{ $subsection track, }
"New gadgets can be defined which delegate to tracks for layout:"
{ $subsection build-track } ;
ARTICLE: "ui-grid-layout" "Grid layouts"
"Grid gadgets layout their children in a rectangular grid."
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
ARTICLE: "ui-frame-layout" "Frame layouts"
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection make-frame }
{ $subsection build-frame }
{ $subsection frame, }
"New gadgets can be defined which delegate to frames for layout:"
{ $subsection build-frame }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
{ $subsection @top }
{ $subsection @bottom }
{ $subsection @top-left }
{ $subsection @top-right }
{ $subsection @bottom-left }
{ $subsection @bottom-right } ;
ARTICLE: "ui-book-layout" "Book layouts"
"Books can contain any number of children, and display one child at a time."
{ $subsection book }
{ $subsection <book> } ;
ARTICLE: "ui-null-layout" "Manual layouts" ARTICLE: "ui-null-layout" "Manual layouts"
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:" "When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
{ $subsection set-rect-loc } { $subsection set-rect-loc }
{ $subsection set-gadget-dim } ; { $subsection set-gadget-dim } ;
ARTICLE: "ui-incremental-layout" "Incremental layouts"
"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
$nl
"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
$nl
"Incremental layout is used by " { $link pane } " gadgets to ensure that new lines of output does not take longer to display when the pane already has previous output."
$nl
"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
{ $subsection incremental }
{ $subsection <incremental> }
"Children are added and removed with a special set of words which perform necessary relayout immediately:"
{ $subsection add-incremental }
{ $subsection clear-incremental }
"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
ARTICLE: "ui-layout-impl" "Implementing layout gadgets" ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:" "The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
{ $subsection layout* } { $subsection layout* }