Tooltip.hs

-- Author:     Andy Stewart <lazycat.manatee@gmail.com>
-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>
-- 
-- Copyright (C) 2010 Andy Stewart, all rights reserved.
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Manatee.Toolkit.Widget.Tooltip where

import Control.Concurrent.STM
import Control.Monad.Trans
import Data.Maybe
import Data.Ord
import Data.Set 
import Graphics.UI.Gtk hiding (Tooltip)
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.Set
import Manatee.Toolkit.Gtk.Gtk

import qualified Data.Function as F

data Tooltip =
    Tooltip {tooltipId               :: Int
            ,tooltipWindow           :: Window                          -- window for contain widget
            ,tooltipDependWindow     :: Window -- depend window for control display
            ,tooltipLabel            :: Label  -- label to container text
            ,tooltipTimeout          :: Int -- timeout for display (in millisecond)
            ,tooltipHideWhenPress    :: Bool -- hide when press
            ,tooltipFocusInConnectId :: ConnectId Window
            ,tooltipFocusOutConnectId:: ConnectId Window
            }

instance Eq Tooltip where
    (==) = (==) `F.on` tooltipId

instance Ord Tooltip where
    compare = comparing tooltipId

-- | Align size.
tooltipAlignSize :: Int
tooltipAlignSize = 10

-- | Default foreground color.
tooltipDefaultForegroundColor :: Color
tooltipDefaultForegroundColor = Color 0 0 0

-- | Default background color.
tooltipDefaultBackgroundColor :: Color
tooltipDefaultBackgroundColor = Color 65335 65335 0

-- | New tooltip.
tooltipNew :: Int                -- ^ id
           -> Window             -- ^ top-level parent window
           -> String             -- ^ text 
           -> Maybe Point        -- ^ point, 'Nothing' will set right-top corner of screen
           -> Int                -- ^ timeout
           -> Maybe Color        -- ^ foreground color
           -> Maybe Color        -- ^ background color
           -> Bool               -- ^ weather hide when key press
           -> TVar (Set Tooltip) -- ^ set to manage temporary tooltip
           -> IO Tooltip
tooltipNew tId win text position timeout fColor bColor hideWhenPress tooltipSet = do
  -- Set color.
  let foregroundColor = fromMaybe tooltipDefaultForegroundColor fColor
      backgroundColor = fromMaybe tooltipDefaultBackgroundColor bColor

  -- Create tooltip window.
  window <- windowNewPopup
  windowSetDecorated window False
  windowSetOpacity window 0.8   -- this function need window-manager support Alpha channel in X11
  widgetModifyBg window StateNormal backgroundColor

  -- Create frame.
  frame <- frameNew
  set frame [frameShadowType := ShadowEtchedIn]

  -- Create alignment.
  alignment <- alignmentNew 0.5 0.5 1 1
  alignmentSetPadding alignment tooltipAlignSize tooltipAlignSize tooltipAlignSize tooltipAlignSize

  -- Create label.
  label <- labelNew $ Just text
  labelSetAttributes label [AttrForeground 0 (length text) foregroundColor
                           ,AttrBackground 0 (length text) backgroundColor]

  -- Wrap line with word bound.
  labelSetLineWrap label True
  labelSetLineWrapMode label WrapPartialWords

  -- Show tooltip.
  alignment `containerAdd` label
  frame     `containerAdd` alignment
  window    `containerAdd` frame
  widgetShowAll window

  -- Adjust tooltip position.
  (screenWidth, screenHeight) <- widgetGetScreenSize win
  (Rectangle _ _ width height) <- widgetGetAllocation window
  let (tooltipX, tooltipY) =  
        case position of
          Just (x, y) -> 
            let adjustX 
                 -- Set screen right when x bigger than screen width.
                 | x > screenWidth 
                     = screenWidth - width - tooltipAlignSize
                 -- Set left of x when tooltip width bigger than screen width.
                 | x + width > screenWidth
                     = x - width - tooltipAlignSize
                 | otherwise
                     = x
                adjustY 
                 -- Set screen bottom when y bigger than screen height.
                 | y > screenHeight
                     = screenHeight - height - tooltipAlignSize
                 -- Set up of y when tooltip height bigger than screen height.
                 | y + height > screenHeight
                     = y - height - tooltipAlignSize
                 | otherwise
                     = y
            in (adjustX, adjustY)
          Nothing -> (screenWidth - width - tooltipAlignSize, tooltipAlignSize)

  -- Move window.
  windowMove window tooltipX tooltipY

  -- Show tooltip when parent window show.
  focusInConnectId <- 
    win `on` focusInEvent $ tryEvent $ do
        liftIO $ do
          widgetShowAll window
          windowMove window tooltipX tooltipY
        stopEvent

  -- Hide tooltip when parent window hide.
  focusOutConnectId <- 
    win `on` focusOutEvent $ tryEvent $ do
        liftIO $ widgetHideAll window
        stopEvent

  -- Create tooltip.
  let tooltip = Tooltip tId window win label timeout hideWhenPress focusInConnectId focusOutConnectId

  -- Destroy tooltip when out of timeout.
  timeoutAdd (tooltipExit tooltip tooltipSet >> return False) timeout

  return tooltip

-- | Exit tooltip.
tooltipExit :: Tooltip -> TVar (Set Tooltip) -> IO ()
tooltipExit Tooltip {tooltipId                  = tId
                    ,tooltipWindow              = window
                    ,tooltipHideWhenPress       = hideWhenPress
                    ,tooltipFocusInConnectId    = focusInConnectId
                    ,tooltipFocusOutConnectId   = focusOutConnectId
                    } 
            tooltipSet = do
  let exitAction = do
        -- Disconnect signal first.
        signalDisconnect focusInConnectId
        signalDisconnect focusOutConnectId

        -- Destroy tooltip.
        widgetDestroy window

  if hideWhenPress
     -- If tooltip will hide after press key, remove from set first.
     then do
       set <- readTVarIO tooltipSet
       maybeFindMin set (\x -> tooltipId x == tId) 
        ?>= \ tooltip -> do
            modifyTVarIO tooltipSet (delete tooltip)
            exitAction
     else exitAction