basis/ui/gadgets/presentations/presentations.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel memoize namespaces ui.commands ui.gadgets
   4 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private
   5 ui.gadgets.glass ui.gadgets.menus ui.gadgets.status-bar
   6 ui.gadgets.theme ui.gadgets.worlds ui.gestures
   7 ui.operations ui.pens.solid ;
   8 IN: ui.gadgets.presentations
   9
  10 TUPLE: presentation < button object hook ;
  11
  12 TUPLE: presentation-menu < border presentation ;
  13
  14 : invoke-presentation ( presentation command -- )
  15     [ [ dup hook>> call( presentation -- ) ] [ object>> ] bi ] dip
  16     invoke-command ;
  17
  18 : invoke-primary ( presentation -- )
  19     dup object>> primary-operation
  20     invoke-presentation ;
  21
  22 : invoke-secondary ( presentation -- )
  23     dup object>> secondary-operation
  24     invoke-presentation ;
  25
  26 : show-mouse-help ( presentation -- )
  27     [ [ object>> ] keep show-summary ] [ button-update ] bi ;
  28
  29 : <presentation> ( label object -- button )
  30     [ [ invoke-primary ] presentation new-button ] dip
  31         >>object
  32         [ drop ] >>hook
  33         roll-button-theme ;
  34
  35 M: presentation ungraft*
  36     dup hand-gadget get-global child? [ dup hide-status ] when
  37     call-next-method ;
  38
  39 MEMO: selected-pen-boundary ( -- button-pen )
  40     roll-button-rollover-border <solid> dup dup f f <button-pen> ;
  41
  42 <PRIVATE
  43 : setup-presentation ( presentation -- presentation )
  44     selected-pen-boundary >>boundary ;
  45 PRIVATE>
  46
  47 : <presentation-menu> ( presentation target hook -- menu )
  48     <operations-menu> presentation-menu new-border
  49         swap >>presentation
  50         { 0 0 } >>size ;
  51
  52 : show-presentation-menu ( presentation -- )
  53     setup-presentation dup
  54     [ ] [ object>> ] [ dup hook>> curry ] tri
  55     <presentation-menu> show-menu ;
  56
  57 M: presentation-menu hide-glass-hook
  58     presentation>> button-pen-boundary >>boundary drop ;
  59
  60 presentation H{
  61     { T{ button-down f f 3 } [ show-presentation-menu ] }
  62     { mouse-leave [ [ hide-status ] [ button-update ] bi ] }
  63     { mouse-enter [ show-mouse-help ] }
  64     ! Responding to motion too allows nested presentations to
  65     ! display status help properly, when the mouse leaves a
  66     ! nested presentation and is still inside the parent, the
  67     ! parent doesn't receive a mouse-enter
  68     { motion [ show-mouse-help ] }
  69 } set-gestures