diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor index 4896bc5e5e..96cf755f4f 100644 --- a/basis/ui/gadgets/gadgets-docs.factor +++ b/basis/ui/gadgets/gadgets-docs.factor @@ -149,6 +149,10 @@ HELP: parents { $values { "gadget" gadget } { "seq" "a sequence of gadgets" } } { $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ; +HELP: child? +{ $values { "parent" gadget } { "child" gadget } { "?" boolean } } +{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ; + HELP: each-parent { $values { "gadget" gadget } { "quot" { $quotation ( gadget -- ? ) } } { "?" boolean } } { $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ; @@ -157,14 +161,6 @@ HELP: find-parent { $values { "gadget" gadget } { "quot" { $quotation ( gadget -- ? ) } } { "parent" gadget } } { $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ; -HELP: screen-loc -{ $values { "gadget" gadget } { "loc" "a pair of integers" } } -{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ; - -HELP: child? -{ $values { "parent" gadget } { "child" gadget } { "?" boolean } } -{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ; - HELP: focusable-child* { $values { "gadget" gadget } { "child/t" "a " { $link gadget } " or " { $link t } } } { $description "Outputs the child of the gadget which would prefer to receive keyboard focus, or " { $link t } " if the gadget itself should receive focus." } @@ -176,6 +172,14 @@ HELP: focusable-child { control-value set-control-value } related-words +HELP: layout-later +{ $values { "gadget" gadget } } +{ $description "Adds the gadget to the " { $link layout-queue } " and notifies the UI thread that there is a gadget to layout. If the length of the queue is larger than " { $link layout-queue-limit } ", then the current thread is yielded so that the UI thread has a chance to run." } ; + +HELP: screen-loc +{ $values { "gadget" gadget } { "loc" "a pair of integers" } } +{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ; + HELP: set-control-value { $values { "value" object } { "control" gadget } } { $description "Sets the value of the control's model." } ; diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 1b3fc4c19e..9b5da69c71 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -1,7 +1,7 @@ -USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds -tools.test namespaces models kernel dlists deques math -math.parser ui sequences hashtables assocs io arrays prettyprint -io.streams.string math.rectangles ui.gadgets.private sets generic ; +USING: accessors arrays assocs concurrency.flags deques dlists io +io.streams.string kernel math math.parser math.rectangles models +namespaces prettyprint sequences sets threads tools.test ui ui.gadgets +ui.gadgets.private ; IN: ui.gadgets.tests { { 300 300 } } @@ -151,3 +151,18 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] with-string-writer print + +: fake-ui-loop ( -- ) + ui-notify-flag get-global lower-flag ; + +ui-running? [ + { f } [ + ! Initially lowered + \ layout-queue set-global + ui-notify-flag set-global + + [ fake-ui-loop ] "Fake UI" spawn drop + 8001 iota [ layout-later ] each + ui-notify-flag get-global value>> + ] unit-test +] unless diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 8395f85e9d..2a9aa1c2f9 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables kernel math namespaces -make sequences quotations math.vectors combinators sorting -binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry locals ; +USING: accessors arrays binary-search combinators concurrency.flags +deques dlists fry kernel locals make math math.order math.rectangles +math.vectors models namespaces sequences threads vectors ; IN: ui.gadgets ! Values for orientation slot @@ -137,13 +136,17 @@ SYMBOL: ui-notify-flag : forget-pref-dim ( gadget -- ) f >>pref-dim drop ; -: layout-queue ( -- queue ) \ layout-queue get ; +: layout-queue ( -- queue ) + \ layout-queue get ; + +CONSTANT: layout-queue-limit 8000 : layout-later ( gadget -- ) - ! When unit testing gadgets without the UI running, the - ! invalid queue is not initialized and we simply ignore - ! invalidation requests. - layout-queue [ push-front notify-ui-thread ] [ drop ] if* ; + layout-queue [ + [ push-back notify-ui-thread ] [ drop ] if* + ] [ + dlist-length layout-queue-limit > [ yield ] when + ] bi ; : invalidate* ( gadget -- ) \ invalidate* >>layout-state