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

More control refactoring

release
Slava Pestov 2007-11-14 16:35:17 -05:00
parent 9bb0c40dc8
commit eee42d4bd5
26 changed files with 133 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/models/models-docs.factor Normal file → Executable file
View File

@ -106,7 +106,7 @@ $nl
": <funny-slider> <x-slider> 100 over set-slider-max ;"
"<funny-slider> <funny-slider> 2array"
"dup make-pile gadget."
"dup [ control-model ] map <compose> [ unparse ] <filter>"
"dup [ gadget-model ] map <compose> [ unparse ] <filter>"
"<label-control> gadget."
}
} ;
@ -146,7 +146,7 @@ HELP: delay
": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget."
"control-model 500 <delay> [ number>string ] <filter>"
"gadget-model 500 <delay> [ number>string ] <filter>"
"<label-control> gadget."
}
} ;

2
extra/slides/slides.factor
View File

@ -75,7 +75,7 @@ TUPLE: slides ;
: change-page ( book n -- )
over control-value + over gadget-children length rem
swap control-model set-model ;
swap gadget-model set-model ;
: next-page ( book -- ) 1 change-page ;

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

@ -2,10 +2,10 @@ USING: ui.gadgets.books help.markup
help.syntax ui.gadgets models ;
HELP: book
{ $class-description "A book is a " { $link control } " containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
$nl
"Books are created by calling " { $link <book> } "." } ;
HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
{ $description "Creates a " { $link book } { $link 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 " } ;

19
extra/ui/gadgets/buttons/buttons-tests.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
IN: temporary
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
ui.gadgets tools.test namespaces sequences kernel ;
ui.gadgets tools.test namespaces sequences kernel models ;
TUPLE: foo-gadget ;
@ -17,3 +17,20 @@ T{ foo-gadget } <toolbar> "t" set
[ 2 ] [ "t" get gadget-children length ] unit-test
[ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test
[ ] [
2 <model> {
{ 0 "atheist" }
{ 1 "christian" }
{ 2 "muslim" }
{ 3 "jewish" }
} <radio-buttons> "religion" set
] unit-test
[ 0 ] [
"religion" get gadget-child radio-control-value
] unit-test
[ 2 ] [
"religion" get gadget-child control-value
] unit-test

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

@ -183,13 +183,14 @@ M: radio-control model-changed
over set-button-selected?
relayout-1 ;
: <radio-controls> ( model assoc quot -- gadget )
swapd [ >r -rot r> call gadget, ] 2curry assoc-each ; inline
: <radio-controls> ( model assoc quot -- )
#! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
: radio-button-theme
{ 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
: <radio-button> ( model value label -- gadget )
: <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right
[ <button> ] <radio-control>
dup radio-button-theme ;
@ -201,7 +202,7 @@ M: radio-control model-changed
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
dup radio-buttons-theme ;
: <toggle-button> ( model value label -- gadget )
: <toggle-button> ( value model label -- gadget )
[ <bevel-button> ] <radio-control> ;
: <toggle-buttons> ( model assoc -- gadget )

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

@ -3,7 +3,7 @@ ui.gadgets.scrollers models strings ui.commands ;
IN: ui.gadgets.editors
HELP: editor
{ $class-description "An editor is a " { $link control } " for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
$nl
"Editors have the following slots:"
{ $list

58
extra/ui/gadgets/editors/editors.factor
View File

@ -9,6 +9,7 @@ colors combinators ;
IN: ui.gadgets.editors
TUPLE: editor
self
font color caret-color selection-color
caret mark
focused? ;
@ -31,6 +32,7 @@ TUPLE: loc-monitor editor ;
: <editor> ( -- editor )
<document> <gadget> editor construct-control
dup dup set-editor-self
dup init-editor-locs
dup editor-theme ;
@ -38,42 +40,42 @@ TUPLE: loc-monitor editor ;
gray <solid> swap set-gadget-boundary ;
: construct-editor ( class -- tuple )
>r <editor> { set-gadget-delegate } r>
(construct-control) ; inline
>r <editor> { set-gadget-delegate } r> construct
dup dup set-editor-self ; inline
TUPLE: source-editor ;
: <source-editor> source-editor construct-editor ;
: activate-editor-model ( editor model -- )
dup activate-model swap control-model add-loc ;
dup activate-model swap gadget-model add-loc ;
: deactivate-editor-model ( editor model -- )
dup deactivate-model swap control-model remove-loc ;
dup deactivate-model swap gadget-model remove-loc ;
M: editor graft*
dup dup editor-caret activate-editor-model
dup dup editor-mark activate-editor-model
dup control-self swap control-model add-connection ;
dup
dup editor-caret activate-editor-model
dup editor-mark activate-editor-model ;
M: editor ungraft*
dup dup editor-caret deactivate-editor-model
dup dup editor-mark deactivate-editor-model
dup control-self swap control-model remove-connection ;
dup
dup editor-caret deactivate-editor-model
dup editor-mark deactivate-editor-model ;
M: editor model-changed
control-self dup control-model
dup gadget-model
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop relayout ;
drop editor-self relayout ;
: editor-caret* ( editor -- loc ) editor-caret model-value ;
: editor-mark* ( editor -- loc ) editor-mark model-value ;
: change-caret ( editor quot -- )
over >r >r dup editor-caret* swap control-model r> call r>
[ control-model validate-loc ] keep
over >r >r dup editor-caret* swap gadget-model r> call r>
[ gadget-model validate-loc ] keep
editor-caret set-model ; inline
: mark>caret ( editor -- )
@ -90,7 +92,7 @@ M: editor model-changed
editor-font* "" string-height ;
: y>line ( y editor -- line# )
[ line-height / >fixnum ] keep control-model validate-line ;
[ line-height / >fixnum ] keep gadget-model validate-line ;
: point>loc ( point editor -- loc )
[
@ -133,7 +135,7 @@ M: editor model-changed
] when drop ;
M: loc-monitor model-changed
loc-monitor-editor control-self
loc-monitor-editor editor-self
dup relayout-1 scroll>caret ;
: draw-caret ( -- )
@ -167,7 +169,7 @@ M: loc-monitor model-changed
swap
dup first-visible-line \ first-visible-line set
dup last-visible-line \ last-visible-line set
dup control-model document set
dup gadget-model document set
editor set
call
] with-scope ; inline
@ -221,19 +223,19 @@ M: editor gadget-selection?
selection-start/end = not ;
M: editor gadget-selection
[ selection-start/end ] keep control-model doc-range ;
[ selection-start/end ] keep gadget-model doc-range ;
: remove-selection ( editor -- )
[ selection-start/end ] keep control-model remove-doc-range ;
[ selection-start/end ] keep gadget-model remove-doc-range ;
M: editor user-input*
[ selection-start/end ] keep control-model set-doc-range t ;
[ selection-start/end ] keep gadget-model set-doc-range t ;
: editor-string ( editor -- string )
control-model doc-string ;
gadget-model doc-string ;
: set-editor-string ( string editor -- )
control-model set-doc-string ;
gadget-model set-doc-string ;
M: editor gadget-text* editor-string % ;
@ -250,8 +252,8 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [
drop nip remove-selection
] [
over >r >r dup editor-caret* swap control-model
r> call r> control-model remove-doc-range
over >r >r dup editor-caret* swap gadget-model
r> call r> gadget-model remove-doc-range
] if ; inline
: editor-delete ( editor elt -- )
@ -277,7 +279,7 @@ M: editor gadget-text* editor-string % ;
: select-elt ( editor elt -- )
over >r
>r dup editor-caret* swap control-model r> prev/next-elt
>r dup editor-caret* swap gadget-model r> prev/next-elt
r> editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
@ -423,7 +425,7 @@ editor "selection" f {
M: editor stream-write1 >r 1string r> stream-write ;
M: editor stream-write
control-self dup end-of-document user-input ;
editor-self dup end-of-document user-input ;
M: editor stream-close drop ;
@ -445,10 +447,10 @@ TUPLE: field model editor ;
M: field graft*
dup field-model model-value
over field-editor set-editor-string
dup field-editor control-model add-connection ;
dup field-editor gadget-model add-connection ;
M: field ungraft*
dup field-editor control-model remove-connection ;
dup field-editor gadget-model remove-connection ;
M: field model-changed
dup field-editor editor-string

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

@ -68,16 +68,12 @@ M: gadget model-changed drop ;
: construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model r> construct-delegate ; inline
: activate-control ( gadget -- )
dup gadget-model dup [ dupd add-connection ] when
dup gadget-model dup [ 2dup add-connection ] when drop
model-changed ;
: deactivate-control ( gadget -- )
dup gadget-model dup [ dupd remove-connection ] when
drop ;
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
: control-value ( control -- value )
gadget-model model-value ;
@ -139,6 +135,10 @@ M: gadget children-on nip gadget-children ;
dup pick [ set-gadget-parent ] curry* each-child
] when set-delegate ;
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model
{ set-gadget-delegate } r> construct ; inline
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )

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

@ -19,7 +19,7 @@ HELP: <closable-gadget>
HELP: <labelled-pane>
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ <labelled-pane> <pane-control> } related-words

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

@ -18,7 +18,7 @@ HELP: set-label-string
HELP: <label-control>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a " { $link control } " which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
{ $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
{ label-string set-label-string } related-words
{ <label> <label-control> } related-words

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math namespaces
opengl sequences io.streams.lines strings splitting
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors ;
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
models ;
IN: ui.gadgets.labels
! A label gadget draws a string.

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

@ -7,7 +7,7 @@ HELP: +secondary+
HELP: list
{ $class-description
"A list " { $link control } " is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
"A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
$nl
"Lists are created by calling " { $link <list> } "."
{ $command-map list "keyboard-navigation" }

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

@ -44,7 +44,7 @@ HELP: <scrolling-pane>
HELP: <pane-control>
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
HELP: pane-stream
{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;

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

@ -8,7 +8,7 @@ hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
io.streams.duplex sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines tuples ;
ui.gadgets.grid-lines tuples models ;
IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls?

24
extra/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -1,7 +1,8 @@
IN: temporary
USING: ui.gadgets ui.gadgets.scrollers
namespaces tools.test kernel models ui.gadgets.viewports math
math.vectors arrays sequences ;
namespaces tools.test kernel models ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences ;
[ ] [
<gadget> "g" set
@ -22,7 +23,7 @@ math.vectors arrays sequences ;
<viewport> "v" set
] unit-test
[ { 10 20 } ] [ "v" get control-model range-value ] unit-test
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
@ -43,15 +44,15 @@ math.vectors arrays sequences ;
[ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get control-model range-min-value ] unit-test
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
[ { 106 106 } ] [ "s" get control-model range-max-value ] unit-test
[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test
[ { 10 20 } ] [ "s" get control-model range-value ] unit-test
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get scroller-viewport control-model range-value ] unit-test
[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
@ -74,3 +75,12 @@ dup layout
"s" get scroller-value
] map [ { 3 0 } = ] all?
] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test

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

@ -29,15 +29,15 @@ scroller H{
} set-gestures
: viewport, ( -- )
g control-model <viewport>
g gadget-model <viewport>
g-> set-scroller-viewport @center frame, ;
: <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: x-model g control-model model-dependencies first ;
: x-model g gadget-model model-dependencies first ;
: y-model g control-model model-dependencies second ;
: y-model g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller )
<scroller-model> <frame> scroller construct-control [
@ -70,11 +70,18 @@ scroller H{
] keep dup scroller-value rot v+ swap scroll ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
scroller-viewport gadget-child 2dup swap child?
[ relative-loc offset-rect ] [ 3drop f ] if ;
scroller-viewport gadget-child relative-loc offset-rect ;
: find-scroller* ( gadget -- scroller )
dup find-scroller dup [
2dup scroller-viewport gadget-child
swap child? [ nip ] [ 2drop f ] if
] [
2drop f
] if ;
: scroll>rect ( rect gadget -- )
dup find-scroller dup [
dup find-scroller* dup [
[ relative-scroll-rect ] keep
[ set-scroller-follows ] keep
relayout
@ -88,7 +95,7 @@ scroller H{
(scroll>rect) ;
: scroll>gadget ( gadget -- )
dup find-scroller dup [
dup find-scroller* dup [
[ set-scroller-follows ] keep
relayout
] [
@ -99,7 +106,7 @@ scroller H{
dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- )
find-scroller [
find-scroller* [
t over set-scroller-follows relayout-1
] when* ;
@ -108,10 +115,10 @@ scroller H{
: update-scroller ( scroller follows -- )
{
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
{ [ dup rect? ] [ swap (scroll>rect) ] }
{ [ dup ] [ swap (scroll>gadget) ] }
{ [ t ] [ drop dup scroller-value swap scroll ] }
{ [ dup t eq? ] [ drop (scroll>bottom) "A" drop ] }
{ [ dup rect? ] [ swap (scroll>rect) "B" drop ] }
{ [ dup ] [ swap (scroll>gadget) "C" drop ] }
{ [ t ] [ drop dup scroller-value swap scroll "D" drop ] }
} cond ;
M: scroller layout*

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

@ -9,7 +9,7 @@ HELP: find-elevator
{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
HELP: slider
{ $class-description "A slider is a " { $link control } " for graphically manipulating a " { $link "models-range" } "."
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$nl
"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
@ -56,6 +56,6 @@ ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
{ $subsection slide-by }
{ $subsection slide-by-line }
{ $subsection slide-by-page }
"Since sliders are controls the value can be get and set by calling " { $link control-model } "." ;
"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
ABOUT: "ui.gadgets.sliders"

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

@ -22,13 +22,13 @@ TUPLE: slider elevator thumb saved line ;
: min-thumb-dim 15 ;
: slider-value control-model range-value >fixnum ;
: slider-value gadget-model range-value >fixnum ;
: slider-page control-model range-page-value ;
: slider-page gadget-model range-page-value ;
: slider-max control-model range-max-value ;
: slider-max gadget-model range-max-value ;
: slider-max* control-model range-max-value* ;
: slider-max* gadget-model range-max-value* ;
: thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min
@ -57,7 +57,7 @@ TUPLE: thumb ;
: do-drag ( thumb -- )
find-slider drag-loc over gadget-orientation v.
over screen>slider swap [ slider-saved + ] keep
control-model set-range-value ;
gadget-model set-range-value ;
thumb H{
{ T{ button-down } [ begin-drag ] }
@ -75,10 +75,10 @@ thumb H{
[ set-gadget-orientation ] keep ;
: slide-by ( amount slider -- )
control-model move-by ;
gadget-model move-by ;
: slide-by-page ( amount slider -- )
control-model move-by-page ;
gadget-model move-by-page ;
: compute-direction ( elevator -- -1/1 )
dup find-slider swap hand-click-rel

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

@ -2,7 +2,7 @@ USING: ui.gadgets.viewports help.markup
help.syntax ui.gadgets models ;
HELP: viewport
{ $class-description "A viewport is a " { $link control } " which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
{ $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
HELP: <viewport>
{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }

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

@ -30,7 +30,7 @@ M: viewport focusable-child*
M: viewport pref-dim* viewport-dim ;
: scroller-value ( scroller -- loc )
control-model range-value [ >fixnum ] map ;
gadget-model range-value [ >fixnum ] map ;
M: viewport model-changed
dup relayout-1

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

@ -19,7 +19,7 @@ help ;
: word-at-loc ( loc interactor -- word )
over [
[ control-model T{ one-word-elt } elt-string ] keep
[ gadget-model T{ one-word-elt } elt-string ] keep
interactor-use assoc-stack
] [
2drop f
@ -46,7 +46,7 @@ M: caret-help model-changed
<source-editor>
{ set-interactor-output set-gadget-delegate }
interactor construct
dup dup set-control-self
dup dup set-editor-self
dup init-interactor-history
dup init-caret-help ;
@ -79,7 +79,7 @@ M: interactor ungraft*
[ editor-string ] keep
[ interactor-input. ] 2keep
[ add-interactor-history ] keep
dup control-model clear-doc
dup gadget-model clear-doc
interactor-continue ;
: interactor-eval ( interactor -- )
@ -123,7 +123,7 @@ M: interactor stream-read-partial
: go-to-error ( interactor error -- )
dup parse-error-line 1- swap parse-error-col 2array
over [ control-model validate-loc ] keep
over [ gadget-model validate-loc ] keep
editor-caret set-model
mark>caret ;
@ -156,7 +156,7 @@ M: interactor parse-interactive
M: interactor pref-dim*
0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
: clear-input control-model clear-doc ;
: clear-input gadget-model clear-doc ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }

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

@ -1,6 +1,6 @@
USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
timers tools.test ui.commands ui.gadgets.editors
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words ;
IN: temporary
@ -30,6 +30,6 @@ H{ } "i" get set-interactor-vars
] unit-test
[ t ] [
"i" get control-model doc-end
"i" get gadget-model doc-end
"i" get editor-caret* =
] unit-test

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

@ -44,7 +44,7 @@ search-field H{
} set-gestures
: <search-model> ( producer -- model )
>r g live-search-field control-model 200 <delay>
>r g live-search-field gadget-model 200 <delay>
[ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget )

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

@ -22,13 +22,13 @@ IN: ui.tools
} ;
: <workspace-tabs> ( -- tabs )
g control-model
g gadget-model
"tool-switching" workspace command-map
[ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ;
: <workspace-book> ( -- gadget )
workspace-tabs [ execute ] map g control-model <book> ;
workspace-tabs [ execute ] map g gadget-model <book> ;
: <workspace> ( -- workspace )
0 <model> { 0 1 } <track> workspace construct-control [

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

@ -25,10 +25,10 @@ M: traceback-gadget pref-dim* drop { 300 400 } ;
{ 0 1 } <track> traceback-gadget construct-control [
[
[
g control-model <datastack-display> 1/2 track,
g control-model <retainstack-display> 1/2 track,
g gadget-model <datastack-display> 1/2 track,
g gadget-model <retainstack-display> 1/2 track,
] { 1 0 } make-track 1/3 track,
g control-model <callstack-display> 2/3 track,
g gadget-model <callstack-display> 2/3 track,
] with-gadget
] keep ;

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

@ -28,7 +28,7 @@ M: gadget tool-scroller drop f ;
workspace-book gadget-children [ class eq? ] curry* find ;
: show-tool ( class workspace -- tool )
[ find-tool swap ] keep workspace-book control-model
[ find-tool swap ] keep workspace-book gadget-model
set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ;