UI fixes
parent
9d7b1ac4dc
commit
d6cf56162f
|
@ -128,7 +128,7 @@ M: editor model-changed
|
|||
line-height 0 swap 2array ;
|
||||
|
||||
: scroll>caret ( editor -- )
|
||||
dup gadget-status second [
|
||||
dup gadget-graft-state second [
|
||||
dup caret-loc over caret-dim { 1 0 } v+ <rect>
|
||||
over scroll>rect
|
||||
] when drop ;
|
||||
|
|
|
@ -139,24 +139,24 @@ M: mock-gadget ungraft*
|
|||
<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
|
||||
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
|
||||
[ ] [ "g" get graft-later ] unit-test
|
||||
[ { f t } ] [ "g" get gadget-status ] unit-test
|
||||
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
|
||||
[ ] [ "g" get ungraft-later ] unit-test
|
||||
[ { f f } ] [ "g" get gadget-status ] unit-test
|
||||
[ { f f } ] [ "g" get gadget-graft-state ] 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 t } ] [ "g" get gadget-graft-state ] 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
|
||||
[ { t f } ] [ "g" get gadget-graft-state ] unit-test
|
||||
[ ] [ notify-queued ] unit-test
|
||||
[ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
|
||||
[ { f f } ] [ "g" get gadget-status ] unit-test
|
||||
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
|
||||
] with-variable
|
||||
|
||||
: add-some-children
|
||||
|
@ -167,7 +167,7 @@ M: mock-gadget ungraft*
|
|||
] each ;
|
||||
|
||||
: status-flags
|
||||
{ "g" "1" "2" "3" } [ get gadget-status ] map prune ;
|
||||
{ "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
|
||||
|
||||
: notify-combo ( ? ? -- )
|
||||
nl "===== Combo: " write 2dup 2array . nl
|
||||
|
@ -182,9 +182,9 @@ M: mock-gadget ungraft*
|
|||
[ [ 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
|
||||
[ { f t } ] [ "1" get gadget-graft-state ] unit-test
|
||||
[ { f t } ] [ "2" get gadget-graft-state ] unit-test
|
||||
[ { f t } ] [ "3" get gadget-graft-state ] unit-test
|
||||
[ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
|
||||
[ ] [ notify-queued ] unit-test
|
||||
[ V{ { t t } } ] [ status-flags ] unit-test
|
||||
|
|
|
@ -41,8 +41,8 @@ M: array rect-dim drop { 0 0 } ;
|
|||
(rect-union) <extent-rect> ;
|
||||
|
||||
TUPLE: gadget
|
||||
pref-dim parent children orientation state focus
|
||||
visible? root? clipped? status
|
||||
pref-dim parent children orientation focus
|
||||
visible? root? clipped? layout-state graft-state
|
||||
interior boundary
|
||||
model ;
|
||||
|
||||
|
@ -63,7 +63,7 @@ M: gadget model-changed drop ;
|
|||
set-delegate
|
||||
set-gadget-orientation
|
||||
set-gadget-visible?
|
||||
set-gadget-status
|
||||
set-gadget-graft-state
|
||||
} gadget construct ;
|
||||
|
||||
: construct-gadget ( class -- tuple )
|
||||
|
@ -170,7 +170,7 @@ M: array gadget-text*
|
|||
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
|
||||
|
||||
: invalidate ( gadget -- )
|
||||
\ invalidate swap set-gadget-state ;
|
||||
\ invalidate swap set-gadget-layout-state ;
|
||||
|
||||
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
|
||||
|
||||
|
@ -185,17 +185,17 @@ M: array gadget-text*
|
|||
DEFER: relayout
|
||||
|
||||
: invalidate* ( gadget -- )
|
||||
\ invalidate* over set-gadget-state
|
||||
\ invalidate* over set-gadget-layout-state
|
||||
dup forget-pref-dim
|
||||
dup gadget-root?
|
||||
[ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
|
||||
|
||||
: relayout ( gadget -- )
|
||||
dup gadget-state \ invalidate* eq?
|
||||
dup gadget-layout-state \ invalidate* eq?
|
||||
[ drop ] [ invalidate* ] if ;
|
||||
|
||||
: relayout-1 ( gadget -- )
|
||||
dup gadget-state
|
||||
dup gadget-layout-state
|
||||
[ drop ] [ dup invalidate layout-later ] if ;
|
||||
|
||||
: show-gadget t swap set-gadget-visible? ;
|
||||
|
@ -216,7 +216,8 @@ DEFER: relayout
|
|||
GENERIC: pref-dim* ( gadget -- dim )
|
||||
|
||||
: ?set-gadget-pref-dim ( dim gadget -- )
|
||||
dup gadget-state [ 2drop ] [ set-gadget-pref-dim ] if ;
|
||||
dup gadget-layout-state
|
||||
[ 2drop ] [ set-gadget-pref-dim ] if ;
|
||||
|
||||
: pref-dim ( gadget -- dim )
|
||||
dup gadget-pref-dim [ ] [
|
||||
|
@ -233,10 +234,10 @@ M: gadget layout* drop ;
|
|||
|
||||
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
|
||||
|
||||
: validate ( gadget -- ) f swap set-gadget-state ;
|
||||
: validate ( gadget -- ) f swap set-gadget-layout-state ;
|
||||
|
||||
: layout ( gadget -- )
|
||||
dup gadget-state [
|
||||
dup gadget-layout-state [
|
||||
dup validate
|
||||
dup layout*
|
||||
dup [ layout ] each-child
|
||||
|
@ -246,19 +247,19 @@ M: gadget layout* drop ;
|
|||
|
||||
: unqueue-graft ( gadget -- )
|
||||
dup graft-queue dlist-delete [ "Not queued" throw ] unless
|
||||
dup gadget-status first { t t } { f f } ?
|
||||
swap set-gadget-status ;
|
||||
dup gadget-graft-state first { t t } { f f } ?
|
||||
swap set-gadget-graft-state ;
|
||||
|
||||
: queue-graft ( gadget -- )
|
||||
{ f t } over set-gadget-status
|
||||
{ f t } over set-gadget-graft-state
|
||||
graft-queue push-front ;
|
||||
|
||||
: queue-ungraft ( gadget -- )
|
||||
{ t f } over set-gadget-status
|
||||
{ t f } over set-gadget-graft-state
|
||||
graft-queue push-front ;
|
||||
|
||||
: graft-later ( gadget -- )
|
||||
dup gadget-status {
|
||||
dup gadget-graft-state {
|
||||
{ { f t } [ drop ] }
|
||||
{ { t t } [ drop ] }
|
||||
{ { t f } [ unqueue-graft ] }
|
||||
|
@ -266,7 +267,7 @@ M: gadget layout* drop ;
|
|||
} case ;
|
||||
|
||||
: ungraft-later ( gadget -- )
|
||||
dup gadget-status {
|
||||
dup gadget-graft-state {
|
||||
{ { f f } [ drop ] }
|
||||
{ { t f } [ drop ] }
|
||||
{ { f t } [ unqueue-graft ] }
|
||||
|
@ -277,16 +278,6 @@ 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 -- )
|
||||
dup graft-later [ graft ] each-child ;
|
||||
|
||||
|
@ -294,16 +285,6 @@ 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 [ ungraft ] each-child ungraft-later ;
|
||||
|
||||
|
@ -351,7 +332,7 @@ SYMBOL: in-layout?
|
|||
over unparent
|
||||
dup pick set-gadget-parent
|
||||
[ ((add-gadget)) ] 2keep
|
||||
gadget-status second [ graft ] [ drop ] if ;
|
||||
gadget-graft-state second [ graft ] [ drop ] if ;
|
||||
|
||||
: add-gadget ( gadget parent -- )
|
||||
not-in-layout
|
||||
|
|
|
@ -21,7 +21,7 @@ TUPLE: incremental cursor ;
|
|||
dup delegate pref-dim over set-incremental-cursor ;
|
||||
|
||||
M: incremental pref-dim*
|
||||
dup gadget-state [
|
||||
dup gadget-layout-state [
|
||||
dup delegate pref-dim over set-incremental-cursor
|
||||
] when incremental-cursor ;
|
||||
|
||||
|
|
|
@ -9,7 +9,7 @@ HELP: gadget
|
|||
{ { $link gadget-parent } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
|
||||
{ { $link gadget-children } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
|
||||
{ { $link gadget-orientation } " - an orientation specifier. This slot is used by layout gadgets." }
|
||||
{ { $link gadget-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
|
||||
{ { $link gadget-layout-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
|
||||
{ { $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." }
|
||||
|
|
|
@ -95,12 +95,12 @@ SYMBOL: ui-hook
|
|||
[ dup update-hand draw-world ] each ;
|
||||
|
||||
: notify ( gadget -- )
|
||||
dup gadget-status {
|
||||
dup gadget-graft-state {
|
||||
{ { 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 ;
|
||||
dup gadget-graft-state first { f f } { t t } ?
|
||||
swap set-gadget-graft-state ;
|
||||
|
||||
: notify-queued ( -- )
|
||||
graft-queue [ notify ] dlist-slurp ;
|
||||
|
|
|
@ -342,23 +342,18 @@ SYMBOL: hWnd
|
|||
|
||||
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
|
||||
|
||||
: do-events ( msg -- )
|
||||
: event-loop ( msg -- )
|
||||
{
|
||||
{ [ windows get empty? ] [ drop ] }
|
||||
{ [ dup peek-message? ] [ >r [ ui-step ] ui-try r> do-events ] }
|
||||
{ [ dup peek-message? ] [ >r [ ui-step ] ui-try r> event-loop ] }
|
||||
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
|
||||
{ [ t ] [
|
||||
dup TranslateMessage drop
|
||||
dup DispatchMessage drop
|
||||
do-events
|
||||
event-loop
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
: event-loop ( -- )
|
||||
windows get empty? [
|
||||
msg-obj get do-events
|
||||
] unless ;
|
||||
|
||||
: register-wndclassex ( -- class )
|
||||
"WNDCLASSEX" <c-object>
|
||||
f GetModuleHandle
|
||||
|
@ -448,7 +443,7 @@ M: windows-ui-backend ui
|
|||
init-clipboard
|
||||
init-win32-ui
|
||||
start-ui
|
||||
event-loop
|
||||
msg-obj get event-loop
|
||||
] [ cleanup-win32-ui ] [ ] cleanup
|
||||
] ui-running ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue