module HTk.Components.Focus (
CurrentFocus,
FocusModel(..),
focusModel,
getFocusModel,
getFocus,
setFocus,
forceFocus,
getRecentFocus,
GrabStatus(..),
CurrentGrab(..),
grabLocal,
grabGlobal,
releaseGrab,
returnGrab,
getGrabStatus,
getCurrentGrab
) where
import HTk.Kernel.Core
import HTk.Kernel.BaseClasses(Widget)
import Data.Char(isSpace)
import Util.Computation
import HTk.Containers.Window
data GrabStatus = Local | Global deriving (Eq,Ord,Enum)
instance GUIValue GrabStatus where
cdefault = Local
instance Read GrabStatus where
readsPrec p b =
case dropWhile (isSpace) b of
'l':'o':'c':'a':'l':xs -> [(Local,xs)]
'g':'l':'o':'b':'a':'l':xs -> [(Global,xs)]
_ -> []
instance Show GrabStatus where
showsPrec d p r = (case p of
Local -> "local"
Global -> "global") ++ r
data CurrentGrab = CurrentGrab GUIOBJECT deriving Eq
instance Object CurrentGrab where
objectID (CurrentGrab obj) = objectID obj
instance GUIObject CurrentGrab where
toGUIObject (CurrentGrab obj) = obj
cname _ = ""
instance Widget CurrentGrab
grabLocal :: Widget w => w
-> IO ()
grabLocal wid = execMethod wid (\name -> [tkGrabLocal name])
grabGlobal :: Widget w => w
-> IO ()
grabGlobal wid =
execMethod wid (\name -> ["grab set -global " ++ show name])
releaseGrab :: Widget w => w
-> IO ()
releaseGrab wid = execMethod wid (\name -> ["grab release " ++ show name])
getGrabStatus :: Widget w => w
-> IO (Maybe GrabStatus)
getGrabStatus wid =
do
(RawData str) <- evalMethod wid (\nm -> ["grab status " ++ show nm])
case dropWhile isSpace str of
('n':'o':'n':'e':_) -> return Nothing
s -> do {v <- creadTk s; return (Just v)}
getCurrentGrab :: IO (Maybe CurrentGrab)
getCurrentGrab =
evalTclScript ["grab current "] >>= toCurrentGrab . WidgetName
returnGrab :: Maybe CurrentGrab -> IO ()
returnGrab Nothing = done
returnGrab (Just g) = execMethod g (\name -> [tkGrabLocal name])
toCurrentGrab :: WidgetName -> IO (Maybe CurrentGrab)
toCurrentGrab name = do {
obj <- lookupGUIObjectByName name;
case obj of
Nothing -> return Nothing
(Just o) -> (return . Just . CurrentGrab) o
}
tkGrabLocal :: ObjectName -> TclCmd
tkGrabLocal name = "grab set " ++ show name
data FocusModel = ActiveFocus | PassiveFocus deriving (Eq,Ord,Enum)
instance GUIValue FocusModel where
cdefault = PassiveFocus
instance Read FocusModel where
readsPrec p b =
case dropWhile (isSpace) b of
'a':'c':'t':'i':'v':'e':xs -> [(ActiveFocus,xs)]
'p':'a':'s':'s':'i':'v':'e':xs -> [(PassiveFocus,xs)]
_ -> []
instance Show FocusModel where
showsPrec d p r =
(case p of
ActiveFocus -> "active"
PassiveFocus -> "passive"
) ++ r
focusModel :: Window w => FocusModel -> Config w
focusModel fm win = cset win "focusmodel" fm
getFocusModel :: Window w => w -> IO FocusModel
getFocusModel win = cget win "focusmodel"
data CurrentFocus = CurrentFocus GUIOBJECT
instance Object CurrentFocus where
objectID (CurrentFocus obj) = objectID obj
instance GUIObject CurrentFocus where
toGUIObject (CurrentFocus obj) = obj
cname _ = ""
instance Widget CurrentFocus
getFocus :: Window w => w
-> IO (Maybe CurrentFocus)
getFocus win =
evalMethod win (\wn -> ["focus -displayof " ++ show wn]) >>=
toCurrentFocus . WidgetName
setFocus :: Widget w => w
-> IO ()
setFocus w = execMethod w (\wn -> ["focus " ++ show wn])
forceFocus :: Widget w => w
-> IO ()
forceFocus w = execMethod w (\wn -> ["focus -force " ++ show wn])
getRecentFocus :: Window w => w
-> IO (Maybe CurrentFocus)
getRecentFocus w =
evalMethod w (\wn -> ["focus -lastfor " ++ show wn]) >>=
toCurrentFocus . WidgetName
toCurrentFocus :: WidgetName -> IO (Maybe CurrentFocus)
toCurrentFocus name =
do
obj <- lookupGUIObjectByName name
case obj of Nothing -> return Nothing
(Just o) -> (return . Just . CurrentFocus) o