graft*/ungraft* refactoring
Slava Pestov
parent
d8a0c08de9
commit
cef837184b
|
|
@ -0,0 +1,16 @@
|
|||
USING: dlists ui.gadgets kernel ui namespaces io.streams.string
|
||||
io ;
|
||||
IN: tools.test.ui
|
||||
|
||||
! We can't print to stdio here because that might be a pane
|
||||
! stream, and our graft-queue rebinding here would be captured
|
||||
! by code adding children to the pane...
|
||||
: with-grafted-gadget ( gadget quot -- )
|
||||
[
|
||||
<dlist> \ graft-queue [
|
||||
over
|
||||
graft notify-queued
|
||||
swap slip
|
||||
ungraft notify-queued
|
||||
] with-variable
|
||||
] string-out print ;
|
||||
|
|
@ -62,7 +62,6 @@ M: cocoa-ui-backend set-title ( string world -- )
|
|||
|
||||
M: cocoa-ui-backend (open-world-window) ( world -- )
|
||||
dup gadget-window
|
||||
dup start-world
|
||||
dup auto-position
|
||||
world-handle second f -> makeKeyAndOrderFront: ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: temporary
|
||||
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets tools.test namespaces sequences kernel models ;
|
||||
ui.gadgets tools.test namespaces sequences kernel models
|
||||
tools.test.inference ;
|
||||
|
||||
TUPLE: foo-gadget ;
|
||||
|
||||
|
|
@ -27,6 +28,12 @@ T{ foo-gadget } <toolbar> "t" set
|
|||
} <radio-buttons> "religion" set
|
||||
] unit-test
|
||||
|
||||
{ 2 1 } [ <radio-buttons> ] unit-test-effect
|
||||
|
||||
{ 2 1 } [ <toggle-buttons> ] unit-test-effect
|
||||
|
||||
{ 2 1 } [ <checkbox> ] unit-test-effect
|
||||
|
||||
[ 0 ] [
|
||||
"religion" get gadget-child radio-control-value
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
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 ;
|
||||
ui.gadgets.grids prettyprint documents ui.gestures
|
||||
tools.test.inference ;
|
||||
|
||||
[ t ] [
|
||||
<editor> "editor" set
|
||||
|
|
@ -36,3 +37,5 @@ ui.gadgets.grids prettyprint documents ui.gestures ;
|
|||
"editor" get position-caret
|
||||
"editor" get ungraft*
|
||||
] unit-test
|
||||
|
||||
{ 0 1 } [ <editor> ] unit-test-effect
|
||||
|
|
|
|||
|
|
@ -2,10 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays documents ui.clipboards ui.commands ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets.scrollers ui.gadgets.theme
|
||||
ui.render ui.gestures io kernel math models namespaces opengl
|
||||
opengl.gl sequences strings io.styles math.vectors sorting
|
||||
colors combinators ;
|
||||
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
|
||||
kernel math models namespaces opengl opengl.gl sequences strings
|
||||
io.styles math.vectors sorting colors combinators ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor
|
||||
|
|
@ -129,7 +128,7 @@ M: editor model-changed
|
|||
line-height 0 swap 2array ;
|
||||
|
||||
: scroll>caret ( editor -- )
|
||||
dup gadget-grafted? [
|
||||
dup gadget-status second [
|
||||
dup caret-loc over caret-dim { 1 0 } v+ <rect>
|
||||
over scroll>rect
|
||||
] when drop ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
IN: temporary
|
||||
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
|
||||
namespaces models kernel ;
|
||||
namespaces models kernel tools.test.inference dlists math
|
||||
math.parser ui sequences hashtables assocs io arrays
|
||||
prettyprint io.streams.string ;
|
||||
|
||||
[ T{ rect f { 10 10 } { 20 20 } } ]
|
||||
[
|
||||
|
|
@ -49,11 +51,11 @@ C: <fooey> fooey
|
|||
"a" get "b" get add-gadget
|
||||
<gadget> "c" set
|
||||
"b" get "c" get add-gadget
|
||||
|
||||
|
||||
! position a and b
|
||||
{ 100 200 } "a" get set-rect-loc
|
||||
{ 200 100 } "b" get set-rect-loc
|
||||
|
||||
|
||||
! give c a loc, it doesn't matter
|
||||
{ -1000 23 } "c" get set-rect-loc
|
||||
|
||||
|
|
@ -108,3 +110,95 @@ C: <fooey> fooey
|
|||
{ 1 1 } "g4" get set-rect-dim
|
||||
|
||||
[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
|
||||
|
||||
TUPLE: mock-gadget graft-called ungraft-called ;
|
||||
|
||||
: <mock-gadget>
|
||||
0 0 mock-gadget construct-boa <gadget> over set-delegate ;
|
||||
|
||||
M: mock-gadget graft*
|
||||
dup mock-gadget-graft-called 1+
|
||||
swap set-mock-gadget-graft-called ;
|
||||
|
||||
M: mock-gadget ungraft*
|
||||
dup mock-gadget-ungraft-called 1+
|
||||
swap set-mock-gadget-ungraft-called ;
|
||||
|
||||
! We can't print to stdio here because that might be a pane
|
||||
! stream, and our graft-queue rebinding here would be captured
|
||||
! by code adding children to the pane...
|
||||
[
|
||||
<dlist> \ graft-queue [
|
||||
[ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
|
||||
[ t ] [ graft-queue dlist-empty? ] unit-test
|
||||
] with-variable
|
||||
|
||||
<dlist> \ graft-queue [
|
||||
[ t ] [ graft-queue dlist-empty? ] unit-test
|
||||
|
||||
<mock-gadget> "g" set
|
||||
[ ] [ "g" get queue-graft ] unit-test
|
||||
[ f ] [ graft-queue dlist-empty? ] unit-test
|
||||
[ { f t } ] [ "g" get gadget-status ] unit-test
|
||||
[ ] [ "g" get graft-later ] unit-test
|
||||
[ { f t } ] [ "g" get gadget-status ] unit-test
|
||||
[ ] [ "g" get ungraft-later ] unit-test
|
||||
[ { f f } ] [ "g" get gadget-status ] unit-test
|
||||
[ t ] [ graft-queue dlist-empty? ] unit-test
|
||||
[ ] [ "g" get ungraft-later ] unit-test
|
||||
[ ] [ "g" get graft-later ] unit-test
|
||||
[ ] [ notify-queued ] unit-test
|
||||
[ { t t } ] [ "g" get gadget-status ] unit-test
|
||||
[ t ] [ graft-queue dlist-empty? ] unit-test
|
||||
[ ] [ "g" get graft-later ] unit-test
|
||||
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
|
||||
[ ] [ "g" get ungraft-later ] unit-test
|
||||
[ { t f } ] [ "g" get gadget-status ] unit-test
|
||||
[ ] [ notify-queued ] unit-test
|
||||
[ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
|
||||
[ { f f } ] [ "g" get gadget-status ] unit-test
|
||||
] with-variable
|
||||
|
||||
: add-some-children
|
||||
3 [
|
||||
<mock-gadget> over <model> over set-gadget-model
|
||||
dup "g" get add-gadget
|
||||
swap 1+ number>string set
|
||||
] each ;
|
||||
|
||||
: status-flags
|
||||
{ "g" "1" "2" "3" } [ get gadget-status ] map prune ;
|
||||
|
||||
: notify-combo ( ? ? -- )
|
||||
nl "===== Combo: " write 2dup 2array . nl
|
||||
<dlist> \ graft-queue [
|
||||
<mock-gadget> "g" set
|
||||
[ ] [ add-some-children ] unit-test
|
||||
[ V{ { f f } } ] [ status-flags ] unit-test
|
||||
[ ] [ "g" get graft ] unit-test
|
||||
[ V{ { f t } } ] [ status-flags ] unit-test
|
||||
dup [ [ ] [ notify-queued ] unit-test ] when
|
||||
[ ] [ "g" get clear-gadget ] unit-test
|
||||
[ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
|
||||
[ [ ] [ notify-queued ] unit-test ] when
|
||||
[ ] [ add-some-children ] unit-test
|
||||
[ { f t } ] [ "1" get gadget-status ] unit-test
|
||||
[ { f t } ] [ "2" get gadget-status ] unit-test
|
||||
[ { f t } ] [ "3" get gadget-status ] unit-test
|
||||
[ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
|
||||
[ ] [ notify-queued ] unit-test
|
||||
[ V{ { t t } } ] [ status-flags ] unit-test
|
||||
] with-variable ;
|
||||
|
||||
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
|
||||
] string-out print
|
||||
|
||||
{ 0 1 } [ <gadget> ] unit-test-effect
|
||||
{ 1 0 } [ unparent ] unit-test-effect
|
||||
{ 2 0 } [ add-gadget ] unit-test-effect
|
||||
{ 2 0 } [ add-gadgets ] unit-test-effect
|
||||
{ 1 0 } [ clear-gadget ] unit-test-effect
|
||||
|
||||
{ 1 0 } [ relayout ] unit-test-effect
|
||||
{ 1 0 } [ relayout-1 ] unit-test-effect
|
||||
{ 1 1 } [ pref-dim ] unit-test-effect
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ M: array rect-dim drop { 0 0 } ;
|
|||
|
||||
TUPLE: gadget
|
||||
pref-dim parent children orientation state focus
|
||||
visible? root? clipped? grafted?
|
||||
visible? root? clipped? status
|
||||
interior boundary
|
||||
model ;
|
||||
|
||||
|
|
@ -59,10 +59,11 @@ M: gadget model-changed drop ;
|
|||
: <zero-rect> ( -- rect ) { 0 0 } dup <rect> ;
|
||||
|
||||
: <gadget> ( -- gadget )
|
||||
<zero-rect> { 0 1 } t {
|
||||
<zero-rect> { 0 1 } t { f f } {
|
||||
set-delegate
|
||||
set-gadget-orientation
|
||||
set-gadget-visible?
|
||||
set-gadget-status
|
||||
} gadget construct ;
|
||||
|
||||
: construct-gadget ( class -- tuple )
|
||||
|
|
@ -173,13 +174,13 @@ M: array gadget-text*
|
|||
|
||||
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
|
||||
|
||||
: invalid ( -- queue ) \ invalid get-global ;
|
||||
: layout-queue ( -- queue ) \ layout-queue get ;
|
||||
|
||||
: add-invalid ( gadget -- )
|
||||
: layout-later ( gadget -- )
|
||||
#! When unit testing gadgets without the UI running, the
|
||||
#! invalid queue is not initialized and we simply ignore
|
||||
#! invalidation requests.
|
||||
invalid [ push-front ] [ drop ] if* ;
|
||||
layout-queue [ push-front ] [ drop ] if* ;
|
||||
|
||||
DEFER: relayout
|
||||
|
||||
|
|
@ -187,7 +188,7 @@ DEFER: relayout
|
|||
\ invalidate* over set-gadget-state
|
||||
dup forget-pref-dim
|
||||
dup gadget-root?
|
||||
[ add-invalid ] [ gadget-parent [ relayout ] when* ] if ;
|
||||
[ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
|
||||
|
||||
: relayout ( gadget -- )
|
||||
dup gadget-state \ invalidate* eq?
|
||||
|
|
@ -195,7 +196,7 @@ DEFER: relayout
|
|||
|
||||
: relayout-1 ( gadget -- )
|
||||
dup gadget-state
|
||||
[ drop ] [ dup invalidate add-invalid ] if ;
|
||||
[ drop ] [ dup invalidate layout-later ] if ;
|
||||
|
||||
: show-gadget t swap set-gadget-visible? ;
|
||||
|
||||
|
|
@ -241,27 +242,70 @@ M: gadget layout* drop ;
|
|||
dup [ layout ] each-child
|
||||
] when drop ;
|
||||
|
||||
: graft-queue \ graft-queue get ;
|
||||
|
||||
: unqueue-graft ( gadget -- )
|
||||
dup graft-queue dlist-delete [ "Not queued" throw ] unless
|
||||
dup gadget-status first { t t } { f f } ?
|
||||
swap set-gadget-status ;
|
||||
|
||||
: queue-graft ( gadget -- )
|
||||
{ f t } over set-gadget-status
|
||||
graft-queue push-front ;
|
||||
|
||||
: queue-ungraft ( gadget -- )
|
||||
{ t f } over set-gadget-status
|
||||
graft-queue push-front ;
|
||||
|
||||
: graft-later ( gadget -- )
|
||||
dup gadget-status {
|
||||
{ { f t } [ drop ] }
|
||||
{ { t t } [ drop ] }
|
||||
{ { t f } [ unqueue-graft ] }
|
||||
{ { f f } [ queue-graft ] }
|
||||
} case ;
|
||||
|
||||
: ungraft-later ( gadget -- )
|
||||
dup gadget-status {
|
||||
{ { f f } [ drop ] }
|
||||
{ { t f } [ drop ] }
|
||||
{ { f t } [ unqueue-graft ] }
|
||||
{ { t t } [ queue-ungraft ] }
|
||||
} case ;
|
||||
|
||||
GENERIC: graft* ( gadget -- )
|
||||
|
||||
M: gadget graft* drop ;
|
||||
|
||||
! : graft ( gadget -- )
|
||||
! dup gadget-grafted? [
|
||||
! drop
|
||||
! ] [
|
||||
! t over set-gadget-grafted?
|
||||
! dup graft*
|
||||
! dup activate-control
|
||||
! [ graft ] each-child
|
||||
! ] if ;
|
||||
|
||||
: graft ( gadget -- )
|
||||
t over set-gadget-grafted?
|
||||
dup graft*
|
||||
dup activate-control
|
||||
[ graft ] each-child ;
|
||||
dup graft-later [ graft ] each-child ;
|
||||
|
||||
GENERIC: ungraft* ( gadget -- )
|
||||
|
||||
M: gadget ungraft* drop ;
|
||||
|
||||
! : ungraft ( gadget -- )
|
||||
! dup gadget-grafted? [
|
||||
! dup [ ungraft ] each-child
|
||||
! dup deactivate-control
|
||||
! dup ungraft*
|
||||
! f swap set-gadget-grafted?
|
||||
! ] [
|
||||
! drop ! "Fuck you" throw
|
||||
! ] if ;
|
||||
|
||||
: ungraft ( gadget -- )
|
||||
dup gadget-grafted? [
|
||||
dup [ ungraft ] each-child
|
||||
dup deactivate-control
|
||||
dup ungraft*
|
||||
f over set-gadget-grafted?
|
||||
] when drop ;
|
||||
dup [ ungraft ] each-child ungraft-later ;
|
||||
|
||||
: (unparent) ( gadget -- )
|
||||
dup ungraft
|
||||
|
|
@ -272,7 +316,14 @@ M: gadget ungraft* drop ;
|
|||
tuck gadget-focus eq?
|
||||
[ f swap set-gadget-focus ] [ drop ] if ;
|
||||
|
||||
SYMBOL: in-layout?
|
||||
|
||||
: not-in-layout
|
||||
in-layout? get
|
||||
[ "Cannot add/remove gadgets in layout*" throw ] when ;
|
||||
|
||||
: unparent ( gadget -- )
|
||||
not-in-layout
|
||||
[
|
||||
dup gadget-parent dup [
|
||||
over (unparent)
|
||||
|
|
@ -290,6 +341,7 @@ M: gadget ungraft* drop ;
|
|||
f swap set-gadget-children ;
|
||||
|
||||
: clear-gadget ( gadget -- )
|
||||
not-in-layout
|
||||
dup (clear-gadget) relayout ;
|
||||
|
||||
: ((add-gadget)) ( gadget box -- )
|
||||
|
|
@ -299,12 +351,14 @@ M: gadget ungraft* drop ;
|
|||
over unparent
|
||||
dup pick set-gadget-parent
|
||||
[ ((add-gadget)) ] 2keep
|
||||
gadget-grafted? [ graft ] [ drop ] if ;
|
||||
gadget-status second [ graft ] [ drop ] if ;
|
||||
|
||||
: add-gadget ( gadget parent -- )
|
||||
not-in-layout
|
||||
[ (add-gadget) ] keep relayout ;
|
||||
|
||||
: add-gadgets ( seq parent -- )
|
||||
not-in-layout
|
||||
swap [ over (add-gadget) ] each relayout ;
|
||||
|
||||
: parents ( gadget -- seq )
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ M: incremental pref-dim*
|
|||
dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
|
||||
|
||||
: add-incremental ( gadget incremental -- )
|
||||
not-in-layout
|
||||
2dup (add-gadget)
|
||||
over prefer-incremental
|
||||
2dup incremental-loc
|
||||
|
|
@ -50,6 +51,7 @@ M: incremental pref-dim*
|
|||
gadget-parent [ invalidate* ] when* ;
|
||||
|
||||
: clear-incremental ( incremental -- )
|
||||
not-in-layout
|
||||
dup (clear-gadget) dup forget-pref-dim
|
||||
{ 0 0 } over set-incremental-cursor
|
||||
gadget-parent [ relayout ] when* ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
IN: temporary
|
||||
USING: alien ui.gadgets.panes ui.gadgets namespaces
|
||||
kernel sequences io io.streams.string tools.test prettyprint
|
||||
definitions help help.syntax help.markup splitting ;
|
||||
definitions help help.syntax help.markup splitting
|
||||
tools.test.ui models ;
|
||||
|
||||
: #children "pane" get gadget-children length ;
|
||||
|
||||
|
|
@ -33,3 +34,7 @@ ARTICLE: "test-article" "This is a test article"
|
|||
|
||||
<pane> [ \ = see ] with-pane
|
||||
<pane> [ \ = help ] with-pane
|
||||
|
||||
[ ] [
|
||||
\ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@ IN: temporary
|
|||
USING: ui.gadgets ui.gadgets.scrollers
|
||||
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 ;
|
||||
ui.gadgets.sliders math math.vectors arrays sequences
|
||||
tools.test.inference tools.test.ui ;
|
||||
|
||||
[ ] [
|
||||
<gadget> "g" set
|
||||
|
|
@ -20,12 +21,14 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
|
|||
[ ] [
|
||||
<gadget> dup "g" set
|
||||
10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
|
||||
<viewport> "v" set
|
||||
<viewport> "v" set
|
||||
] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
|
||||
"v" get [
|
||||
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
|
||||
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
|
||||
] with-grafted-gadget
|
||||
|
||||
[ ] [
|
||||
<gadget> { 100 100 } over set-rect-dim
|
||||
|
|
@ -36,27 +39,25 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
|
|||
|
||||
[ ] [ "s" get layout ] unit-test
|
||||
|
||||
[ ] [ "s" get graft ] unit-test
|
||||
"s" get [
|
||||
[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
|
||||
|
||||
[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
|
||||
[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
|
||||
|
||||
[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
|
||||
[ ] [ { 0 0 } "s" get scroll ] unit-test
|
||||
|
||||
[ ] [ { 0 0 } "s" get scroll ] unit-test
|
||||
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
|
||||
[ { 106 106 } ] [ "s" get gadget-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 scroll ] unit-test
|
||||
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
|
||||
[ { 10 20 } ] [ "s" get scroller-viewport gadget-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
|
||||
|
||||
[ ] [ "s" get ungraft ] unit-test
|
||||
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
|
||||
] with-grafted-gadget
|
||||
|
||||
<gadget> { 600 400 } over set-rect-dim "g1" set
|
||||
<gadget> { 600 10 } over set-rect-dim "g2" set
|
||||
|
|
@ -84,3 +85,5 @@ dup layout
|
|||
[ 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
|
||||
|
||||
{ 1 1 } [ <scroller> ] unit-test-effect
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ scroller H{
|
|||
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: viewport, ( -- )
|
||||
: viewport, ( child -- )
|
||||
g gadget-model <viewport>
|
||||
g-> set-scroller-viewport @center frame, ;
|
||||
|
||||
|
|
@ -106,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* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -131,7 +131,7 @@ M: elevator layout*
|
|||
: slide-by-line ( amount slider -- )
|
||||
[ slider-line * ] keep slide-by ;
|
||||
|
||||
: <slide-button> ( vector polygon amount -- )
|
||||
: <slide-button> ( vector polygon amount -- button )
|
||||
>r gray swap <polygon-gadget> r>
|
||||
[ swap find-slider slide-by-line ] curry <repeat-button>
|
||||
[ set-gadget-orientation ] keep ;
|
||||
|
|
@ -144,7 +144,7 @@ M: elevator layout*
|
|||
: <left-button> { 0 1 } arrow-left -1 <slide-button> ;
|
||||
: <right-button> { 0 1 } arrow-right 1 <slide-button> ;
|
||||
|
||||
: build-x-slider ( slider -- slider )
|
||||
: build-x-slider ( slider -- )
|
||||
[
|
||||
<left-button> @left frame,
|
||||
{ 0 1 } elevator,
|
||||
|
|
@ -154,7 +154,7 @@ M: elevator layout*
|
|||
: <up-button> { 1 0 } arrow-up -1 <slide-button> ;
|
||||
: <down-button> { 1 0 } arrow-down 1 <slide-button> ;
|
||||
|
||||
: build-y-slider ( slider -- slider )
|
||||
: build-y-slider ( slider -- )
|
||||
[
|
||||
<up-button> @top frame,
|
||||
{ 1 0 } elevator,
|
||||
|
|
|
|||
|
|
@ -16,8 +16,7 @@ TUPLE: viewport ;
|
|||
: <viewport> ( content model -- viewport )
|
||||
<gadget> viewport construct-control
|
||||
t over set-gadget-clipped?
|
||||
[ add-gadget ] keep
|
||||
[ model-changed ] keep ;
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
M: viewport layout*
|
||||
dup rect-dim viewport-gap 2 v*n v-
|
||||
|
|
|
|||
|
|
@ -112,12 +112,6 @@ world H{
|
|||
{ T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
|
||||
} set-gestures
|
||||
|
||||
: start-world ( world -- )
|
||||
dup graft
|
||||
dup relayout
|
||||
dup world-title over set-title
|
||||
request-focus ;
|
||||
|
||||
: close-global ( world global -- )
|
||||
dup get-global find-world rot eq?
|
||||
[ f swap set-global ] [ drop ] if ;
|
||||
|
|
@ -126,3 +120,8 @@ world H{
|
|||
drop-prefix <reversed>
|
||||
T{ lose-focus } swap each-gesture
|
||||
T{ gain-focus } swap each-gesture ;
|
||||
|
||||
M: world graft*
|
||||
dup (open-world-window)
|
||||
dup world-title over set-title
|
||||
request-focus ;
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@ HELP: gadget
|
|||
{ { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
|
||||
{ { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
|
||||
{ { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
|
||||
{ { $link gadget-grafted? } " - if set to " { $link t } ", the gadget is parented in a native window." }
|
||||
{ { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
|
||||
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
|
||||
{ { $link gadget-model } " - XXX" }
|
||||
}
|
||||
"Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
|
||||
{ $notes
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
IN: temporary
|
||||
USING: tools.test tools.test.ui ui.tools.browser
|
||||
tools.test.inference ;
|
||||
|
||||
{ 0 1 } [ <browser-gadget> ] unit-test-effect
|
||||
[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
|
||||
|
|
@ -1,35 +1,39 @@
|
|||
USING: continuations documents ui.tools.interactor
|
||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
||||
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.panes vocabs words ;
|
||||
ui.gadgets.panes vocabs words tools.test.ui ;
|
||||
IN: temporary
|
||||
|
||||
timers [ init-timers ] unless
|
||||
|
||||
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
||||
|
||||
<listener-gadget> "listener" set
|
||||
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
|
||||
|
||||
{ "kernel" } [ vocab-words ] map use associate
|
||||
"listener" get listener-gadget-input set-interactor-vars
|
||||
[ ] [ <listener-gadget> "listener" set ] unit-test
|
||||
|
||||
[ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
|
||||
"listener" get [
|
||||
{ "kernel" } [ vocab-words ] map use associate
|
||||
"listener" get listener-gadget-input set-interactor-vars
|
||||
|
||||
[ "USE: words word-name" ]
|
||||
[ \ word-name "listener" get word-completion-string ] unit-test
|
||||
[ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
|
||||
|
||||
<pane> <interactor> "i" set
|
||||
H{ } "i" get set-interactor-vars
|
||||
[ "USE: words word-name" ]
|
||||
[ \ word-name "listener" get word-completion-string ] unit-test
|
||||
|
||||
[ t ] [ "i" get interactor? ] unit-test
|
||||
<pane> <interactor> "i" set
|
||||
H{ } "i" get set-interactor-vars
|
||||
|
||||
[ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
|
||||
[ t ] [ "i" get interactor? ] unit-test
|
||||
|
||||
[ ] [
|
||||
"i" get [ "SYMBOL:" parse ] catch go-to-error
|
||||
] unit-test
|
||||
[ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"i" get gadget-model doc-end
|
||||
"i" get editor-caret* =
|
||||
] unit-test
|
||||
[ ] [
|
||||
"i" get [ "SYMBOL:" parse ] catch go-to-error
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"i" get gadget-model doc-end
|
||||
"i" get editor-caret* =
|
||||
] unit-test
|
||||
] with-grafted-gadget
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: assocs ui.tools.search help.topics io.files io.styles
|
||||
kernel namespaces sequences source-files threads timers
|
||||
tools.test ui.gadgets ui.gestures vocabs
|
||||
vocabs.loader words ;
|
||||
vocabs.loader words tools.test.ui debugger ;
|
||||
IN: temporary
|
||||
|
||||
timers get [ init-timers ] unless
|
||||
|
|
@ -12,12 +12,16 @@ timers get [ init-timers ] unless
|
|||
T{ key-down f { C+ } "x" } swap search-gesture
|
||||
] unit-test
|
||||
|
||||
: assert-non-empty empty? f assert= ;
|
||||
|
||||
: update-live-search ( search -- seq )
|
||||
dup [
|
||||
300 sleep do-timers
|
||||
live-search-list control-value
|
||||
] with-grafted-gadget ;
|
||||
|
||||
: test-live-search ( gadget quot -- ? )
|
||||
>r dup graft 300 sleep do-timers
|
||||
dup live-search-list control-value
|
||||
dup empty? [ "Empty" throw ] when
|
||||
r> all?
|
||||
>r ungraft r> ;
|
||||
>r update-live-search dup assert-non-empty r> all? ;
|
||||
|
||||
[ t ] [
|
||||
"swp" all-words f <definition-search>
|
||||
|
|
@ -26,11 +30,12 @@ timers get [ init-timers ] unless
|
|||
|
||||
[ t ] [
|
||||
"" all-words t <definition-search>
|
||||
dup graft
|
||||
{ "set-word-prop" } over live-search-field set-control-value
|
||||
300 sleep
|
||||
do-timers
|
||||
search-value \ set-word-prop eq?
|
||||
dup [
|
||||
{ "set-word-prop" } over live-search-field set-control-value
|
||||
300 sleep
|
||||
do-timers
|
||||
search-value \ set-word-prop eq?
|
||||
] with-grafted-gadget
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -2,14 +2,14 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
|
|||
ui.tools.search ui.tools.workspace kernel models namespaces
|
||||
sequences timers tools.test ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.labelled ui.gadgets.presentations
|
||||
ui.gadgets.scrollers vocabs ;
|
||||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||
IN: temporary
|
||||
|
||||
[
|
||||
[ f ] [
|
||||
0 <model> <gadget> [ set-gadget-model ] keep gadget set
|
||||
<workspace-tabs> gadget-children empty?
|
||||
] unit-test
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
||||
timers get [ init-timers ] unless
|
||||
|
|
@ -31,24 +31,29 @@ timers get [ init-timers ] unless
|
|||
"w" get hide-popup
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<workspace> "w" set
|
||||
"w" get graft
|
||||
"w" get "kernel" vocab show-vocab-words
|
||||
] unit-test
|
||||
[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
|
||||
|
||||
"w" get workspace-popup closable-gadget-content
|
||||
live-search-list gadget-child "p" set
|
||||
"w" get [
|
||||
|
||||
[ t ] [ "p" get presentation? ] unit-test
|
||||
[ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
|
||||
|
||||
"p" get <operations-menu> gadget-child gadget-child "c" set
|
||||
[ ] [ notify-queued ] unit-test
|
||||
|
||||
[ t ] [ "c" get button? ] unit-test
|
||||
[ ] [ "w" get workspace-popup closable-gadget-content
|
||||
live-search-list gadget-child "p" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
"w" get workspace-listener listener-gadget-input
|
||||
3 handle-parse-error
|
||||
] unit-test
|
||||
[ t ] [ "p" get presentation? ] unit-test
|
||||
|
||||
[ ] [ "w" get ungraft ] unit-test
|
||||
[ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
|
||||
|
||||
[ ] [ notify-queued ] unit-test
|
||||
|
||||
[ t ] [ "c" get button? ] unit-test
|
||||
|
||||
[ ] [
|
||||
"w" get workspace-listener listener-gadget-input
|
||||
3 handle-parse-error
|
||||
] unit-test
|
||||
|
||||
[ ] [ notify-queued ] unit-test
|
||||
] with-grafted-gadget
|
||||
|
|
|
|||
|
|
@ -12,15 +12,6 @@ vocabs.loader tools.test ui.gadgets.buttons
|
|||
ui.gadgets.status-bar mirrors ;
|
||||
IN: ui.tools
|
||||
|
||||
: workspace-tabs ( -- seq )
|
||||
{
|
||||
<stack-display>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<walker>
|
||||
<profiler-gadget>
|
||||
} ;
|
||||
|
||||
: <workspace-tabs> ( -- tabs )
|
||||
g gadget-model
|
||||
"tool-switching" workspace command-map
|
||||
|
|
@ -28,7 +19,13 @@ IN: ui.tools
|
|||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( -- gadget )
|
||||
workspace-tabs [ execute ] map g gadget-model <book> ;
|
||||
[
|
||||
<stack-display> ,
|
||||
<browser-gadget> ,
|
||||
<inspector-gadget> ,
|
||||
<walker> ,
|
||||
<profiler-gadget> ,
|
||||
] { } make g gadget-model <book> ;
|
||||
|
||||
: <workspace> ( -- workspace )
|
||||
0 <model> { 0 1 } <track> workspace construct-control [
|
||||
|
|
|
|||
|
|
@ -5,15 +5,15 @@ ui.commands ui.gadgets ui.gadgets.labelled
|
|||
ui.gadgets.tracks ui.gestures ;
|
||||
IN: ui.tools.traceback
|
||||
|
||||
: <callstack-display> ( model -- )
|
||||
: <callstack-display> ( model -- gadget )
|
||||
[ [ continuation-call callstack. ] when* ]
|
||||
"Call stack" <labelled-pane> ;
|
||||
|
||||
: <datastack-display> ( model -- )
|
||||
: <datastack-display> ( model -- gadget )
|
||||
[ [ continuation-data stack. ] when* ]
|
||||
"Data stack" <labelled-pane> ;
|
||||
|
||||
: <retainstack-display> ( model -- )
|
||||
: <retainstack-display> ( model -- gadget )
|
||||
[ [ continuation-retain stack. ] when* ]
|
||||
"Retain stack" <labelled-pane> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
IN: temporary
|
||||
USING: tools.test tools.test.inference ui.tools ;
|
||||
|
||||
{ 0 1 } [ <workspace> ] unit-test-effect
|
||||
|
|
@ -18,11 +18,6 @@ HELP: find-window
|
|||
{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
|
||||
{ $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
|
||||
|
||||
HELP: start-world
|
||||
{ $values { "world" world } }
|
||||
{ $description "Starts a world." }
|
||||
{ $notes "This word should be called by the UI backend after " { $link register-window } ", but before making the world's containing window visible on the screen." } ;
|
||||
|
||||
HELP: register-window
|
||||
{ $values { "world" world } { "handle" "a baackend-specific handle" } }
|
||||
{ $description "Adds a window to the global " { $link windows } " variable." }
|
||||
|
|
@ -174,7 +169,6 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
|
|||
{ $subsection open-world-window }
|
||||
"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
|
||||
{ $subsection register-window }
|
||||
{ $subsection start-world }
|
||||
"The following words must also be implemented:"
|
||||
{ $subsection set-title }
|
||||
{ $subsection raise-window }
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays assocs io kernel math models namespaces
|
||||
prettyprint dlists sequences threads sequences words timers
|
||||
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
|
||||
ui.gestures ui.backend ui.render continuations init ;
|
||||
ui.gestures ui.backend ui.render continuations init
|
||||
combinators ;
|
||||
IN: ui
|
||||
|
||||
! Assoc mapping aliens to gadgets
|
||||
|
|
@ -53,25 +54,23 @@ SYMBOL: windows
|
|||
reset-world ;
|
||||
|
||||
: open-world-window ( world -- )
|
||||
dup pref-dim over set-gadget-dim
|
||||
dup (open-world-window)
|
||||
draw-world ;
|
||||
dup pref-dim over set-gadget-dim dup relayout graft ;
|
||||
|
||||
: open-window ( gadget title -- )
|
||||
>r [ 1 track, ] { 0 1 } make-track r>
|
||||
f <world> open-world-window ;
|
||||
|
||||
: find-window ( quot -- world )
|
||||
windows get 1 <column>
|
||||
windows get values
|
||||
[ gadget-child swap call ] curry* find-last nip ; inline
|
||||
|
||||
: restore-windows ( -- )
|
||||
windows get [ 1 <column> >array ] keep delete-all
|
||||
windows get [ values ] keep delete-all
|
||||
[ dup reset-world (open-world-window) ] each
|
||||
forget-rollover ;
|
||||
|
||||
: restore-windows? ( -- ? )
|
||||
windows get [ empty? not ] [ f ] if* ;
|
||||
windows get empty? not ;
|
||||
|
||||
: update-hand ( world -- )
|
||||
dup hand-world get-global eq?
|
||||
|
|
@ -79,7 +78,8 @@ SYMBOL: windows
|
|||
|
||||
: layout-queued ( -- seq )
|
||||
[
|
||||
invalid [
|
||||
in-layout? on
|
||||
layout-queue [
|
||||
dup layout find-world [ , ] when*
|
||||
] dlist-slurp
|
||||
] { } make ;
|
||||
|
|
@ -87,24 +87,40 @@ SYMBOL: windows
|
|||
SYMBOL: ui-hook
|
||||
|
||||
: init-ui ( -- )
|
||||
<dlist> \ invalid set-global
|
||||
<dlist> \ graft-queue set-global
|
||||
<dlist> \ layout-queue set-global
|
||||
V{ } clone windows set-global ;
|
||||
|
||||
: redraw-worlds ( seq -- )
|
||||
[ dup update-hand draw-world ] each ;
|
||||
|
||||
: notify ( gadget -- )
|
||||
dup gadget-status {
|
||||
{ { f t } [ dup activate-control dup graft* ] }
|
||||
{ { t f } [ dup activate-control dup ungraft* ] }
|
||||
} case
|
||||
dup gadget-status first { f f } { t t } ?
|
||||
swap set-gadget-status ;
|
||||
|
||||
: notify-queued ( -- )
|
||||
graft-queue [ notify ] dlist-slurp ;
|
||||
|
||||
: ui-step ( -- )
|
||||
[
|
||||
do-timers
|
||||
notify-queued
|
||||
layout-queued
|
||||
redraw-worlds
|
||||
10 sleep
|
||||
] assert-depth ;
|
||||
|
||||
: start-ui ( -- )
|
||||
init-timers
|
||||
restore-windows? [
|
||||
restore-windows
|
||||
] [
|
||||
init-ui ui-hook get call
|
||||
] if ;
|
||||
|
||||
: redraw-worlds ( seq -- )
|
||||
[ dup update-hand draw-world ] each ;
|
||||
|
||||
: ui-step ( -- )
|
||||
[
|
||||
do-timers layout-queued redraw-worlds 10 sleep
|
||||
] assert-depth ;
|
||||
] if ui-step ;
|
||||
|
||||
: ui-running ( quot -- )
|
||||
t \ ui-running set-global
|
||||
|
|
|
|||
|
|
@ -340,17 +340,23 @@ SYMBOL: hWnd
|
|||
] ui-try
|
||||
] alien-callback ;
|
||||
|
||||
: do-events ( -- )
|
||||
msg-obj get f 0 0 PM_REMOVE PeekMessage
|
||||
zero? not [
|
||||
msg-obj get MSG-message WM_QUIT = [
|
||||
msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop
|
||||
] unless
|
||||
] when ;
|
||||
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
|
||||
|
||||
: do-events ( msg -- )
|
||||
{
|
||||
{ [ windows get empty? ] [ drop ] }
|
||||
{ [ dup peek-message? ] [ >r [ ui-step ] ui-try r> do-events ] }
|
||||
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
|
||||
{ [ t ] [
|
||||
dup TranslateMessage drop
|
||||
dup DispatchMessage drop
|
||||
do-events
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
: event-loop ( -- )
|
||||
windows get empty? [
|
||||
[ do-events ui-step ] ui-try event-loop
|
||||
msg-obj get do-events
|
||||
] unless ;
|
||||
|
||||
: register-wndclassex ( -- class )
|
||||
|
|
@ -414,8 +420,8 @@ M: windows-ui-backend (open-world-window) ( world -- )
|
|||
[ rect-dim first2 create-window dup setup-gl ] keep
|
||||
[ f <win> ] keep
|
||||
[ swap win-hWnd register-window ] 2keep
|
||||
[ set-world-handle ] 2keep
|
||||
start-world win-hWnd show-window ;
|
||||
dupd set-world-handle
|
||||
win-hWnd show-window ;
|
||||
|
||||
M: windows-ui-backend select-gl-context ( handle -- )
|
||||
[ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
|
||||
|
|
|
|||
|
|
@ -224,7 +224,6 @@ M: x11-ui-backend set-title ( string world -- )
|
|||
|
||||
M: x11-ui-backend (open-world-window) ( world -- )
|
||||
dup gadget-window
|
||||
dup start-world
|
||||
world-handle x11-handle-window dup set-closable map-window ;
|
||||
|
||||
M: x11-ui-backend raise-window ( world -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue