module Manatee.UI.FocusNotifier where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans
import Data.Ord
import Data.Set (Set)
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
import Manatee.Toolkit.General.Basic
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.Set
import Manatee.Toolkit.Gtk.Cairo
import Manatee.Toolkit.Gtk.Gtk
import qualified Data.Function as Fun
import qualified Data.Set as Set
data FocusNotifier =
FocusNotifier {focusNotifierId :: FocusNotifierId
,focusNotifierBody :: Widget
,focusNotifierFocus :: Bool}
type FocusNotifierId = Int
data FocusNotifierList = FocusNotifierList (Set FocusNotifier) (Maybe FocusNotifierId)
instance Eq FocusNotifier where
(==) = (==) `Fun.on` focusNotifierId
instance Ord FocusNotifier where
compare = comparing focusNotifierId
focusNotifierSize :: Int
focusNotifierSize = 2
focusNotifierColor :: Color
focusNotifierColor = Color 61440 30464 17920
focusNotifierAlpha :: Double
focusNotifierAlpha = 0.7
focusNotifierNew :: WidgetClass widget => FocusNotifierId -> widget -> TVar FocusNotifierList -> IO FocusNotifier
focusNotifierNew frameId widget focusNotifierList = do
let focusNotifier = FocusNotifier frameId (toWidget widget) False
modifyTVarIO focusNotifierList $ \(FocusNotifierList setList currentFocusId) ->
(FocusNotifierList (Set.insert focusNotifier setList ) currentFocusId)
widget `after` exposeEvent $ tryEvent $ liftIO $
whenM (focusNotifierIsFocus frameId focusNotifierList) $ do
(Rectangle x y w h) <- widgetGetAllocation widget
frameWin <- widgetGetDrawWindow widget
renderWithDrawable frameWin $
focusNotifierDraw
(integralToDouble x)
(integralToDouble y)
(integralToDouble w)
(integralToDouble h)
(integralToDouble focusNotifierSize)
widget `on` destroyEvent $ tryEvent $ liftIO $
modifyTVarIO focusNotifierList $ \(FocusNotifierList setList currentFocusId) ->
let newSetList = Set.delete focusNotifier setList
newFocusId = case currentFocusId of
Just i -> if i == focusNotifierId focusNotifier
then Nothing
else Just i
Nothing -> Nothing
in (FocusNotifierList newSetList newFocusId)
return focusNotifier
focusNotifierIsFocus :: FocusNotifierId -> TVar FocusNotifierList -> IO Bool
focusNotifierIsFocus frameId focusNotifierList = do
focusNotifier <- focusNotifierGetWithId frameId focusNotifierList
return $ case focusNotifier of
Just fn -> focusNotifierFocus fn
Nothing -> False
focusNotifierHide :: TVar FocusNotifierList -> IO ()
focusNotifierHide focusNotifierList =
modifyTVarIOM focusNotifierList $ \list@(FocusNotifierList sfSet focusId) ->
case focusId of
Just fi -> do
match <- focusNotifierGetWithId fi focusNotifierList
case match of
Just m@(FocusNotifier sfId widget _) -> do
focusNotifierErase widget
let newSet = Set.insert (FocusNotifier sfId widget False) $ Set.delete m sfSet
return (FocusNotifierList newSet Nothing)
Nothing -> return $ FocusNotifierList sfSet Nothing
Nothing -> return list
focusNotifierShow :: FocusNotifierId -> TVar FocusNotifierList -> IO ()
focusNotifierShow frameId focusNotifierList = do
let showFun =
modifyTVarIOM focusNotifierList $ \list@(FocusNotifierList sfSet _) -> do
match <- focusNotifierGetWithId frameId focusNotifierList
case match of
Just m@(FocusNotifier sfId widget _) -> do
focusNotifierErase widget
let newSet = Set.insert (FocusNotifier sfId widget True) $ Set.delete m sfSet
return (FocusNotifierList newSet (Just sfId))
Nothing -> return list
(FocusNotifierList _ focusId) <- readTVarIO focusNotifierList
case focusId of
Just fi -> unless (frameId == fi) $ do
focusNotifierHide focusNotifierList
showFun
Nothing -> showFun
focusNotifierDraw :: Double -> Double -> Double -> Double -> Double -> Render ()
focusNotifierDraw x y w h lw = do
let (rv, gv, bv) = colorToRGB focusNotifierColor
setSourceRGBA rv gv bv focusNotifierAlpha
setLineWidth lw
roundRectangle (x + 1) (y + 1) (w 2) (h 2) pi
stroke
focusNotifierGetWithId :: FocusNotifierId -> TVar FocusNotifierList -> IO (Maybe FocusNotifier)
focusNotifierGetWithId frameId focusNotifierList = do
(FocusNotifierList sfSet _) <- readTVarIO focusNotifierList
return $ maybeFindMin sfSet (\fn -> focusNotifierId fn == frameId)
focusNotifierErase :: WidgetClass self => self -> IO ()
focusNotifierErase widget = do
(Rectangle x y w h) <- widgetGetAllocation widget
widgetRedrawRectangleFrame widget
x y w h
(focusNotifierSize + 1)