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

Clean up model-changed; no need for auxilliary tuples in editor and interactor

release
Slava Pestov 2007-11-16 03:01:45 -05:00
parent d6cf56162f
commit 57893118e0
22 changed files with 158 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/color-picker/color-picker.factor
View File

@ -18,7 +18,7 @@ TUPLE: color-preview ;
{ 100 100 } over set-rect-dim ;
M: color-preview model-changed
dup control-value over set-gadget-interior relayout-1 ;
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
[ [ 256 /f ] map 1 add <solid> ] <filter> ;

2
extra/models/models-tests.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ TUPLE: model-tester hit? ;
: <model-tester> model-tester construct-empty ;
M: model-tester model-changed t swap set-model-tester-hit? ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
[ T{ model-tester f t } ]
[

52
extra/models/models.factor Normal file → Executable file
View File

@ -3,10 +3,10 @@
USING: generic kernel math sequences timers arrays assocs ;
IN: models
TUPLE: model value connections dependencies ref ;
TUPLE: model value connections dependencies ref locked? ;
: <model> ( value -- model )
V{ } clone V{ } clone 0 model construct-boa ;
V{ } clone V{ } clone 0 f model construct-boa ;
M: model equal? 2drop f ;
@ -49,7 +49,7 @@ DEFER: remove-connection
drop
] if ;
GENERIC: model-changed ( observer -- )
GENERIC: model-changed ( model observer -- )
: add-connection ( observer model -- )
dup model-connections empty? [ dup activate-model ] when
@ -60,11 +60,26 @@ GENERIC: model-changed ( observer -- )
dup model-connections empty? [ dup deactivate-model ] when
drop ;
GENERIC: set-model ( value model -- )
: with-locked-model ( model quot -- )
swap
t over set-model-locked?
slip
f swap set-model-locked? ; inline
M: model set-model
[ set-model-value ] keep
model-connections [ model-changed ] each ;
GENERIC: update-model ( model -- )
M: model update-model drop ;
: set-model ( value model -- )
dup model-locked? [
2drop
] [
dup [
[ set-model-value ] keep
[ update-model ] keep
dup model-connections [ model-changed ] curry* each
] with-locked-model
] if ;
: ((change-model)) ( model quot -- newvalue model )
over >r >r model-value r> call r> ; inline
@ -87,10 +102,10 @@ TUPLE: filter model quot ;
[ add-dependency ] keep ;
M: filter model-changed
dup filter-model model-value over filter-quot call
swap model-value over filter-quot call
swap set-model ;
M: filter model-activated model-changed ;
M: filter model-activated dup filter-model swap model-changed ;
TUPLE: compose ;
@ -103,11 +118,13 @@ TUPLE: compose ;
: set-composed-value >r model-dependencies r> 2each ; inline
M: compose model-changed
nip
dup [ model-value ] composed-value swap delegate set-model ;
M: compose model-activated model-changed ;
M: compose model-activated dup model-changed ;
M: compose set-model [ set-model ] set-composed-value ;
M: compose update-model
dup model-value swap [ set-model ] set-composed-value ;
TUPLE: mapping assoc ;
@ -117,13 +134,15 @@ TUPLE: mapping assoc ;
tuck set-mapping-assoc ;
M: mapping model-changed
nip
dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ;
M: mapping model-activated model-changed ;
M: mapping model-activated dup model-changed ;
M: mapping set-model
mapping-assoc [ swapd at set-model ] curry assoc-each ;
M: mapping update-model
dup model-value swap mapping-assoc
[ swapd at set-model ] curry assoc-each ;
TUPLE: history back forward ;
@ -161,10 +180,9 @@ TUPLE: delay model timeout ;
f delay construct-model
[ set-delay-timeout ] keep
[ set-delay-model ] 2keep
[ add-dependency ] keep
dup update-delay-model ;
[ add-dependency ] keep ;
M: delay model-changed 0 over delay-timeout add-timer ;
M: delay model-changed nip 0 over delay-timeout add-timer ;
M: delay model-activated update-delay-model ;

4
extra/ui/gadgets/books/books-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: tools.test.inference ui.gadgets.books ;
{ 2 1 } [ <book> ] unit-test-effect

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

@ -10,15 +10,14 @@ TUPLE: book ;
: current-page ( book -- gadget )
[ control-value ] keep nth-gadget ;
M: book model-changed ( book -- )
M: book model-changed
nip
dup hide-all
dup current-page show-gadget
relayout ;
: <book> ( pages model -- book )
<gadget> book construct-control
[ add-gadgets ] keep
[ model-changed ] keep ;
<gadget> book construct-control [ add-gadgets ] keep ;
M: book pref-dim* gadget-children pref-dims max-dim ;

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

