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
,tooltipDependWindow :: Window
,tooltipLabel :: Label
,tooltipTimeout :: Int
,tooltipHideWhenPress :: Bool
,tooltipFocusInConnectId :: ConnectId Window
,tooltipFocusOutConnectId:: ConnectId Window
}
instance Eq Tooltip where
(==) = (==) `F.on` tooltipId
instance Ord Tooltip where
compare = comparing tooltipId
tooltipAlignSize :: Int
tooltipAlignSize = 10
tooltipDefaultForegroundColor :: Color
tooltipDefaultForegroundColor = Color 0 0 0
tooltipDefaultBackgroundColor :: Color
tooltipDefaultBackgroundColor = Color 65335 65335 0
tooltipNew :: Int
-> Window
-> String
-> Maybe Point
-> Int
-> Maybe Color
-> Maybe Color
-> Bool
-> TVar (Set Tooltip)
-> IO Tooltip
tooltipNew tId win text position timeout fColor bColor hideWhenPress tooltipSet = do
let foregroundColor = fromMaybe tooltipDefaultForegroundColor fColor
backgroundColor = fromMaybe tooltipDefaultBackgroundColor bColor
window <- windowNewPopup
windowSetDecorated window False
windowSetOpacity window 0.8
widgetModifyBg window StateNormal backgroundColor
frame <- frameNew
set frame [frameShadowType := ShadowEtchedIn]
alignment <- alignmentNew 0.5 0.5 1 1
alignmentSetPadding alignment tooltipAlignSize tooltipAlignSize tooltipAlignSize tooltipAlignSize
label <- labelNew $ Just text
labelSetAttributes label [AttrForeground 0 (length text) foregroundColor
,AttrBackground 0 (length text) backgroundColor]
labelSetLineWrap label True
labelSetLineWrapMode label WrapPartialWords
alignment `containerAdd` label
frame `containerAdd` alignment
window `containerAdd` frame
widgetShowAll window
(screenWidth, screenHeight) <- widgetGetScreenSize win
(Rectangle _ _ width height) <- widgetGetAllocation window
let (tooltipX, tooltipY) =
case position of
Just (x, y) ->
let adjustX
| x > screenWidth
= screenWidth width tooltipAlignSize
| x + width > screenWidth
= x width tooltipAlignSize
| otherwise
= x
adjustY
| y > screenHeight
= screenHeight height tooltipAlignSize
| y + height > screenHeight
= y height tooltipAlignSize
| otherwise
= y
in (adjustX, adjustY)
Nothing -> (screenWidth width tooltipAlignSize, tooltipAlignSize)
windowMove window tooltipX tooltipY
focusInConnectId <-
win `on` focusInEvent $ tryEvent $ do
liftIO $ do
widgetShowAll window
windowMove window tooltipX tooltipY
stopEvent
focusOutConnectId <-
win `on` focusOutEvent $ tryEvent $ do
liftIO $ widgetHideAll window
stopEvent
let tooltip = Tooltip tId window win label timeout hideWhenPress focusInConnectId focusOutConnectId
timeoutAdd (tooltipExit tooltip tooltipSet >> return False) timeout
return tooltip
tooltipExit :: Tooltip -> TVar (Set Tooltip) -> IO ()
tooltipExit Tooltip {tooltipId = tId
,tooltipWindow = window
,tooltipHideWhenPress = hideWhenPress
,tooltipFocusInConnectId = focusInConnectId
,tooltipFocusOutConnectId = focusOutConnectId
}
tooltipSet = do
let exitAction = do
signalDisconnect focusInConnectId
signalDisconnect focusOutConnectId
widgetDestroy window
if hideWhenPress
then do
set <- readTVarIO tooltipSet
maybeFindMin set (\x -> tooltipId x == tId)
?>= \ tooltip -> do
modifyTVarIO tooltipSet (delete tooltip)
exitAction
else exitAction