{-# LANGUAGE DeriveDataTypeable #-}



module Eventloop.Types.Exception where





import Control.Exception

import Data.Typeable



import Eventloop.Types.Common

import Eventloop.Types.Events





data EventloopException = ShuttingDownException

                        | RequestShutdownException

                        | NoOutRouteException Out

                        | InitializationException EventloopModuleIdentifier SomeException

                        | RetrievingException EventloopModuleIdentifier SomeException

                        | ProcessingException ProcessingDescription EventloopModuleIdentifier SomeException

                        | EventloopException SomeException

                        | SendingException EventloopModuleIdentifier Out SomeException

                        | TeardownException EventloopModuleIdentifier SomeException

                        

                        deriving (Typeable)



instance Exception EventloopException





instance Show EventloopException where

    show ShuttingDownException    = exceptionMessage "A shutting down exception has been logged. This should not happen. Please contact an administrator."

                                                     []

    show RequestShutdownException = "System is shutting down..."

    

    show (NoOutRouteException out)  = exceptionMessage "Tried to route an Out even to a module but could not find an appropriate configured event sender."

                                                       [ ("Out event", show out)

                                                       ]

    show (InitializationException moduleId e) = exceptionMessage "Tried to initialize a module but something happened."

                                                                 [ ("Module", moduleId)

                                                                 , ("Exception", show e)

                                                                 ]

    show (RetrievingException moduleId e) = exceptionMessage "Tried to retrieve an In event from a module but something happened. The retriever has been shutdown."

                                                             [ ("Module", moduleId)

                                                             , ("Exception", show e)

                                                             ]

    show (ProcessingException processDesc moduleId e) = exceptionMessage "Tried to process an In\\Out event with a module but something happened."

                                                                         [ ("Processor", processDesc)

                                                                         , ("Module", moduleId)

                                                                         , ("Exception", show e)

                                                                         ]

    show (EventloopException e) = exceptionMessage "An exception occurred in your eventloop program."

                                                   [ ("Exception", show e)

                                                   ]

    show (SendingException moduleId out e) = exceptionMessage "Tried to send an Out event with a module but something happened."

                                                              [ ("Module", moduleId)

                                                              , ("Out event", show out)

                                                              , ("Exception", show e)

                                                              ]

    show (TeardownException moduleId e) = exceptionMessage "Tried to teardown a module but something happened."

                                                           [ ("Module", moduleId)

                                                           , ("Exception", show e)

                                                           ]



exceptionMessage :: String

                 -> [(String, String)]

                 -> String

exceptionMessage description fields

    = "- Exc: " ++ description ++ "\n" ++ (concat fieldLines)

    where

        fieldLines = map (\(field, value) -> "    " ++ field ++ ": " ++ value ++ "\n") fields