@ -141,7 +141,7 @@ TUPLE: checkbox ;
dup checkbox-theme ;
M: checkbox model-changed
dup control-value over set-button-selected? relayout-1 ;
swap model-value over set-button-selected? relayout-1 ;
TUPLE: radio-paint color ;
@ -178,7 +178,7 @@ TUPLE: radio-control value ;
tuck set-radio-control-value ; inline
M: radio-control model-changed
dup control-value
swap model-value
over radio-control-value =
over set-button-selected?
relayout-1 ;

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

@ -16,9 +16,6 @@ $nl
{ { $link editor-focused? } " - a boolean." }
} } ;
HELP: loc-monitor
{ $class-description "Instances of this class are used internally by " { $link editor } " controls to redraw the editor when the caret or mark is moved by calling " { $link set-model } " on " { $link editor-caret } " or " { $link editor-mark } "." } ;
HELP: <editor>
{ $values { "editor" "a new " { $link editor } } }
{ $description "Creates a new " { $link editor } " with an empty document." } ;

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

@ -1,41 +1,41 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
io.streams.string definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference ;
tools.test.inference tools.test.ui ;
[ t ] [
<editor> "editor" set
"editor" get graft*
"editor" get <plain-writer> [ \ = see ] with-stream
"editor" get editor-string [ \ = see ] string-out =
"editor" get ungraft*
"editor" get [
"editor" get <plain-writer> [ \ = see ] with-stream
"editor" get editor-string [ \ = see ] string-out =
] with-grafted-gadget
] unit-test
[ "foo bar" ] [
<editor> "editor" set
"editor" get graft*
"foo bar" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
"editor" get ungraft*
"editor" get [
"foo bar" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
] with-grafted-gadget
] unit-test
[ "baz quux" ] [
<editor> "editor" set
"editor" get graft*
"foo bar\nbaz quux" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
"editor" get ungraft*
"editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
] with-grafted-gadget
] unit-test
[ ] [
<editor> "editor" set
"editor" get graft*
"foo bar\nbaz quux" "editor" get set-editor-string
4 hand-click# set
"editor" get position-caret
"editor" get ungraft*
"editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string
4 hand-click# set
"editor" get position-caret
] with-grafted-gadget
] unit-test
{ 0 1 } [ <editor> ] unit-test-effect

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

