diff --git a/extra/tools/test/ui/ui.factor b/extra/tools/test/ui/ui.factor new file mode 100755 index 0000000000..0376e7f4c7 --- /dev/null +++ b/extra/tools/test/ui/ui.factor @@ -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 -- ) + [ + \ graft-queue [ + over + graft notify-queued + swap slip + ungraft notify-queued + ] with-variable + ] string-out print ; diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor old mode 100644 new mode 100755 index c7a4b62abb..52722a2fab --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -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: ; diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index b8cf5892eb..8565098e70 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -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 } "t" set } "religion" set ] unit-test +{ 2 1 } [ ] unit-test-effect + +{ 2 1 } [ ] unit-test-effect + +{ 2 1 } [ ] unit-test-effect + [ 0 ] [ "religion" get gadget-child radio-control-value ] unit-test diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor old mode 100644 new mode 100755 index daaeac6fad..b7ddc8359c --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -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" set @@ -36,3 +37,5 @@ ui.gadgets.grids prettyprint documents ui.gestures ; "editor" get position-caret "editor" get ungraft* ] unit-test + +{ 0 1 } [ ] unit-test-effect diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 9e2a258c0f..2221cb2bfd 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -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+ over scroll>rect ] when drop ; diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor old mode 100644 new mode 100755 index 2a4527fbf2..a5a5b36a1b --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -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 "a" get "b" get add-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 { 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 ; + +: + 0 0 mock-gadget construct-boa 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... +[ + \ graft-queue [ + [ ] [ dup queue-graft unqueue-graft ] unit-test + [ t ] [ graft-queue dlist-empty? ] unit-test + ] with-variable + + \ graft-queue [ + [ t ] [ graft-queue dlist-empty? ] unit-test + + "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 [ + over 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 + \ graft-queue [ + "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 } [ ] 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 diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 526c4864c8..ed5c4b935b 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -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 ; : ( -- rect ) { 0 0 } dup ; : ( -- gadget ) - { 0 1 } t { + { 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 ) diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor old mode 100644 new mode 100755 index 0e15515750..5f213bc31a --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -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* ; diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor old mode 100644 new mode 100755 index f9663d8249..248de5e889 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -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" [ \ = see ] with-pane [ \ = help ] with-pane + +[ ] [ + \ = [ see ] [ ] with-grafted-gadget +] unit-test diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 8b11c4f8a2..a53cf1fb0e 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -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 ; [ ] [ "g" set @@ -20,12 +21,14 @@ ui.gadgets.sliders math math.vectors arrays sequences ; [ ] [ dup "g" set 10 1 0 100 20 1 0 100 2array - "v" set + "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 [ ] [ { 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 { 600 400 } over set-rect-dim "g1" set { 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 } [ ] unit-test-effect diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index b6c3f263cd..83f8edc70e 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -28,7 +28,7 @@ scroller H{ { T{ mouse-scroll } [ do-mouse-scroll ] } } set-gestures -: viewport, ( -- ) +: viewport, ( child -- ) g gadget-model 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* ; diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index 4c558ad8c9..0d5c587a54 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -131,7 +131,7 @@ M: elevator layout* : slide-by-line ( amount slider -- ) [ slider-line * ] keep slide-by ; -: ( vector polygon amount -- ) +: ( vector polygon amount -- button ) >r gray swap r> [ swap find-slider slide-by-line ] curry [ set-gadget-orientation ] keep ; @@ -144,7 +144,7 @@ M: elevator layout* : { 0 1 } arrow-left -1 ; : { 0 1 } arrow-right 1 ; -: build-x-slider ( slider -- slider ) +: build-x-slider ( slider -- ) [ @left frame, { 0 1 } elevator, @@ -154,7 +154,7 @@ M: elevator layout* : { 1 0 } arrow-up -1 ; : { 1 0 } arrow-down 1 ; -: build-y-slider ( slider -- slider ) +: build-y-slider ( slider -- ) [ @top frame, { 1 0 } elevator, diff --git a/extra/ui/gadgets/viewports/viewports.factor b/extra/ui/gadgets/viewports/viewports.factor index b5dc2da337..e879f32a02 100755 --- a/extra/ui/gadgets/viewports/viewports.factor +++ b/extra/ui/gadgets/viewports/viewports.factor @@ -16,8 +16,7 @@ TUPLE: viewport ; : ( content model -- viewport ) 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- diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor old mode 100644 new mode 100755 index 2f5a5a17e9..fc0e78a61c --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -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 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 ; diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor old mode 100644 new mode 100755 index b0479c7c29..3c5ad22e30 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -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 diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor new file mode 100755 index 0000000000..5a343919e7 --- /dev/null +++ b/extra/ui/tools/browser/browser-tests.factor @@ -0,0 +1,6 @@ +IN: temporary +USING: tools.test tools.test.ui ui.tools.browser +tools.test.inference ; + +{ 0 1 } [ ] unit-test-effect +[ ] [ [ ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 5c1335ce9a..4e59fd63ee 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -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" set +[ ] [ [ ] with-grafted-gadget ] unit-test -{ "kernel" } [ vocab-words ] map use associate -"listener" get listener-gadget-input set-interactor-vars +[ ] [ "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 - "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 + "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 diff --git a/extra/ui/tools/search/search-tests.factor b/extra/ui/tools/search/search-tests.factor index fe3203b57e..47ae786f59 100755 --- a/extra/ui/tools/search/search-tests.factor +++ b/extra/ui/tools/search/search-tests.factor @@ -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 @@ -26,11 +30,12 @@ timers get [ init-timers ] unless [ t ] [ "" all-words t - 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 ] [ diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 8333392659..919d1705af 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -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 [ set-gadget-model ] keep gadget set 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 -[ ] [ - "w" set - "w" get graft - "w" get "kernel" vocab show-vocab-words -] unit-test +[ ] [ [ ] 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 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 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 diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 9a9a155236..3b161c1d28 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -12,15 +12,6 @@ vocabs.loader tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ; IN: ui.tools -: workspace-tabs ( -- seq ) - { - - - - - - } ; - : ( -- tabs ) g gadget-model "tool-switching" workspace command-map @@ -28,7 +19,13 @@ IN: ui.tools ; : ( -- gadget ) - workspace-tabs [ execute ] map g gadget-model ; + [ + , + , + , + , + , + ] { } make g gadget-model ; : ( -- workspace ) 0 { 0 1 } workspace construct-control [ diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor index 9979dd2df2..2a7dfe654c 100755 --- a/extra/ui/tools/traceback/traceback.factor +++ b/extra/ui/tools/traceback/traceback.factor @@ -5,15 +5,15 @@ ui.commands ui.gadgets ui.gadgets.labelled ui.gadgets.tracks ui.gestures ; IN: ui.tools.traceback -: ( model -- ) +: ( model -- gadget ) [ [ continuation-call callstack. ] when* ] "Call stack" ; -: ( model -- ) +: ( model -- gadget ) [ [ continuation-data stack. ] when* ] "Data stack" ; -: ( model -- ) +: ( model -- gadget ) [ [ continuation-retain stack. ] when* ] "Retain stack" ; diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor new file mode 100755 index 0000000000..957f38ca26 --- /dev/null +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: tools.test tools.test.inference ui.tools ; + +{ 0 1 } [ ] unit-test-effect diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor old mode 100644 new mode 100755 index e9e3a05d62..231682ce6e --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -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 } diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor old mode 100644 new mode 100755 index fc5777ab6a..810ccacf80 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -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 open-world-window ; : find-window ( quot -- world ) - windows get 1 + windows get values [ gadget-child swap call ] curry* find-last nip ; inline : restore-windows ( -- ) - windows get [ 1 >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 ( -- ) - \ invalid set-global + \ graft-queue set-global + \ 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 diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 6b19085a1c..7c1b578981 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -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 ] 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 ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor old mode 100644 new mode 100755 index fe0f1fa9eb..165989d86a --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -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 -- )