module Eventloop.EventloopCore
( startMainloop
) where
import Eventloop.Types.EventTypes
import Data.Maybe
startMainloop :: EventloopConfiguration progstateT -> IO ()
startMainloop eventloopConfig@(EventloopConfiguration { moduleConfigurations = moduleConfigs
, sharedIOState = sharedIO
}) = do
(sharedIO', moduleConfigs') <- withIOStateModules sharedIO initializer moduleConfigs
eventloopConfig'' <- startMainloopWithStart (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'})
let
moduleConfigs'' = moduleConfigurations eventloopConfig''
sharedIO'' = sharedIOState eventloopConfig''
(sharedIO''', moduleStates''') <- withIOStateModules sharedIO'' teardown moduleConfigs''
return ()
withIOStateModules :: SharedIOState ->
(EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) ->
[EventloopModuleConfiguration] ->
IO (SharedIOState, [EventloopModuleConfiguration])
withIOStateModules sharedIO _ [] = return (sharedIO, [])
withIOStateModules sharedIO getFunc (mc:mcs) = do
(sharedIO', mc') <- withIOStateModule sharedIO getFunc mc
(sharedIO'', mcs') <- withIOStateModules sharedIO' getFunc mcs
return (sharedIO'', mc':mcs')
withIOStateModule :: SharedIOState ->
(EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) ->
EventloopModuleConfiguration ->
IO (SharedIOState, EventloopModuleConfiguration)
withIOStateModule sharedIO getFunc mc = case (getFunc mc) of
Nothing -> return (sharedIO, mc)
Just (func) -> do
(sharedIO', iostate') <- func sharedIO (iostate mc)
return (sharedIO', mc {iostate=iostate'})
startMainloopWithStart :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT)
startMainloopWithStart ec = handleMainloopUsingSource (return (ec, [Start]))
handleMainloopUsingSource :: IO (EventloopConfiguration progstateT, [In]) -> IO (EventloopConfiguration progstateT)
handleMainloopUsingSource source = do
(ec', inEvents) <- source
(ec'', inEvents') <- processEvents ec' preprocessor inEvents
(ec'', stopFound) <- foldl (>>=) (return (ec'', False)) (map handleSingleInEvent inEvents')
if stopFound
then (return ec'')
else (handleMainloopUsingSource (receiveEvents ec''))
receiveEvents :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, [In])
receiveEvents eventloopConfig = do
let
(moduleConfig:mcs) = moduleConfigurations eventloopConfig
eventRetrieverM = eventRetriever moduleConfig
sharedIO = sharedIOState eventloopConfig
checkNextModule sio mc = receiveEvents (eventloopConfig {moduleConfigurations=(mcs++[mc]), sharedIOState=sio})
case eventRetrieverM of
Nothing -> checkNextModule sharedIO moduleConfig
Just er -> 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)
handleSingleInEvent :: In -> (EventloopConfiguration progstateT, Bool) -> IO (EventloopConfiguration progstateT, Bool)
handleSingleInEvent inEvent (ec, stopFound) | stopFound = return (ec, stopFound)
| otherwise = do
let
(ec', outEvents) = doEventloop ec inEvent
(ec'', outEvents') <- processEvents ec' postprocessor outEvents
sendOutEvents ec'' outEvents'
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, Bool)
sendOutEvents ec [] = return (ec, False)
sendOutEvents ec (Stop:outs) = return (ec, True)
sendOutEvents ec (out:outs) = case sendModuleConfigM of
Nothing -> error ("Could not send outEvent because module is not configured. Wanted to use module: " ++ (show moduleToRoute) ++ " Event: " ++ (show out))
Just sendModuleConfig -> do
let
eventSenderFuncM = eventSender sendModuleConfig
moduleIOState = iostate sendModuleConfig
case eventSenderFuncM of
Nothing -> error ("Could not send outEvent because module eventsender is not configured. Using module: " ++ (show moduleToRoute) ++ " Event: " ++ (show out))
Just eventSenderFunc -> do
(sharedIO', moduleIOState') <- eventSenderFunc sharedIO moduleIOState out
let
sendModuleConfig' = sendModuleConfig {iostate=moduleIOState'}
ec' = ec {moduleConfigurations=(replaceModuleConfiguration sendModuleConfig' moduleConfigs), sharedIOState=sharedIO'}
sendOutEvents ec' outs
where
sharedIO = sharedIOState ec
moduleToRoute = (outRouter ec) out
moduleConfigs = moduleConfigurations ec
sendModuleConfigM = findModuleConfiguration moduleToRoute moduleConfigs
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 :: SharedIOState ->
[EventloopModuleConfiguration] ->
(EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) ->
[event] ->
IO (SharedIOState, [EventloopModuleConfiguration], [event])
processEventsModules sharedIO mcs _ [] = return (sharedIO, mcs, [])
processEventsModules sharedIO [] _ events = return (sharedIO, [], events)
processEventsModules sharedIO (moduleConfig:mcs) getFunc (event:events) = do
(sharedIO', moduleConfig', moreEvents) <- processEventModule sharedIO moduleConfig getFunc event
(sharedIO'', mcs', moreEvents') <- processEventsModules sharedIO' mcs getFunc moreEvents
(sharedIO''', mcs'', events') <- processEventsModules sharedIO'' (moduleConfig':mcs') getFunc events
return (sharedIO''', mcs'', moreEvents' ++ events')
processEvents :: EventloopConfiguration progstateT ->
(EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) ->
[event] ->
IO (EventloopConfiguration progstateT, [event])
processEvents eventloopConfig getFunc events = do
let
moduleConfigs = moduleConfigurations eventloopConfig
sharedIO = sharedIOState eventloopConfig
(sharedIO', moduleConfigs', events') <- processEventsModules sharedIO moduleConfigs getFunc events
return (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}, events')
findModuleConfiguration :: EventloopModuleIdentifier -> [EventloopModuleConfiguration] -> Maybe EventloopModuleConfiguration
findModuleConfiguration _ [] = Nothing
findModuleConfiguration id (mc:mcs) | id == moduleId = Just mc
| otherwise = findModuleConfiguration id mcs
where
moduleId = moduleIdentifier mc
replaceModuleConfiguration :: EventloopModuleConfiguration -> [EventloopModuleConfiguration] -> [EventloopModuleConfiguration]
replaceModuleConfiguration _ [] = []
replaceModuleConfiguration mc (mc':mcs) | moduleIdentifier mc == moduleIdentifier mc' = (mc:mcs)
| otherwise = (mc':(replaceModuleConfiguration mc mcs))