@ -13,15 +13,11 @@ font color caret-color selection-color
caret mark
focused? ;
TUPLE: loc-monitor editor ;
: <loc> ( editor -- loc )
loc-monitor construct-boa
{ 0 0 } <model> [ add-connection ] keep ;
: <loc> ( -- loc ) { 0 0 } <model> ;
: init-editor-locs ( editor -- )
dup <loc> over set-editor-caret
dup <loc> swap set-editor-mark ;
<loc> over set-editor-caret
<loc> swap set-editor-mark ;
: editor-theme ( editor -- )
black over set-editor-color
@ -47,10 +43,14 @@ TUPLE: source-editor ;
: <source-editor> source-editor construct-editor ;
: activate-editor-model ( editor model -- )
dup activate-model swap gadget-model add-loc ;
2dup add-connection
dup activate-model
swap gadget-model add-loc ;
: deactivate-editor-model ( editor model -- )
dup deactivate-model swap gadget-model remove-loc ;
2dup remove-connection
dup deactivate-model
swap gadget-model remove-loc ;
M: editor graft*
dup
@ -62,12 +62,6 @@ M: editor ungraft*
dup editor-caret deactivate-editor-model
dup editor-mark deactivate-editor-model ;
M: editor model-changed
dup gadget-model
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop editor-self relayout ;
: editor-caret* ( editor -- loc ) editor-caret model-value ;
: editor-mark* ( editor -- loc ) editor-mark model-value ;
@ -133,10 +127,6 @@ M: editor model-changed
over scroll>rect
] when drop ;
M: loc-monitor model-changed
loc-monitor-editor editor-self
dup relayout-1 scroll>caret ;
: draw-caret ( -- )
editor get editor-focused? [
editor get
@ -218,6 +208,22 @@ M: editor draw-gadget*
M: editor pref-dim*
dup editor-font* swap control-value text-dim ;
: contents-changed
editor-self swap
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop relayout ;
: caret/mark-changed
nip editor-self dup relayout-1 scroll>caret ;
M: editor model-changed
{
{ [ 2dup gadget-model eq? ] [ contents-changed ] }
{ [ 2dup editor-caret eq? ] [ caret/mark-changed ] }
{ [ 2dup editor-mark eq? ] [ caret/mark-changed ] }
} cond ;
M: editor gadget-selection?
selection-start/end = not ;
@ -420,16 +426,6 @@ editor "selection" f {
{ T{ key-down f { S+ C+ } "END" } select-end-of-document }
} define-command-map
! Editors support the stream output protocol
M: editor stream-write1 >r 1string r> stream-write ;
M: editor stream-write
editor-self dup end-of-document user-input ;
M: editor stream-close drop ;
M: editor stream-flush drop ;
! Fields are like editors except they edit an external model
TUPLE: field model editor ;
@ -452,5 +448,6 @@ M: field ungraft*
dup field-editor gadget-model remove-connection ;
M: field model-changed
nip
dup field-editor editor-string
swap field-model set-model ;

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

@ -50,7 +50,7 @@ M: gadget equal? 2drop f ;
M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed drop ;
M: gadget model-changed 2drop ;
: gadget-child ( gadget -- child ) gadget-children first ;
@ -71,7 +71,7 @@ M: gadget model-changed drop ;
: activate-control ( gadget -- )
dup gadget-model dup [ 2dup add-connection ] when drop
model-changed ;
dup gadget-model swap model-changed ;
: deactivate-control ( gadget -- )
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;

15
extra/ui/gadgets/incremental/incremental.factor
View File

@ -11,14 +11,15 @@ IN: ui.gadgets.incremental
! pack-gap.
! The cursor is the current size of the incremental pack.
! New gadgets are added at cursor-cursor*gadget-orientation.
! New gadgets are added at
! incremental-cursor gadget-orientation v*
TUPLE: incremental cursor ;
: <incremental> ( pack -- incremental )
incremental construct-empty
[ set-gadget-delegate ] keep
dup delegate pref-dim over set-incremental-cursor ;
dup pref-dim
{ set-gadget-delegate set-incremental-cursor }
incremental construct ;
M: incremental pref-dim*
dup gadget-layout-state [
@ -39,7 +40,8 @@ M: incremental pref-dim*
swap set-rect-loc ;
: prefer-incremental ( gadget -- )
dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
dup forget-pref-dim dup pref-dim over set-rect-dim
layout ;
: add-incremental ( gadget incremental -- )
not-in-layout
@ -52,6 +54,7 @@ M: incremental pref-dim*
: clear-incremental ( incremental -- )
not-in-layout
dup (clear-gadget) dup forget-pref-dim
dup (clear-gadget)
dup forget-pref-dim
{ 0 0 } over set-incremental-cursor
gadget-parent [ relayout ] when* ;

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

@ -40,7 +40,7 @@ M: label gadget-text* label-string % ;
TUPLE: label-control ;
M: label-control model-changed
dup control-value over set-label-text relayout ;
swap model-value over set-label-text relayout ;
: <label-control> ( model -- gadget )
"" <label> label-control construct-control ;

1
extra/ui/gadgets/lists/lists.factor
View File

@ -42,6 +42,7 @@ TUPLE: list index presenter color hook ;
] map 2nip ;
M: list model-changed
nip
dup clear-gadget
dup <list-items> over add-gadgets
bound-index ;

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

@ -140,7 +140,7 @@ M: duplex-stream write-gadget
TUPLE: pane-control quot ;
M: pane-control model-changed
dup control-value swap dup pane-control-quot with-pane ;
swap model-value swap dup pane-control-quot with-pane ;
: <pane-control> ( model quot -- pane )
>r <pane> pane-control construct-control r>

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

@ -131,4 +131,4 @@ M: scroller focusable-child*
scroller-viewport ;
M: scroller model-changed
f swap set-scroller-follows ;
nip f swap set-scroller-follows ;

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

@ -47,7 +47,7 @@ TUPLE: slider elevator thumb saved line ;
: screen>slider slider-scale / ;
M: slider model-changed slider-elevator relayout-1 ;
M: slider model-changed nip slider-elevator relayout-1 ;
TUPLE: thumb ;

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

@ -32,6 +32,7 @@ M: viewport pref-dim* viewport-dim ;
gadget-model range-value [ >fixnum ] map ;
M: viewport model-changed
nip
dup relayout-1
dup scroller-value
vneg viewport-gap v+

4
extra/ui/tools/interactor/interactor-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: ui.tools.interactor tools.test.inference ;
{ 1 1 } [ <interactor> ] unit-test-effect

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

@ -25,19 +25,8 @@ help ;
2drop f
] if ;
TUPLE: caret-help model gadget ;
: <caret-help> ( interactor -- caret-help )
[ editor-caret 100 <delay> ] keep caret-help construct-boa
dup dup caret-help-model add-connection ;
M: caret-help model-changed
dup caret-help-gadget
swap caret-help-model model-value over word-at-loc
swap show-summary ;
: init-caret-help ( interactor -- )
dup <caret-help> swap set-interactor-help ;
dup editor-caret 100 <delay> swap set-interactor-help ;
: init-interactor-history ( interactor -- )
V{ } clone swap set-interactor-history ;
@ -52,13 +41,20 @@ M: caret-help model-changed
M: interactor graft*
dup delegate graft*
dup interactor-help caret-help-model activate-model
dup dup interactor-help add-connection
f swap set-interactor-busy? ;
M: interactor ungraft*
dup interactor-help caret-help-model deactivate-model
dup dup interactor-help remove-connection
delegate ungraft* ;
M: interactor model-changed
2dup interactor-help eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
] if ;
: write-input ( string input -- )
<input> presented associate
[ H{ { font-style bold } } format ] with-nesting ;

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

