module HTk.Kernel.Core (
Wish(..),
wish,
TclCmd,
TclScript,
TclMessageType(..),
execCmd,
evalCmd,
execTclScript,
evalTclScript,
execMethod,
evalMethod,
setTclVariable,
getTclVariable,
module HTk.Kernel.GUIValue,
module HTk.Kernel.GUIObjectName,
module HTk.Kernel.GUIObjectKind,
GUI(..),
getGUI,
ConfigOption,
ConfigID,
showConfigs,
showConfig,
HasEnable(..),
GUIOBJECT(..),
OST(..),
GUIObject(..),
Object(..),
ObjectID(..),
getObjectNo,
getParentObjectID,
createGUIObject,
createHTkObject,
createWidget,
lookupGUIObjectByName,
lookupGUIObject,
getParentPathName,
getParentObject,
getObjectKind,
setObjectKind,
getObjectName,
setObjectName,
Methods(..),
defMethods,
voidMethods,
setMethods,
WishEvent(..),
WishEventType(..),
WishEventModifier(..),
KeySym(..),
bind,
bindSimple,
bindPath,
bindPathSimple,
HasCommand(..),
bindTagS,
showP,
mkBoundCmdArg,
BindTag,
EventInfoSet,
tkDeclVar,
tkUndeclVar,
) where
import qualified Data.Map as Map
import Control.Concurrent
import System.IO.Unsafe
import Util.Computation
import Events.GuardedEvents
import Events.EqGuard
import Events.Events
import Util.Object
import Reactor.ReferenceVariables
import Events.Destructible
import qualified Util.ExtendedPrelude as ExtendedPrelude(simpleSplit)
import HTk.Kernel.GUIValue
import HTk.Kernel.EventInfo
import HTk.Kernel.GUIObjectName
import HTk.Kernel.GUIObject
import HTk.Kernel.GUIObjectKind
import HTk.Kernel.Wish
import HTk.Kernel.BaseClasses(Widget)
import HTk.Kernel.Configuration
import HTk.Kernel.PackOptions
import HTk.Kernel.GridPackOptions
instance GUIObject GUIOBJECT where
toGUIObject = id
cname _ = "GUIOBJECT"
instance GUIObject a => Destroyable a where
destroy wid =
do
let (GUIOBJECT oid ostref) = toGUIObject wid
meth <- withRef ostref methods
nm <- withRef ostref objectname
execTclScript ((destroyCmd meth) nm)
data GUI = GUI GUIOBJECT (Ref GST)
type GST = Map.Map ObjectID GUIOBJECT
instance Object GUI where
objectID (GUI obj _) = objectID obj
instance GUIObject GUI where
toGUIObject (GUI obj _) = obj
cname _ = "GUI"
getGUI :: IO GUI
getGUI =
return (unsafePerformIO (do
wdg <- newRef Map.empty
obj <- newGUIObject ROOT SESSION defMethods
let gui = GUI obj wdg
return gui))
applyGUI :: (GST -> GST) -> IO ()
applyGUI f = getGUI >>= \ (GUI _ gui) -> changeRef gui f
queryGUI :: (GST -> a) -> IO a
queryGUI f = getGUI >>= \ (GUI _ gui) -> withRef gui f
createGUIObject :: GUIOBJECT -> ObjectKind -> Methods -> IO GUIOBJECT
createGUIObject par@(GUIOBJECT _ postref) kind meths =
do
guio@(GUIOBJECT oid ostref) <- newGUIObject par kind meths
GUI _ gstref <- getGUI
changeRef gstref (newObj guio)
name <- withRef ostref objectname
pname <- withRef postref objectname
execTclScript ((createCmd meths) pname kind name oid [])
return guio
where newObj guio @ (GUIOBJECT oid ost) wd = Map.insert oid guio wd
createGUIObject ROOT kind meths =
do
guio@(GUIOBJECT oid ostref) <- newGUIObject ROOT kind meths
GUI _ gstref <- getGUI
changeRef gstref (newObj guio)
name <- withRef ostref objectname
execTclScript ((createCmd meths) (ObjectName ".") kind name oid [])
return guio
where newObj guio @ (GUIOBJECT oid ost) wd = Map.insert oid guio wd
createHTkObject :: Methods -> IO GUIOBJECT
createHTkObject meths =
do
oid <- newObject
ost <- newRef (OST ABSTRACT (ObjectName ".") oid meths)
return (GUIOBJECT oid ost)
createWidget :: GUIOBJECT -> ObjectKind -> IO GUIOBJECT
createWidget par kind = createGUIObject par kind defMethods
lookupGUIObject :: ObjectID -> IO GUIOBJECT
lookupGUIObject key = do {
mwid <- queryGUI (\wd -> Map.lookup key wd);
case mwid of
Nothing ->
error "Haskell-Tk Error: gui object not found"
(Just wid) -> return wid
}
getParentPathName :: GUIObject w => w -> IO (Maybe ObjectName)
getParentPathName w =
do
par' <- getParentObject w
case par' of Nothing -> return Nothing
Just par -> do
nm <- getObjectName par
return (Just nm)
lookupGUIObjectByName :: WidgetName -> IO (Maybe GUIOBJECT)
lookupGUIObjectByName (WidgetName "") = return Nothing
lookupGUIObjectByName (WidgetName str) =
queryGUI (\wd -> Map.lookup no wd)
where wnm =
head (reverse (ExtendedPrelude.simpleSplit (== '.') str))
no = ObjectID (read ( drop 1 wnm))
getParentObject :: GUIObject w => w -> IO (Maybe GUIOBJECT)
getParentObject w =
do
oid <- getParentObjectID (toGUIObject w)
queryGUI (\wd -> Map.lookup oid wd)
getParentObjectID :: GUIOBJECT -> IO ObjectID
getParentObjectID (GUIOBJECT _ ostref) = withRef ostref parentobj
showConfig :: (ConfigID, GUIVALUE) -> String
showConfig (cid, cval) =
"-" ++ cid ++ " " ++
case cid of
"tag" -> "\"" ++ (drop 2 (show cval))
_ -> show cval
showConfigs :: [(ConfigID, GUIVALUE)] -> String
showConfigs [] = " "
showConfigs (x : ol) = (showConfig x) ++ " " ++ (showConfigs ol)
defMethods :: Methods
defMethods = Methods tkGetWidgetConfig
tkSetWidgetConfigs
tkCreateWidget
tkPack
tkGrid
tkDestroyWidget
tkBindWidget
tkUnbindWidget
tkCleanupWidget
voidMethods :: Methods
voidMethods = Methods (\_ _ -> [])
(\_ _ -> [])
(\_ _ _ _ _ -> [])
(\_ _ -> [])
(\_ _ -> [])
(\_ -> [])
(\_ _ _ _ _ -> [])
(\_ _ _ _ -> [])
(\_ _ -> [])
tkCreateWidget :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
[ConfigOption] -> TclScript
tkCreateWidget _ kind name _ opts =
[show kind ++ " " ++ show name ++ " " ++ showConfigs opts]
tkPack :: ObjectName -> [PackOption] -> TclScript
tkPack name opts = ["pack " ++ show name ++ " " ++ showPackOptions opts]
tkGrid :: ObjectName -> [GridPackOption] -> TclScript
tkGrid name opts =
["grid " ++ show name ++ " " ++ showGridPackOptions opts]
tkBindWidget :: ObjectName -> BindTag -> [WishEvent] ->
EventInfoSet -> Bool -> TclScript
tkBindWidget nm bindTag wishEvents eventInfoSet bindToTag =
let evStr flag = delimitString (foldr (\ event soFar -> showP event soFar)
"" wishEvents) ++ " " ++
mkBoundCmdArg bindTag eventInfoSet flag
in if bindToTag then ["addtag " ++ show nm ++ " " ++ bindTagS bindTag,
"bind " ++ bindTagS bindTag ++ " " ++ evStr False]
else ["bind " ++ show nm ++ " " ++ evStr True]
tkUnbindWidget :: ObjectName -> BindTag -> [WishEvent] -> Bool ->
TclScript
tkUnbindWidget nm bindTag wishEvents boundToTag =
let evStr = delimitString (foldr (\ event soFar -> showP event soFar)
"" wishEvents) ++ " {}"
in if boundToTag then ["rmtag " ++ show nm ++ " " ++ bindTagS bindTag,
"bind " ++ bindTagS bindTag ++ " " ++ evStr]
else ["bind " ++ show nm ++ " " ++ evStr]
tkDestroyWidget :: ObjectName -> TclScript
tkDestroyWidget name = ["destroy " ++ show name]
tkCleanupWidget :: ObjectID -> ObjectName -> TclScript
tkCleanupWidget _ _ = []
tkGetWidgetConfig :: ObjectName -> ConfigID -> TclScript
tkGetWidgetConfig name cid = [(show name) ++ " cget -" ++ cid]
tkSetWidgetConfigs :: ObjectName -> [ConfigOption] -> TclScript
tkSetWidgetConfigs _ [] = []
tkSetWidgetConfigs name args =
[show name ++ " configure " ++ showConfigs args]
class GUIObject w => HasCommand w where
clicked :: w -> IO (Event ())
clicked w =
do
let (GUIOBJECT oid _) = toGUIObject w
cset w "command" (TkCommand ("puts \"CO " ++ show oid ++ "\""))
return (toEvent (listen (coQueue wish) |> Eq (CallBackId oid))
>>> return ())
doBind :: GUIObject wid => Bool -> wid -> [WishEvent] ->
IO (Event EventInfo,IO ())
doBind bindToTag wid wishEvents =
do
let mVar = bindTags wish
bindTag <- takeMVar mVar
putMVar mVar (succBindTag bindTag)
let (GUIOBJECT oid ostref) = toGUIObject wid
meth <- withRef ostref methods
nm <- getObjectName (toGUIObject wid)
execTclScript ((bindCmd meth) nm bindTag wishEvents
defaultEventInfoSet bindToTag)
let
event =
toEvent (listen (eventQueue wish) |> Eq bindTag)
>>>= (\ (_,eventInfoSet) -> return eventInfoSet)
unbind :: IO ()
unbind = execTclScript ((unbindCmd meth) nm bindTag wishEvents
bindToTag)
return (event,unbind)
doBindSimple :: GUIObject wid => Bool -> wid -> WishEventType ->
IO (Event (),IO ())
doBindSimple bindToTag wid wishEventType =
do
(event1, deregister) <-
doBind bindToTag wid [WishEvent [] wishEventType]
return (event1 >>> done, deregister)
bind :: GUIObject wid => wid -> [WishEvent] -> IO (Event EventInfo,IO ())
bind = doBind True
bindSimple :: GUIObject wid => wid -> WishEventType ->
IO (Event (),IO ())
bindSimple = doBindSimple True
bindPath :: Widget wid => wid -> [WishEvent] -> IO (Event EventInfo,IO ())
bindPath = doBind False
bindPathSimple :: Widget wid => wid -> WishEventType ->
IO (Event (), IO ())
bindPathSimple = doBindSimple False
evalMethod :: (GUIObject a, GUIValue b) =>
a -> (ObjectName -> TclScript) -> IO b
evalMethod wid meth =
do
let (GUIOBJECT _ ostref) = toGUIObject wid
nm <- withRef ostref objectname
str <- evalTclScript (meth nm)
creadTk str
execMethod :: GUIObject a => a -> (ObjectName -> TclScript) -> IO ()
execMethod wid meth =
do
let (GUIOBJECT _ ostref) = toGUIObject wid
nm <- withRef ostref objectname
execTclScript (meth nm)
tkDeclVar :: String -> String -> TclScript
tkDeclVar var val = ["global " ++ var, "set " ++ var ++ " " ++ val]
tkUndeclVar :: String -> TclScript
tkUndeclVar var = ["global " ++ var, "unset " ++ var]
setTclVariable :: GUIValue a => String -> a -> IO ()
setTclVariable name v =
execTclScript ["global " ++ name,
"set " ++ name ++ " " ++ show (toGUIValue v)]
getTclVariable :: GUIValue a => String -> IO a
getTclVariable name =
evalTclScript ["global " ++ name ++ "; set res $" ++ name] >>= creadTk