basis/ui/gadgets/presentations/presentations.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays accessors definitions hashtables io kernel
   4 sequences strings io.styles words help math models
   5 namespaces quotations
   6 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   7 ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
   8 ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
   9 IN: ui.gadgets.presentations
  10
  11 TUPLE: presentation < button object hook ;
  12
  13 : invoke-presentation ( presentation command -- )
  14     over dup hook>> call
  15     [ object>> ] dip invoke-command ;
  16
  17 : invoke-primary ( presentation -- )
  18     dup object>> primary-operation
  19     invoke-presentation ;
  20
  21 : invoke-secondary ( presentation -- )
  22     dup object>> secondary-operation
  23     invoke-presentation ;
  24
  25 : show-mouse-help ( presentation -- )
  26     dup object>> over show-summary button-update ;
  27
  28 : <presentation> ( label object -- button )
  29     swap [ invoke-primary ] presentation new-button
  30         swap >>object
  31         [ drop ] >>hook
  32         roll-button-theme ;
  33
  34 M: presentation ungraft*
  35     dup hand-gadget get-global child? [ dup hide-status ] when
  36     call-next-method ;
  37
  38 : <operations-menu> ( presentation -- menu )
  39     [ object>> ]
  40     [ dup hook>> curry ]
  41     [ object>> object-operations ]
  42     tri <commands-menu> ;
  43
  44 : operations-menu ( presentation -- )
  45     dup <operations-menu> show-menu ;
  46
  47 presentation H{
  48     { T{ button-down f f 3 } [ operations-menu ] }
  49     { T{ mouse-leave } [ dup hide-status button-update ] }
  50     { T{ mouse-enter } [ show-mouse-help ] }
  51     ! Responding to motion too allows nested presentations to
  52     ! display status help properly, when the mouse leaves a
  53     ! nested presentation and is still inside the parent, the
  54     ! parent doesn't receive a mouse-enter
  55     { T{ motion } [ show-mouse-help ] }
  56 } set-gestures