eventloop-0.8.2.8: src/Eventloop/System/TeardownThread.hs

module Eventloop.System.TeardownThread
    ( startTeardowning
    ) where

import Control.Exception
import Control.Concurrent.ExceptionCollection
import Control.Concurrent.STM

import Eventloop.Types.Exception
import Eventloop.Types.System


startTeardowning :: EventloopSystemConfiguration progstateT
                 -> IO ()
startTeardowning systemConfig
    = do
        sharedIO <- readTVarIO sharedIOStateT_
        sharedIO' <- teardownModules sharedConst sharedIO systemConfig moduleConfigs_
        atomically $ writeTVar sharedIOStateT_ sharedIO'
    where
        sharedConst = sharedIOConstants systemConfig
        sharedIOStateT_ = sharedIOStateT systemConfig
        moduleConfigs_ = moduleConfigs systemConfig


teardownModules :: SharedIOConstants
                -> SharedIOState
                -> EventloopSystemConfiguration progstateT
                -> [EventloopModuleConfiguration]
                -> IO SharedIOState
teardownModules _ sharedIO _ [] = return sharedIO
teardownModules sharedConst sharedIO systemConfig (moduleConfig:configs)
    = do
        sharedIO' <- teardownModule sharedConst sharedIO systemConfig moduleConfig
        teardownModules sharedConst sharedIO' systemConfig configs


teardownModule :: SharedIOConstants
               -> SharedIOState
               -> EventloopSystemConfiguration progstateT
               -> EventloopModuleConfiguration
               -> IO SharedIOState
teardownModule sharedConst sharedIO systemConfig moduleConfig
    = case (teardownM moduleConfig) of
        Nothing         -> return (sharedIO)
        (Just teardown) -> handle
                ( \exception -> do
                    logException (exceptions systemConfig) (toException $ TeardownException moduleId_ exception)
                    return sharedIO
                )
               ( do
                    ioState <- readTVarIO ioStateT_
                    teardown sharedConst sharedIO ioConst ioState
               )
    where
        moduleId_ = moduleId moduleConfig
        ioConst = ioConstants moduleConfig
        ioStateT_ = ioStateT moduleConfig