56 lines
1.9 KiB
Factor
56 lines
1.9 KiB
Factor
! Copyright (C) 2005, 2007 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays definitions ui.gadgets ui.gadgets.borders
|
|
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus
|
|
ui.gadgets.worlds hashtables io kernel prettyprint sequences
|
|
strings io.styles words help math models namespaces quotations
|
|
ui.commands ui.operations ui.gestures ;
|
|
IN: ui.gadgets.presentations
|
|
|
|
TUPLE: presentation object hook ;
|
|
|
|
: invoke-presentation ( presentation command -- )
|
|
over dup presentation-hook call
|
|
>r presentation-object r> invoke-command ;
|
|
|
|
: invoke-primary ( presentation -- )
|
|
dup presentation-object primary-operation
|
|
invoke-presentation ;
|
|
|
|
: invoke-secondary ( presentation -- )
|
|
dup presentation-object secondary-operation
|
|
invoke-presentation ;
|
|
|
|
: show-mouse-help ( presentation -- )
|
|
dup presentation-object over show-summary button-update ;
|
|
|
|
: <presentation> ( label object -- button )
|
|
presentation new
|
|
[ drop ] over set-presentation-hook
|
|
[ set-presentation-object ] keep
|
|
swap [ invoke-primary ] <roll-button>
|
|
over set-gadget-delegate ;
|
|
|
|
M: presentation ungraft*
|
|
dup hand-gadget get-global child? [ dup hide-status ] when
|
|
delegate ungraft* ;
|
|
|
|
: <operations-menu> ( presentation -- menu )
|
|
dup dup presentation-hook curry
|
|
swap presentation-object
|
|
dup object-operations <commands-menu> ;
|
|
|
|
: operations-menu ( presentation -- )
|
|
dup <operations-menu> swap show-menu ;
|
|
|
|
presentation H{
|
|
{ T{ button-down f f 3 } [ operations-menu ] }
|
|
{ T{ mouse-leave } [ dup hide-status button-update ] }
|
|
{ T{ mouse-enter } [ show-mouse-help ] }
|
|
! Responding to motion too allows nested presentations to
|
|
! display status help properly, when the mouse leaves a
|
|
! nested presentation and is still inside the parent, the
|
|
! parent doesn't receive a mouse-enter
|
|
{ T{ motion } [ show-mouse-help ] }
|
|
} set-gestures
|