module HTk.Containers.Toplevel (
Toplevel(..),
createToplevel,
tkGetToplevelConfig,
tkSetToplevelConfigs
) where
import HTk.Kernel.Core
import HTk.Kernel.BaseClasses
import Data.List
import Util.Computation
import Events.Destructible
import Events.Synchronized
import HTk.Containers.Window
import HTk.Kernel.Packer
newtype Toplevel = Toplevel GUIOBJECT deriving Eq
createToplevel :: [Config Toplevel]
-> IO Toplevel
createToplevel cnf =
do
wid <- createGUIObject ROOT TOPLEVEL toplevelMethods
configure (Toplevel wid) cnf
instance GUIObject Toplevel where
toGUIObject (Toplevel f) = f
cname _ = "Toplevel"
instance Destroyable Toplevel where
destroy = destroy . toGUIObject
instance Widget Toplevel
instance Container Toplevel
instance Synchronized Toplevel where
synchronize = synchronize . toGUIObject
instance Window Toplevel
toplevelMethods = Methods tkGetToplevelConfig
tkSetToplevelConfigs
tkCreateToplevel
(packCmd voidMethods)
(gridCmd voidMethods)
(destroyCmd defMethods)
(bindCmd defMethods)
(unbindCmd defMethods)
(cleanupCmd defMethods)
tkCreateToplevel :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
[ConfigOption] -> TclScript
tkCreateToplevel _ kind name _ args =
[ show kind ++ " " ++ show name ++ " " ++ showConfigs cargs,
wmSetConfigs name wargs
]
where (wargs,cargs) = partition (\(cid,_) -> isWMConfig cid) args
tkGetToplevelConfig :: ObjectName -> ConfigID -> TclScript
tkGetToplevelConfig name cid | isWMConfig cid =
["wm " ++ cid ++ " " ++ (show name)]
tkGetToplevelConfig name cid =
[(show name) ++ " cget -" ++ cid]
tkSetToplevelConfigs :: ObjectName -> [ConfigOption] -> TclScript
tkSetToplevelConfigs _ [] = []
tkSetToplevelConfigs name args =
[cSetConfigs name cargs, wmSetConfigs name wargs]
where (wargs,cargs) = partition (\(cid,_) -> isWMConfig cid) args
cSetConfigs :: ObjectName -> [ConfigOption] -> TclCmd
cSetConfigs name [] = ""
cSetConfigs name args = show name ++ " configure " ++ showConfigs args
wmSetConfigs :: ObjectName -> [ConfigOption] -> TclCmd
wmSetConfigs name [] = ""
wmSetConfigs name ((cid,val) : args) =
wmSet name cid val ++ ";" ++ wmSetConfigs name args
wmSet :: ObjectName -> ConfigID -> GUIVALUE -> TclCmd
wmSet name "state" val = "wm " ++ show val ++ " " ++ show name
wmSet name cid val = "wm " ++ cid ++ " " ++ show name ++ " " ++ show val