1{-# LANGUAGE CPP #-} 2-- -*-haskell-*- 3-- GIMP Toolkit (GTK) General 4-- 5-- Author : Axel Simon, Manuel M. T. Chakravarty 6-- 7-- Created: 8 December 1998 8-- 9-- Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty 10-- 11-- This library is free software; you can redistribute it and/or 12-- modify it under the terms of the GNU Lesser General Public 13-- License as published by the Free Software Foundation; either 14-- version 2.1 of the License, or (at your option) any later version. 15-- 16-- This library is distributed in the hope that it will be useful, 17-- but WITHOUT ANY WARRANTY; without even the implied warranty of 18-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19-- Lesser General Public License for more details. 20-- 21-- | 22-- Maintainer : gtk2hs-users@lists.sourceforge.net 23-- Stability : provisional 24-- Portability : portable (depends on GHC) 25-- 26-- library initialization, main event loop, and events 27-- 28module Graphics.UI.Gtk.General.General ( 29-- getDefaultLanguage, 30 -- * Initialisation 31 initGUI, 32 33 -- ** Support for OS threads 34 unsafeInitGUIForThreadedRTS, 35 postGUISync, 36 postGUIAsync, 37 threadsEnter, 38 threadsLeave, 39 40 -- * Main event loop 41 mainGUI, 42 mainQuit, 43 44 -- ** Less commonly used event loop functions 45 eventsPending, 46 mainLevel, 47 mainIteration, 48 mainIterationDo, 49 mainDoEvent, 50 51 -- ** Call when mainloop is left 52#if GTK_MAJOR_VERSION < 3 53 quitAddDestroy, 54 quitAdd, 55 quitRemove, 56#endif 57 58 -- * Grab widgets 59 grabAdd, 60 grabGetCurrent, 61 grabRemove, 62 63 -- * Timeout and idle callbacks 64 Priority, 65 priorityLow, 66 priorityDefaultIdle, 67 priorityHighIdle, 68 priorityDefault, 69 priorityHigh, 70 timeoutAdd, 71 timeoutAddFull, 72 timeoutRemove, 73 idleAdd, 74 idleRemove, 75 inputAdd, 76 inputRemove, 77 IOCondition(..), 78 HandlerId, 79 FD 80 ) where 81 82import Control.Applicative 83import Prelude 84import System.Environment (getProgName, getArgs) 85import Control.Monad (liftM, when) 86import Control.Concurrent (rtsSupportsBoundThreads, newEmptyMVar, 87 putMVar, takeMVar) 88 89import System.Glib.FFI 90import System.Glib.UTFString 91import qualified System.Glib.MainLoop as ML 92import System.Glib.MainLoop ( Priority, priorityLow, priorityDefaultIdle, 93 priorityHighIdle, priorityDefault, priorityHigh, timeoutRemove, idleRemove, 94 inputRemove, IOCondition(..), HandlerId ) 95import Graphics.UI.Gtk.Abstract.Object (makeNewObject) 96import Graphics.UI.Gtk.Gdk.EventM (EventM) 97import Control.Monad.Reader (ask) 98import Control.Monad.Trans (liftIO) 99{#import Graphics.UI.Gtk.Types#} 100 101{#context lib="gtk" prefix ="gtk"#} 102 103{- 104-- | Retreive the current language. 105-- * This function returns a String which's pointer can be used later on for 106-- comarisions. 107-- 108--getDefaultLanguage :: GlibString string => IO string 109--getDefaultLanguage = do 110-- strPtr <- {#call unsafe get_default_language#} 111-- str <- peekUTFString strPtr 112-- destruct strPtr 113-- return str 114-} 115 116unsafeInitGUIForThreadedRTS = initGUI 117 118-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi 119-- check however we do not compile users programs with this header so if 120-- initGUI was ever inlined in a users program, then that program would not 121-- bypass the abi check and would fail on startup. So to stop that we must 122-- prevent initGUI from being inlined. 123{-# NOINLINE initGUI #-} 124-- | Initialize the GUI. 125-- 126-- This must be called before any other function in the Gtk2Hs library. 127-- 128-- This function initializes the GUI toolkit and parses all Gtk 129-- specific arguments. The remaining arguments are returned. If the 130-- initialization of the toolkit fails for whatever reason, an exception 131-- is thrown. 132-- 133-- * Throws: @error \"Cannot initialize GUI.\"@ 134-- 135-- 136-- * If you want to use Gtk2Hs and in a multi-threaded application then it is your obligation 137-- to ensure that all calls to Gtk+ happen in a single OS thread. 138-- If you want to make calls to Gtk2Hs functions from a Haskell thread other 139-- than the one that calls this functions and 'mainGUI' then you will have to 140-- \'post\' your GUI actions to the main GUI thread. You can do this using 141-- 'postGUISync' or 'postGUIAsync'. See also 'threadsEnter'. 142-- 143initGUI :: IO [String] 144initGUI = do 145 initialise 146 when rtsSupportsBoundThreads initialiseGThreads 147 -- note: initizliseGThreads calls 'threadsEnter' 148 prog <- getProgName 149 args <- getArgs 150 let allArgs = (prog:args) 151 withMany withUTFString (map stringToGlib allArgs) $ \addrs -> 152 withArrayLen addrs $ \argc argv -> 153 with argv $ \argvp -> 154 with argc $ \argcp -> do 155 res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp) 156 if (toBool res) then do 157 argc' <- peek argcp 158 argv' <- peek argvp 159 _:addrs' <- peekArray argc' argv' -- drop the program name 160 mapM ((glibToString <$>) . peekUTFString) addrs' 161 else error "Cannot initialize GUI." 162 163-- g_thread_init aborts the whole program if it's called more than once so 164-- we've got to keep track of whether or not we've called it already. Sigh. 165-- 166foreign import ccall "hsgthread.h gtk2hs_threads_initialise" 167 initialiseGThreads :: IO () 168 169foreign import ccall "hsgthread.h gtk2hs_initialise" 170 initialise :: IO () 171 172-- | Post an action to be run in the main GUI thread. 173-- 174-- The current thread blocks until the action completes and the result is 175-- returned. 176-- 177postGUISync :: IO a -> IO a 178postGUISync action = do 179 resultVar <- newEmptyMVar 180 idleAdd (action >>= putMVar resultVar >> return False) priorityDefault 181 takeMVar resultVar 182 183-- | Post an action to be run in the main GUI thread. 184-- 185-- The current thread continues and does not wait for the result of the 186-- action. 187-- 188postGUIAsync :: IO () -> IO () 189postGUIAsync action = do 190 idleAdd (action >> return False) priorityDefault 191 return () 192 193-- | Acquire the global Gtk lock. 194-- 195-- * During normal operation, this lock is held by the thread from which all 196-- interaction with Gtk is performed. When calling 'mainGUI', the thread will 197-- release this global lock before it waits for user interaction. During this 198-- time it is, in principle, possible to use a different OS thread (any other 199-- Haskell thread that is bound to the Gtk OS thread will be blocked anyway) 200-- to interact with Gtk by explicitly acquiring the lock, calling Gtk functions 201-- and releasing the lock. However, the Gtk functions that are called from this 202-- different thread may not trigger any calls to the OS since this will 203-- lead to a crash on Windows (the Win32 API can only be used from a single 204-- thread). Since it is very hard to tell which function only interacts on 205-- Gtk data structures and which function call actual OS functions, it 206-- is best not to use this feature at all. A better way to perform updates 207-- in the background is to spawn a Haskell thread and to perform the update 208-- to Gtk widgets using 'postGUIAsync' or 'postGUISync'. These will execute 209-- their arguments from the main loop, that is, from the OS thread of Gtk, 210-- thereby ensuring that any Gtk and OS function can be called. 211-- 212{#fun gdk_threads_enter as threadsEnter {} -> `()' #} 213 214-- | Release the global Gtk lock. 215-- 216-- * The use of this function is not recommended. See 'threadsEnter'. 217-- 218{#fun unsafe gdk_threads_leave as threadsLeave {} -> `()' #} 219 220-- | Inquire the number of events pending on the event queue 221-- 222eventsPending :: IO Int 223eventsPending = liftM fromIntegral {#call events_pending#} 224 225-- | Run the Gtk+ main event loop. 226-- 227mainGUI :: IO () 228mainGUI = {#call main#} 229 230-- | Inquire the main loop level. 231-- 232-- * Callbacks that take more time to process can call 'mainIteration' to keep 233-- the GUI responsive. Each time the main loop is restarted this way, the main 234-- loop counter is increased. This function returns this counter. 235-- 236mainLevel :: IO Int 237mainLevel = liftM (toEnum.fromEnum) {#call unsafe main_level#} 238 239-- | Exit the main event loop. 240-- 241mainQuit :: IO () 242mainQuit = {#call main_quit#} 243 244-- | Process an event, block if necessary. 245-- 246-- * Returns @True@ if 'mainQuit' was called while processing the event. 247-- 248mainIteration :: IO Bool 249mainIteration = liftM toBool {#call main_iteration#} 250 251-- | Process a single event. 252-- 253-- * Called with @True@, this function behaves as 'mainIteration' in that it 254-- waits until an event is available for processing. It will return 255-- immediately, if passed @False@. 256-- 257-- * Returns @True@ if the 'mainQuit' was called while processing the event. 258-- 259mainIterationDo :: Bool -> IO Bool 260mainIterationDo blocking = 261 liftM toBool $ {#call main_iteration_do#} (fromBool blocking) 262 263-- | Processes a single GDK event. This is public only to allow filtering of events between GDK and 264-- GTK+. You will not usually need to call this function directly. 265-- 266-- While you should not call this function directly, you might want to know how exactly events are 267-- handled. So here is what this function does with the event: 268-- 269-- 1. Compress enter\/leave notify events. If the event passed build an enter\/leave pair together with 270-- the next event (peeked from GDK) both events are thrown away. This is to avoid a backlog of 271-- (de-)highlighting widgets crossed by the pointer. 272-- 273-- 2. Find the widget which got the event. If the widget can't be determined the event is thrown away 274-- unless it belongs to a INCR transaction. In that case it is passed to 275-- 'selectionIncrEvent'. 276-- 277-- 3. Then the event is passed on a stack so you can query the currently handled event with 278-- 'getCurrentEvent'. 279-- 280-- 4. The event is sent to a widget. If a grab is active all events for widgets that are not in the 281-- contained in the grab widget are sent to the latter with a few exceptions: 282-- 283-- * Deletion and destruction events are still sent to the event widget for obvious reasons. 284-- 285-- * Events which directly relate to the visual representation of the event widget. 286-- 287-- * Leave events are delivered to the event widget if there was an enter event delivered to it 288-- before without the paired leave event. 289-- 290-- * Drag events are not redirected because it is unclear what the semantics of that would be. 291-- 292-- Another point of interest might be that all key events are first passed through the key snooper 293-- functions if there are any. Read the description of 'keySnooperInstall' if you need this 294-- feature. 295-- 296-- 5. After finishing the delivery the event is popped from the event stack. 297mainDoEvent :: EventM t () 298mainDoEvent = do 299 ptr <- ask 300 liftIO $ {#call main_do_event #} (castPtr ptr) 301 302#if GTK_MAJOR_VERSION < 3 303-- | Trigger destruction of object in case the mainloop at level @mainLevel@ is quit. 304-- 305-- Removed in Gtk3. 306quitAddDestroy :: ObjectClass obj 307 => Int -- ^ @mainLevel@ Level of the mainloop which shall trigger the destruction. 308 -> obj -- ^ @object@ Object to be destroyed. 309 -> IO () 310quitAddDestroy mainLevel obj = 311 {#call quit_add_destroy #} 312 (fromIntegral mainLevel) 313 (toObject obj) 314 315-- | Registers a function to be called when an instance of the mainloop is left. 316-- 317-- Removed in Gtk3. 318quitAdd :: Int -- ^ @mainLevel@ Level at which termination the function shall be called. You can pass 0 here to have the function run at the current mainloop. 319 -> (IO Bool) -- ^ @function@ The function to call. This should return 'False' to be removed from the list of quit handlers. Otherwise the function might be called again. 320 -> IO Int -- ^ returns A handle for this quit handler (you need this for 'quitRemove') 321quitAdd mainLevel func = do 322 funcPtr <- mkGtkFunction $ \ _ -> 323 liftM fromBool func 324 liftM fromIntegral $ 325 {#call quit_add #} 326 (fromIntegral mainLevel) 327 funcPtr 328 nullPtr 329 330{#pointer GtkFunction#} 331 332foreign import ccall "wrapper" mkGtkFunction :: 333 (Ptr () -> IO {#type gboolean#}) -> IO GtkFunction 334 335-- | Removes a quit handler by its identifier. 336-- 337-- Removed in Gtk3. 338quitRemove :: Int -- ^ @quitHandlerId@ Identifier for the handler returned when installing it. 339 -> IO () 340quitRemove quitHandlerId = 341 {#call quit_remove #} (fromIntegral quitHandlerId) 342#endif 343 344-- | add a grab widget 345-- 346grabAdd :: WidgetClass wd => wd -> IO () 347grabAdd = {#call grab_add#} . toWidget 348 349-- | inquire current grab widget 350-- 351grabGetCurrent :: IO (Maybe Widget) 352grabGetCurrent = do 353 wPtr <- {#call grab_get_current#} 354 if (wPtr==nullPtr) then return Nothing else 355 liftM Just $ makeNewObject mkWidget (return wPtr) 356 357-- | remove a grab widget 358-- 359grabRemove :: WidgetClass w => w -> IO () 360grabRemove = {#call grab_remove#} . toWidget 361 362-- | Sets a function to be called at regular intervals, with the default 363-- priority 'priorityDefault'. The function is called repeatedly until it 364-- returns @False@, after which point the timeout function will not be called 365-- again. The first call to the function will be at the end of the first interval. 366-- 367-- Note that timeout functions may be delayed, due to the processing of other 368-- event sources. Thus they should not be relied on for precise timing. After 369-- each call to the timeout function, the time of the next timeout is 370-- recalculated based on the current time and the given interval (it does not 371-- try to 'catch up' time lost in delays). 372-- 373-- This function differs from 'ML.timeoutAdd' in that the action will 374-- be executed within the global Gtk+ lock. It is therefore possible to 375-- call Gtk+ functions from the action. 376-- 377timeoutAdd :: IO Bool -> Int -> IO HandlerId 378timeoutAdd fun msec = timeoutAddFull fun priorityDefault msec 379 380-- | Sets a function to be called at regular intervals, with the given 381-- priority. The function is called repeatedly until it returns @False@, after 382-- which point the timeout function will not be called again. The first call 383-- to the function will be at the end of the first interval. 384-- 385-- Note that timeout functions may be delayed, due to the processing of other 386-- event sources. Thus they should not be relied on for precise timing. After 387-- each call to the timeout function, the time of the next timeout is 388-- recalculated based on the current time and the given interval (it does not 389-- try to 'catch up' time lost in delays). 390-- 391-- This function differs from 'ML.timeoutAddFull' in that the action will 392-- be executed within the global Gtk+ lock. It is therefore possible to 393-- call Gtk+ functions from the action. 394-- 395timeoutAddFull :: IO Bool -> Priority -> Int -> IO HandlerId 396timeoutAddFull fun pri msec = 397 ML.timeoutAddFull (threadsEnter >> fun >>= \r -> threadsLeave >> return r) 398 pri msec 399 400-- | Add a callback that is called whenever the system is idle. 401-- 402-- * A priority can be specified via an integer. This should usually be 403-- 'priorityDefaultIdle'. 404-- 405-- * If the function returns @False@ it will be removed. 406-- 407-- This function differs from 'ML.idleAdd' in that the action will 408-- be executed within the global Gtk+ lock. It is therefore possible to 409-- call Gtk+ functions from the action. 410-- 411idleAdd :: IO Bool -> Priority -> IO HandlerId 412idleAdd fun pri = 413 ML.idleAdd (threadsEnter >> fun >>= \r -> threadsLeave >> return r) pri 414 415type FD = Int 416 417-- | Adds the file descriptor into the main event loop with the given priority. 418-- 419-- This function differs from 'ML.inputAdd' in that the action will 420-- be executed within the global Gtk+ lock. It is therefore possible to 421-- call Gtk+ functions from the action. 422-- 423inputAdd :: 424 FD -- ^ a file descriptor 425 -> [IOCondition] -- ^ the condition to watch for 426 -> Priority -- ^ the priority of the event source 427 -> IO Bool -- ^ the function to call when the condition is satisfied. 428 -- The function should return False if the event source 429 -- should be removed. 430 -> IO HandlerId -- ^ the event source id 431inputAdd fd conds pri fun = 432 ML.inputAdd fd conds pri (threadsEnter >> fun >>= \r -> threadsLeave >> return r) 433