@ -49,6 +49,7 @@ IN: ui.tools
] if relayout ;
M: workspace model-changed
nip
dup workspace-listener listener-gadget-output scroll>bottom
dup resize-workspace
request-focus ;

57
extra/ui/tools/walker/walker-tests.factor Normal file → Executable file
View File

@ -2,27 +2,30 @@ USING: arrays continuations ui.tools.listener ui.tools.walker
ui.tools.workspace inspector kernel namespaces sequences threads
listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools tools.interpreter
tools.interpreter.debug ;
tools.interpreter.debug tools.test.inference tools.test.ui ;
IN: temporary
{ 0 1 } [ <walker> ] unit-test-effect
[ ] [ <walker> "walker" set ] unit-test
! Make sure the toolbar buttons don't throw if we're
! not actually walking.
"walker" get [
! Make sure the toolbar buttons don't throw if we're
! not actually walking.
[ ] [ "walker" get com-step ] unit-test
[ ] [ "walker" get com-into ] unit-test
[ ] [ "walker" get com-out ] unit-test
[ ] [ "walker" get com-back ] unit-test
[ ] [ "walker" get com-inspect ] unit-test
[ ] [ "walker" get reset-walker ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-step ] unit-test
[ ] [ "walker" get com-into ] unit-test
[ ] [ "walker" get com-out ] unit-test
[ ] [ "walker" get com-back ] unit-test
[ ] [ "walker" get com-inspect ] unit-test
[ ] [ "walker" get reset-walker ] unit-test
[ ] [ "walker" get com-continue ] unit-test
] with-grafted-gadget
: <test-world> ( gadget -- world )
[ gadget, ] make-pile "Hi" f <world> ;
[
f <workspace>
f <workspace> dup [
[ <test-world> 2array 1vector windows set ] keep
"ok" off
@ -37,38 +40,40 @@ IN: temporary
[ t ] [ "ok" get ] unit-test
[ ] [ <walker> "w" set ] unit-test
[ ] [ walker get-tool "w" set ] unit-test
continuation "c" set
[ ] [ "c" get "w" get call-tool* ] unit-test
[ ] [
[ "c" set f ] callcc1
[ "q" set ] [ "w" get com-inspect stop ] if*
] unit-test
[ t ] [
"q" get dup first continuation?
swap second \ inspect eq? and
] unit-test
] with-scope
] with-grafted-gadget
[
f <workspace> <test-world> 2array 1vector windows set
f <workspace> dup [
<test-world> 2array 1vector windows set
[ ] [
[ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
] unit-test
[ ] [
[ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
] unit-test
[ ] [ walker get-tool com-continue ] unit-test
[ ] [ walker get-tool com-continue ] unit-test
[ ] [ yield ] unit-test
[ ] [ yield ] unit-test
[ t ] [ walker get-tool walker-active? ] unit-test
[ t ] [ walker get-tool walker-active? ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
] with-grafted-gadget
] with-scope

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

@ -46,12 +46,13 @@ TUPLE: walker model interpreter history ;
V{ } clone over set-walker-history
update-stacks ;
M: walker graft* dup delegate graft* reset-walker ;
: <walker> ( -- gadget )
f <model> f f walker construct-boa [
toolbar,
g walker-model <traceback-gadget> 1 track,
] { 0 1 } build-track
dup reset-walker ;
] { 0 1 } build-track ;
M: walker call-tool* ( continuation walker -- )
[ restore ] with-walker ;