module HTk.Kernel.GUIObject(
GUIObject(..),
GUIOBJECT(..),
newGUIObject,
setObjectKind,
setObjectName,
getMethods,
setMethods,
getObjectName,
getObjectNo,
getObjectKind,
OST(..),
ConfigID,
ConfigOption,
Methods(..)
) where
import Reactor.ReferenceVariables
import Events.Synchronized
import HTk.Kernel.GUIObjectKind
import HTk.Kernel.GUIObjectName
import Util.Object
import HTk.Kernel.Wish
import HTk.Kernel.EventInfo
import HTk.Kernel.GUIValue
import HTk.Kernel.PackOptions
import HTk.Kernel.GridPackOptions
class GUIObject w where
toGUIObject :: w -> GUIOBJECT
cname :: w -> String
cset :: GUIValue a => w -> ConfigID -> a -> IO w
cget :: GUIValue a => w -> ConfigID -> IO a
cset w cid v = setConfig (toGUIObject w) cid v >> return w
cget w cid = getConfig (toGUIObject w) cid
setConfig :: GUIValue a => GUIOBJECT -> ConfigID -> a -> IO ()
setConfig (GUIOBJECT _ ostref) cid val =
do
ost <- getRef ostref
execTclScript
((csetCmd (methods ost)) (objectname ost) [(cid, toGUIValue val)])
getConfig :: GUIValue a => GUIOBJECT -> ConfigID -> IO a
getConfig (GUIOBJECT _ ostref) cid =
do
ost <- getRef ostref
resp <- evalTclScript ((cgetCmd (methods ost)) (objectname ost) cid)
creadTk resp
data GUIOBJECT = GUIOBJECT ObjectID (Ref OST) | ROOT
data OST =
OST { objectkind :: ObjectKind,
objectname :: ObjectName,
parentobj :: ObjectID,
methods :: Methods }
instance Eq GUIOBJECT where
(GUIOBJECT key1 _) == (GUIOBJECT key2 _) = key1 == key2
wid1 /= wid2 = not (wid1 == wid2)
instance Ord GUIOBJECT where
(GUIOBJECT key1 _) <= (GUIOBJECT key2 _) = key1 <= key2
instance Object GUIOBJECT where
objectID (GUIOBJECT oid _) = oid
instance Synchronized GUIOBJECT where
synchronize (GUIOBJECT _ ostref) = synchronize ostref
newGUIObject :: GUIOBJECT -> ObjectKind -> Methods -> IO GUIOBJECT
newGUIObject par@(GUIOBJECT parId parostref) kind meths =
do
oid <- newObject
parnm <- withRef parostref objectname
case kind of
TEXTTAG _ -> do
ost <- newRef (OST kind (TextPaneItemName parnm
(TextTagID oid))
parId meths)
return (GUIOBJECT oid ost)
EMBEDDEDTEXTWIN _ _ -> do
ost <- newRef (OST kind (TextPaneItemName parnm
(TextTagID oid))
parId meths)
return (GUIOBJECT oid ost)
MENUITEM _ i -> do
ost <- newRef (OST kind (MenuItemName parnm i)
parId meths)
return (GUIOBJECT oid ost)
CANVASITEM _ _ -> do
ost <- newRef
(OST kind (CanvasItemName
parnm
(CanvasTagOrID oid))
parId meths)
return (GUIOBJECT oid ost)
NOTEBOOKPAGE _ -> do
ost <- newRef (OST kind (NoteBookPageName oid)
parId meths)
return (GUIOBJECT oid ost)
WINDOWPANE -> do
ost <- newRef (OST kind (PaneName oid)
parId meths)
return (GUIOBJECT oid ost)
LABELFRAME -> do
let nm = show parnm ++
(if show parnm == "." then "" else ".") ++
show oid
ost <- newRef (OST kind (LabelFrameName
(ObjectName nm) oid)
parId meths)
return (GUIOBJECT oid ost)
SUBWIDGET subKind megaName ->
do let objName = "["++show kind++"]"
ost <- newRef (OST subKind (ObjectName objName) parId meths)
return (GUIOBJECT oid ost)
_ -> do
let nm = show parnm ++
(if show parnm == "." then "" else ".") ++ show oid
ost <- newRef (OST kind (ObjectName nm) parId meths)
return (GUIOBJECT oid ost)
newGUIObject ROOT kind meths =
do
oid <- newObject
ost <- newRef (OST kind (ObjectName ("." ++ show oid)) oid meths)
return (GUIOBJECT oid ost)
getObjectNo :: GUIOBJECT -> Int
getObjectNo (GUIOBJECT (ObjectID i) _) = i
getMethods :: GUIOBJECT -> IO Methods
getMethods (GUIOBJECT _ ostref) = withRef ostref methods
setMethods :: GUIOBJECT -> Methods -> IO ()
setMethods (GUIOBJECT _ ostref) meth =
changeRef ostref (\o -> o{methods = meth})
getObjectKind :: GUIOBJECT -> IO ObjectKind
getObjectKind (GUIOBJECT _ ostref) = withRef ostref objectkind
setObjectKind :: GUIOBJECT -> ObjectKind -> IO ()
setObjectKind (GUIOBJECT _ ostref) kind =
changeRef ostref (\o -> o{objectkind = kind})
getObjectName :: GUIOBJECT -> IO ObjectName
getObjectName (GUIOBJECT _ ostref) = withRef ostref objectname
setObjectName :: GUIOBJECT -> ObjectName -> IO ()
setObjectName (GUIOBJECT _ ostref) name =
changeRef ostref (\o -> o{objectname = name})
type ConfigID = String
type ConfigOption = (ConfigID, GUIVALUE)
data Methods =
Methods { cgetCmd :: ObjectName -> ConfigID -> TclScript,
csetCmd :: ObjectName -> [ConfigOption] -> TclScript,
createCmd :: ObjectName -> ObjectKind -> ObjectName ->
ObjectID -> [ConfigOption] -> TclScript,
packCmd :: ObjectName -> [PackOption] -> TclScript,
gridCmd :: ObjectName -> [GridPackOption] -> TclScript,
destroyCmd :: ObjectName -> TclScript,
bindCmd :: ObjectName -> BindTag -> [WishEvent] ->
EventInfoSet -> Bool -> TclScript,
unbindCmd :: ObjectName -> BindTag -> [WishEvent] ->
Bool -> TclScript,
cleanupCmd :: ObjectID -> ObjectName -> TclScript }