ObjectIO-1.0.1.1: Graphics/UI/ObjectIO/Process/Scheduler.hs
-- #hide
-----------------------------------------------------------------------------
-- |
-- Module : Process.Scheduler
-- Copyright : (c) Krasimir Andreev 2002
-- License : BSD-style
--
-- Maintainer : ka2_mail@yahoo.com
-- Stability : provisional
-- Portability : portable
--
-- Scheduler contains the process creation, termination, and handling functions.
--
-----------------------------------------------------------------------------
module Graphics.UI.ObjectIO.Process.Scheduler
( Context
, initContext
, handleEvents
, handleContextOSEvent
, addInteractiveProcess
, closeContext
, quitProcess
) where
import Graphics.UI.ObjectIO.CommonDef
import Graphics.UI.ObjectIO.Id
import Graphics.UI.ObjectIO.Process.IOState
import Graphics.UI.ObjectIO.StdProcessDef
import Graphics.UI.ObjectIO.Timer.Table(getTimeIntervalFromTimerTable)
import Graphics.UI.ObjectIO.OS.Event
import Graphics.UI.ObjectIO.OS.ClCrossCall_12 (osInitToolbox, osCloseToolbox)
import Data.IORef
schedulerFatalError :: String -> String -> x
schedulerFatalError rule message
= dumpFatalError rule "Process.Scheduler" message
-- Access functions on RuntimeState:
rsIsClosed :: RuntimeState -> Bool
rsIsClosed Closed = True
rsIsClosed _ = False
-- Starting an interactive process.
initContext :: [ProcessAttribute ps] -> ProcessInit ps -> ps -> DocumentInterface -> IO (Maybe Context)
initContext pAtts initIO ps xDI
= do {
initOK <- osInitToolbox; -- initialise toolbox
if initOK -- toolbox correctly initialised
then do {
context <- initialContext Nothing; -- initialise context
context1 <- createInitialProcess pAtts initIO ps xDI context; -- fork the initial interactive process
return (Just context1)
}
else return Nothing;
}
-- Handling events until termination of all interactive processes.
handleEvents :: Context -> IO ()
handleEvents context
= osHandleEvents
terminate
getosevent
getsleeptime
handlecontext
where
terminate :: IO Bool
terminate = do
iocontext <- readIORef context
return (ioContextEmptyProcesses iocontext)
getosevent :: IO (Maybe SchedulerEvent)
getosevent = do
iocontext <- readIORef context
let (event, iocontext1) = ioContextTakeEvent iocontext
writeIORef context iocontext1
return event
getsleeptime :: IO Int
getsleeptime = do
iocontext <- readIORef context
let tt = ioContextGetTimerTable iocontext
let maybe_sleep = getTimeIntervalFromTimerTable tt
let sleep = maybe osLongSleep id maybe_sleep
return sleep
handlecontext = handleContextOSEvent context
-- Closing a final context.
closeContext :: Context -> IO ()
closeContext context = do
iocontext <- readIORef context;
(if ioContextEmptyProcesses iocontext then return ()
else schedulerFatalError "closeContext" "not a final Context")
osCloseToolbox
return ()
handleContextOSEvent :: Context -> SchedulerEvent -> IO [Int]
handleContextOSEvent context schedulerEvent = do
iocontext <- readIORef context
let processes = ioContextGetProcesses iocontext
schedulerEvent1 <- letProcessesFilterEvent context schedulerEvent processes
let replyToOS = case schedulerEvent1 of
(ScheduleOSEvent _ reply) -> reply
_ -> []
return replyToOS
where
letProcessesFilterEvent :: Context -> SchedulerEvent -> [PSt] -> IO SchedulerEvent
letProcessesFilterEvent context schedulerEvent [] = return schedulerEvent
letProcessesFilterEvent context schedulerEvent (p@(PSt st ioSt) : ps)
| ioStClosed ioSt = letProcessesFilterEvent context schedulerEvent ps
| otherwise = do
(ok,maybeDeviceEvent,schedulerEvent1) <- processEventFilter ioSt schedulerEvent
(if not ok
then letProcessesFilterEvent context schedulerEvent1 ps
else case maybeDeviceEvent of
Nothing -> return schedulerEvent1
Just (device, deviceEvent) -> do
p <- handleEventForProcess device deviceEvent p
modifyIORef context (ioContextSetProcess p)
return schedulerEvent1)
handleEventForProcess :: Device -> DeviceEvent -> PSt -> IO PSt
handleEventForProcess device schedulerEvent (PSt ps ioState)
= do {
(ps1,ioState2) <- fromGUI (initIO ps) ioState1;
if ioStClosed ioState2
then return (PSt ps1 ioState2)
else let deviceFunctions = ioStGetDeviceFunctions ioState2
(found,df) = cselect (\df -> dDevice df == device) undefined deviceFunctions
in
if not found
then schedulerFatalError "ioProcess" "could not find Device to handle DeviceEvent"
else do
(ps2,ioState3) <- fromGUI (catchGUI (dDoIO df schedulerEvent ps1) handleErrorReport) ioState2
return (PSt ps2 ioState3)
}
where
initIO = ioStGetInitIO ioState
ioState1 = ioStSetInitIO (return) ioState
createInitialProcess :: [ProcessAttribute ps] -> ProcessInit ps -> ps -> DocumentInterface -> Context -> IO Context
createInitialProcess pAtts initIO ps xDI context = do
iocontext <- readIORef context
let (ioId,iocontext1) = ioContextNewMaxIONr iocontext
newIOSt <- emptyIOSt ioId xDI pAtts initIO context;
let p = PSt ps newIOSt
let iocontext2 = ioContextSetProcess p iocontext1
writeIORef context iocontext2
p <- handleEventForProcess ProcessDevice ProcessInitialise p -- Make sure the interactive process gets started
modifyIORef context (ioContextSetProcess p)
return context
addInteractiveProcess :: [ProcessAttribute ps'] -> ProcessInit ps' -> ps' -> DocumentInterface -> GUI ps ()
addInteractiveProcess pAtts initIO ps' xDI = do
ioId <- ioStNewMaxIONr
context <- accIOEnv ioStGetContext
newIOSt <- liftIO (emptyIOSt ioId xDI pAtts initIO context)
let p = PSt ps' newIOSt
liftIO (modifyIORef context (ioContextSetProcess p))
p <- liftIO (handleEventForProcess ProcessDevice ProcessInitialise p)
liftIO (modifyIORef context (ioContextSetProcess p))
{- processEventFilter passes the current Device dEvent DeviceFunctions to the
argument SchedulerEvent to determine if this event should be handled by this
process.
-}
processEventFilter :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEventInfo,SchedulerEvent)
processEventFilter ioState schedulerEvent
| ioStClosed ioState = return (False,Nothing,schedulerEvent)
| otherwise = filterEventForDevices eventFunctions schedulerEvent ioState
where
eventFunctions = [(dDevice df,dEvent df) | df <- ioStGetDeviceFunctions ioState]
filterEventForDevices :: [(Device,EventFunction ps)] -> SchedulerEvent -> IOSt ps
-> IO (Bool,Maybe DeviceEventInfo,SchedulerEvent)
filterEventForDevices ((device,mapDeviceEvent):mapDeviceEvents) schedulerEvent ioState
= do {
(forThisDevice,okDeviceEvent,schedulerEvent1) <- mapDeviceEvent ioState schedulerEvent;
if not forThisDevice
then filterEventForDevices mapDeviceEvents schedulerEvent1 ioState
else return ( forThisDevice
, case okDeviceEvent of
Just deviceEvent -> Just (device,deviceEvent)
nothing -> Nothing
, schedulerEvent1
)
}
filterEventForDevices _ schedulerEvent _
= return (False,Nothing,schedulerEvent)
{- Quit this interactive process.
Quitting a process involves the following:
- Set the RuntimeState to Closed (quitProcess is the only function that does this)
- Close all devices
- Remove the process from the Context
-}
quitProcess :: ps -> GUI ps ps
quitProcess ps
= do {
rs <- accIOEnv ioStGetRuntimeState;
if rsIsClosed rs
then return ps
else do {
deviceFunctions <- accIOEnv ioStGetDeviceFunctions;
ps1 <- seqListM [dClose df | df<-deviceFunctions] ps;
osdInfo <- accIOEnv ioStGetOSDInfo;
liftIO (osCloseOSDInfo osdInfo);
appIOEnv (ioStSetRuntimeState Closed);
-- This part is new: remove the process from the context
accIOEnv ioStGetIOId >>= ioStRemoveProcess;
return ps1
}
}
where
seqListM :: [ps -> GUI ps ps] -> ps -> GUI ps ps
seqListM (m:ms) ps
= m ps >>= (\ps -> seqListM ms ps)
seqListM _ ps
= return ps