module HTk.Tix.LabelFrame (
LabelFrame,
newLabelFrame,
labelSide,
getLabelSide,
LabelSide(..)
) where
import HTk.Kernel.Core
import HTk.Kernel.BaseClasses(Widget)
import HTk.Kernel.Configuration
import Util.Computation
import Events.Synchronized
import Events.Destructible
import HTk.Kernel.Packer
import Data.Char
import HTk.Kernel.PackOptions
import HTk.Kernel.GridPackOptions
import HTk.Kernel.Tooltip
newtype LabelFrame = LabelFrame GUIOBJECT deriving Eq
newLabelFrame :: Container par => par
-> [Config LabelFrame]
->
IO LabelFrame
newLabelFrame par cnf =
do
w <- createGUIObject (toGUIObject par) LABELFRAME labelFrameMethods
configure (LabelFrame w) cnf
labelSide :: LabelSide -> Config LabelFrame
labelSide ls w = cset w "labelside" ls
getLabelSide :: LabelFrame -> IO LabelSide
getLabelSide w = cget w "labelside"
data LabelSide =
TopLabel | LeftLabel | RightLabel | BottomLabel | NoLabel
| AcrossTopLabel
instance Read LabelSide where
readsPrec p b =
case dropWhile isSpace b of
't':'o':'p': xs -> [(TopLabel,xs)]
'l':'e':'f':'t': xs -> [(LeftLabel, xs)]
'r':'i':'g':'h':'t': xs -> [(RightLabel, xs)]
'b':'o':'t':'t':'o':'m': xs -> [(BottomLabel, xs)]
'n':'o':'n':'e': xs -> [(NoLabel, xs)]
'a':'c':'r':'o':'s':'s':'t':'o':'p': xs -> [(AcrossTopLabel, xs)]
_ -> []
instance Show LabelSide where
showsPrec d p r =
(case p of TopLabel -> "top"
LeftLabel -> "left"
RightLabel -> "right"
BottomLabel -> "bottom"
NoLabel -> "none"
AcrossTopLabel -> "acrosstop") ++ r
instance GUIValue LabelSide where
cdefault = TopLabel
labelFrameMethods = Methods tkGetLabelFrameConfig
tkSetLabelFrameConfigs
tkCreateLabelFrame
tkPackLabelFrame
tkGridLabelFrame
(destroyCmd defMethods)
(bindCmd defMethods)
(unbindCmd defMethods)
(cleanupCmd defMethods)
tkGetLabelFrameConfig :: ObjectName -> ConfigID -> TclScript
tkGetLabelFrameConfig (LabelFrameName nm oid) cid =
[show nm ++ " cget -" ++ cid]
tkSetLabelFrameConfigs :: ObjectName -> [ConfigOption] -> TclScript
tkSetLabelFrameConfigs (LabelFrameName nm oid) args =
[show nm ++ " configure " ++ showConfigs args]
tkSetLabelFrameConfigs _ _ = []
tkCreateLabelFrame :: ObjectName -> ObjectKind -> ObjectName ->
ObjectID -> [ConfigOption] -> TclScript
tkCreateLabelFrame parnm _ nm oid args =
["tixLabelFrame " ++ show parnm ++ "." ++ show oid ++ " "++
showConfigs args,
"global v" ++ show oid,
"set v" ++ show oid ++ " [" ++ show parnm ++ "." ++ show oid ++ " subwidget frame]"]
tkPackLabelFrame :: ObjectName -> [PackOption] -> TclScript
tkPackLabelFrame (LabelFrameName nm _) opts =
["pack " ++ show nm ++ " " ++ showPackOptions opts]
tkGridLabelFrame :: ObjectName -> [GridPackOption] -> TclScript
tkGridLabelFrame (LabelFrameName nm _) opts =
["grid " ++ show nm ++ " " ++ showGridPackOptions opts]
instance GUIObject LabelFrame where
toGUIObject (LabelFrame w) = w
cname _ = "LabelFrame"
instance Destroyable LabelFrame where
destroy = destroy . toGUIObject
instance Widget LabelFrame
instance Container LabelFrame
instance HasBorder LabelFrame
instance HasColour LabelFrame where
legalColourID = hasBackGroundColour
instance HasTooltip LabelFrame
instance HasSize LabelFrame
instance GUIValue v => HasText LabelFrame v where
text s w = cset w "label" s
getText w = cget w "label"
instance Synchronized LabelFrame where
synchronize = synchronize . toGUIObject