{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverlappingInstances #-} module HTk.Kernel.Core ( Wish(..), wish, TclCmd, TclScript, TclMessageType(..), execCmd, evalCmd, execTclScript, evalTclScript, execMethod, evalMethod, setTclVariable, getTclVariable, -- * submodules module HTk.Kernel.GUIValue, module HTk.Kernel.GUIObjectName, module HTk.Kernel.GUIObjectKind, -- * tool instance GUI(..), getGUI, -- * Widget configuration ConfigOption, ConfigID, showConfigs, showConfig, -- * enabling \/ disabling of widgets HasEnable(..), -- * GUIObjects and methods (internal representation of Tk-Widgets) GUIOBJECT(..), OST(..), -- the gui objects state GUIObject(..), Object(..), ObjectID(..), getObjectNo, getParentObjectID, createGUIObject, createHTkObject, createWidget, lookupGUIObjectByName, lookupGUIObject, getParentPathName, getParentObject, getObjectKind, setObjectKind, getObjectName, setObjectName, Methods(..), defMethods, voidMethods, setMethods, -- * events WishEvent(..), WishEventType(..), WishEventModifier(..), KeySym(..), bind, bindSimple, bindPath, bindPathSimple, HasCommand(..), -- needed to build bind and unbind methods in widget classes: bindTagS, showP, mkBoundCmdArg, BindTag, EventInfoSet, -- * Tk variables 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 -- ----------------------------------------------------------------------- -- base GUI object -- ----------------------------------------------------------------------- instance GUIObject GUIOBJECT where toGUIObject = id cname _ = "GUIOBJECT" -- ----------------------------------------------------------------------- -- destruction of GUI objects -- ----------------------------------------------------------------------- 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) -- ----------------------------------------------------------------------- -- GUI / GUI State -- ----------------------------------------------------------------------- data GUI = GUI GUIOBJECT (Ref GST) type GST = Map.Map ObjectID GUIOBJECT -- ----------------------------------------------------------------------- -- GUI Instances -- ----------------------------------------------------------------------- instance Object GUI where objectID (GUI obj _) = objectID obj instance GUIObject GUI where toGUIObject (GUI obj _) = obj cname _ = "GUI" -- ----------------------------------------------------------------------- -- GUI state -- ----------------------------------------------------------------------- getGUI :: IO GUI -- IO because of old htk stuff, may change 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 -- ---------------------------------------------------------------------- -- GUIObject/Widget Creation -- ---------------------------------------------------------------------- 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 -- ----------------------------------------------------------------------- -- lookup object handle etc. -- ----------------------------------------------------------------------- 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 } -- TD ??? 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) -- TD ??? getParentObjectID :: GUIOBJECT -> IO ObjectID getParentObjectID (GUIOBJECT _ ostref) = withRef ostref parentobj -- ----------------------------------------------------------------------- -- instances (Show) -- ----------------------------------------------------------------------- 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) -- ----------------------------------------------------------------------- -- GUIObject default methods (for widgets and foreign objects mainly) -- ----------------------------------------------------------------------- defMethods :: Methods defMethods = Methods tkGetWidgetConfig tkSetWidgetConfigs tkCreateWidget tkPack tkGrid tkDestroyWidget tkBindWidget tkUnbindWidget tkCleanupWidget voidMethods :: Methods voidMethods = Methods (\_ _ -> []) (\_ _ -> []) (\_ _ _ _ _ -> []) (\_ _ -> []) (\_ _ -> []) (\_ -> []) (\_ _ _ _ _ -> []) (\_ _ _ _ -> []) (\_ _ -> []) -- ----------------------------------------------------------------------- -- unparsing of widget (default 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] -- ----------------------------------------------------------------------- -- widget commands -- ----------------------------------------------------------------------- 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 ()) -- --------------------------------------------------------------------- -- bindings -- --------------------------------------------------------------------- doBind :: GUIObject wid => Bool -> wid -> [WishEvent] -> IO (Event EventInfo,IO ()) doBind bindToTag wid wishEvents = do -- Allocate a bindtag let mVar = bindTags wish bindTag <- takeMVar mVar putMVar mVar (succBindTag bindTag) -- do the binding 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) -- | Binds an event for this widget. The second action returned unbinds -- the event. bind :: GUIObject wid => wid -> [WishEvent] -> IO (Event EventInfo,IO ()) bind = doBind True -- | Simple version of bind for only one event and without modifiers. bindSimple :: GUIObject wid => wid -> WishEventType -> IO (Event (),IO ()) bindSimple = doBindSimple True -- | Binds an event for this widget and its parent widgets. The second -- action returned unbinds the event. bindPath :: Widget wid => wid -> [WishEvent] -> IO (Event EventInfo,IO ()) bindPath = doBind False -- | Simple version of bindPath for only one event and without modifiers. bindPathSimple :: Widget wid => wid -> WishEventType -> IO (Event (), IO ()) bindPathSimple = doBindSimple False -- ----------------------------------------------------------------------- -- convenient execution of Tcl commands -- ----------------------------------------------------------------------- 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) -- ----------------------------------------------------------------------- -- Tk variables (for internal use) -- ----------------------------------------------------------------------- tkDeclVar :: String -> String -> TclScript tkDeclVar var val = ["global " ++ var, "set " ++ var ++ " " ++ val] tkUndeclVar :: String -> TclScript tkUndeclVar var = ["global " ++ var, "unset " ++ var] -- ----------------------------------------------------------------------- -- Tcl variables -- ----------------------------------------------------------------------- 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