module Eventloop.EventloopCore
( startMainloop
) where
import Eventloop.Types.EventTypes
import Data.Maybe
import Control.Exception
import Control.Concurrent
type HasToStop = Bool
type PhaseDescription = [Char]
type ProcessingDescription = [Char]
putStrLnIf :: Bool -> String -> IO ()
putStrLnIf doIf str | doIf = putStrLn str
| otherwise = return ()
startMainloop :: EventloopConfiguration progstateT -> IO ()
startMainloop eventloopConfig
= do
(eventloopConfig', initHasToStop) <- initialisePhase eventloopConfig
case initHasToStop of
True -> do
putStrLn "Something went wrong during initialisation"
(_, emTeardownHasToStop) <- teardownPhase eventloopConfig'
putStrLnIf emTeardownHasToStop "Something also went wrong at teardown"
False -> do
eventloopConfig'' <- startMainloopWithStart eventloopConfig'
(eventloopConfig''', teardownHasToStop) <- teardownPhase eventloopConfig''
putStrLnIf teardownHasToStop "Something went wrong during teardown"
putStrLn "Stopping system..."
initialisePhase :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop)
initialisePhase eventloopConfig
= do
let
sharedIO = sharedIOState eventloopConfig
moduleConfigs = moduleConfigurations eventloopConfig
(sharedIO', moduleConfigs', hasToStop) <- handlePhaseModuleConfigurations sharedIO moduleConfigs initializer "initialisation"
return (eventloopConfig {sharedIOState = sharedIO', moduleConfigurations = moduleConfigs'}, hasToStop)
teardownPhase :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop)
teardownPhase eventloopConfig
= do
let
sharedIO = sharedIOState eventloopConfig
moduleConfigs = moduleConfigurations eventloopConfig
(sharedIO', moduleConfigs', hasToStop) <- handlePhaseModuleConfigurations sharedIO moduleConfigs teardown "teardown"
return (eventloopConfig {sharedIOState = sharedIO', moduleConfigurations = moduleConfigs'}, hasToStop)
handlePhaseModuleConfigurations :: SharedIOState
-> [EventloopModuleConfiguration]
-> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState)))
-> PhaseDescription
-> IO (SharedIOState, [EventloopModuleConfiguration], HasToStop)
handlePhaseModuleConfigurations sharedIO [] _ _ = return (sharedIO, [], False)
handlePhaseModuleConfigurations sharedIO (mc:mcs) phaseFunc phaseDescription
= do
(sharedIO', mc', hasToStop) <- handlePhaseModuleConfiguration sharedIO mc phaseFunc phaseDescription
(sharedIO'', mcs', hasToStopOther) <- handlePhaseModuleConfigurations sharedIO' mcs phaseFunc phaseDescription
return (sharedIO'', mc':mcs', hasToStop || hasToStopOther)
handlePhaseModuleConfiguration :: SharedIOState
-> EventloopModuleConfiguration
-> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState)))
-> PhaseDescription
-> IO (SharedIOState, EventloopModuleConfiguration, HasToStop)
handlePhaseModuleConfiguration sharedIO mc phaseFunc phaseDescription
= do
let
name = moduleIdentifier mc
modulePhaseFuncM = phaseFunc mc
moduleIOState = iostate mc
handle
( \exception -> do
putStrLn ("Exception during " ++ phaseDescription ++ " in module " ++ name)
putStrLn (" " ++ show (exception :: SomeException))
return (sharedIO, mc, True)
)
( case modulePhaseFuncM of
(Just modulePhaseFunc) -> do
(sharedIO', moduleIOState') <- modulePhaseFunc sharedIO moduleIOState
return (sharedIO', mc {iostate=moduleIOState'}, False)
Nothing -> return (sharedIO, mc, False)
)
startMainloopWithStart :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT)
startMainloopWithStart ec = handleMainloopUsingSource (return (ec, [Start], False))
handleMainloopUsingSource :: IO (EventloopConfiguration progstateT, [In], HasToStop) -> IO (EventloopConfiguration progstateT)
handleMainloopUsingSource source = do
(ec', inEvents, hasToStopSource) <- source
case hasToStopSource of
True -> return ec'
False -> do
(ec'', inEvents', hasToStopPreProcess) <- processEvents "preprocess" ec' preprocessor inEvents
case hasToStopPreProcess of
True -> return ec''
False -> do
(ec''', hasToStopInEvents) <- handleInEvents inEvents' ec''
case hasToStopInEvents of
True -> return ec'''
False -> handleMainloopUsingSource (receiveEvents ec''')
receiveEvents :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, [In], HasToStop)
receiveEvents eventloopConfig = do
let
(moduleConfig:mcs) = moduleConfigurations eventloopConfig
eventRetrieverM = eventRetriever moduleConfig
sharedIO = sharedIOState eventloopConfig
checkNextModule sio mc = do
threadDelay 100000
receiveEvents (eventloopConfig {moduleConfigurations=(mcs++[mc]), sharedIOState=sio})
case eventRetrieverM of
Nothing -> checkNextModule sharedIO moduleConfig
Just er -> handle
( \exception -> do
putStrLn "Exception when receiving events"
putStrLn (" " ++ show (exception :: SomeException))
return (eventloopConfig, [], True)
)
( do
(sharedIO', iostate', inEvents) <- er sharedIO (iostate moduleConfig)
let
moduleConfig' = moduleConfig {iostate=iostate'}
case inEvents of
[] -> checkNextModule sharedIO' moduleConfig'
_ -> return (eventloopConfig {moduleConfigurations=(mcs++[moduleConfig']), sharedIOState=sharedIO'}, inEvents, False)
)
handleInEvents :: [In] -> EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop)
handleInEvents [] ec
= return (ec, False)
handleInEvents (i:is) ec
= do
(ec', hasToStop) <- handleSingleInEvent i ec
case hasToStop of
True -> return (ec', True)
False -> handleInEvents is ec'
handleSingleInEvent :: In -> EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop)
handleSingleInEvent inEvent ec
= handle
( \exception -> do
putStrLn "Exception in eventloop function"
putStrLn (" " ++ show (exception :: SomeException))
return (ec, True)
)
( do
let
(ec', outEvents) = doEventloop ec inEvent
(ec'', outEvents', hasToStopPostProcess) <- processEvents "postprocess" ec' postprocessor outEvents
case hasToStopPostProcess of
False -> sendOutEvents ec'' outEvents'
True -> do
putStrLn "Exception when postprocessing outEvents"
return (ec'', True)
)
doEventloop :: EventloopConfiguration progstateT -> In -> (EventloopConfiguration progstateT, [Out])
doEventloop ec inEvent = (ec', outEvents)
where
(progState', outEvents) = (eventloopFunc ec) (progState ec) inEvent
ec' = ec {progState = progState'}
sendOutEvents :: EventloopConfiguration progstateT -> [Out] -> IO (EventloopConfiguration progstateT, HasToStop)
sendOutEvents ec [] = return (ec, False)
sendOutEvents ec (Stop:_) = return (ec, True)
sendOutEvents ec (out:outs)
= handle
( \exception -> do
putStrLn "Exception when sending outEvent"
putStrLn (" OutEvent: " ++ show out)
putStrLn (" Exception: " ++ show (exception :: SomeException))
return (ec, True)
)
( do
let
moduleConfigs = moduleConfigurations ec
moduleToSendWith = (outRouter ec) out
sharedIO = sharedIOState ec
(sharedIO', moduleConfigs') <- sendOutEventWithModule sharedIO moduleToSendWith out moduleConfigs
let
ec' = ec {sharedIOState=sharedIO', moduleConfigurations=moduleConfigs'}
sendOutEvents ec' outs
)
sendOutEventWithModule :: SharedIOState -> EventloopModuleIdentifier -> Out -> [EventloopModuleConfiguration] -> IO (SharedIOState, [EventloopModuleConfiguration])
sendOutEventWithModule _ sendWith out []
= error ("Could not send outEvent because module is not configured. Wanted to use module: " ++ (show sendWith) ++ " Event: " ++ (show out))
sendOutEventWithModule sharedIO sendWith out (mc:mcs)
| sendWith == moduleId = case eventSenderFuncM of
Nothing -> error ("Could not send outEvent because module " ++ (show sendWith) ++ " does not have an eventsender configured")
Just eventSenderFunc -> do
(sharedIO', moduleIOState') <- eventSenderFunc sharedIO moduleIOState out
return (sharedIO', (mc {iostate=moduleIOState'}):mcs)
| otherwise = do
(sharedIO', mcs') <- sendOutEventWithModule sharedIO sendWith out mcs
return (sharedIO, mc:mcs')
where
moduleId = moduleIdentifier mc
eventSenderFuncM = eventSender mc
moduleIOState = iostate mc
processEventModule :: SharedIOState
-> EventloopModuleConfiguration
-> (EventloopModuleConfiguration
-> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])))
-> event
-> IO (SharedIOState, EventloopModuleConfiguration, [event])
processEventModule sharedIO eventloopModuleConfig getFunc event = do
let
processFuncM = getFunc eventloopModuleConfig
case processFuncM of
Nothing -> return (sharedIO, eventloopModuleConfig, [event])
Just processFunc -> do
(sharedIO', iostate', events) <- processFunc sharedIO (iostate eventloopModuleConfig) event
return (sharedIO', eventloopModuleConfig {iostate=iostate'}, events)
processEventsModules :: ProcessingDescription
-> SharedIOState
-> [EventloopModuleConfiguration]
-> (EventloopModuleConfiguration
-> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])))
-> [event]
-> IO (SharedIOState, [EventloopModuleConfiguration], [event], HasToStop)
processEventsModules _ sharedIO mcs _ []
= return (sharedIO, mcs, [], False)
processEventsModules _ sharedIO [] _ events
= return (sharedIO, [], events, False)
processEventsModules processingDescription sharedIO (moduleConfig:mcs) getFunc (event:events)
= handle
( \exception -> do
putStrLn ("Exception when " ++ (show processingDescription))
putStrLn (show (exception :: SomeException))
return (sharedIO, moduleConfig:mcs, event:events, True)
)
( do
(sharedIO', moduleConfig', moreEvents) <- processEventModule sharedIO moduleConfig getFunc event
(sharedIO'', mcs', moreEvents', hasToStopResultingEvents) <- processEventsModules processingDescription sharedIO' mcs getFunc moreEvents
(sharedIO''', mcs'', events', hasToStopOtherEvents) <- processEventsModules processingDescription sharedIO'' (moduleConfig':mcs') getFunc events
return (sharedIO''', mcs'', moreEvents' ++ events', hasToStopResultingEvents || hasToStopOtherEvents)
)
processEvents :: ProcessingDescription
-> EventloopConfiguration progstateT
-> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])))
-> [event]
-> IO (EventloopConfiguration progstateT, [event], HasToStop)
processEvents processingDescription eventloopConfig getFunc events
= do
let
moduleConfigs = moduleConfigurations eventloopConfig
sharedIO = sharedIOState eventloopConfig
(sharedIO', moduleConfigs', events', hasToStop) <- processEventsModules processingDescription sharedIO moduleConfigs getFunc events
return (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}, events', hasToStop)