content: -- | Core Process code
  {-# LANGUAGE ExistentialQuantification, FlexibleInstances,
               GeneralizedNewtypeDeriving,
               ScopedTypeVariables,
               DeriveDataTypeable,
               MultiParamTypeClasses, CPP #-}
  
  module Process (
      -- * Types
        Process
      -- * Interface
      , runP
      , spawnP
      , catchP
      , cleanupP
      , stopP
      -- * Log Interface
      , Logging(..)
      , logP
      , infoP
      , debugP
      , warningP
      , criticalP
      , errorP
      )
  where
  
  import Control.Applicative
  import Control.Concurrent
  import Control.Exception
  
  import Control.Monad.Reader
  import Control.Monad.State.Strict
  
  import Data.Typeable
  
  import Prelude hiding (log)
  
  import System.Log.Logger
  
  -- | A @Process a b c@ is the type of processes with access to configuration data @a@, state @b@
  --   returning values of type @c@. Usually, the read-only data are configuration parameters and
  --   channels, and the state the internal process state. It is implemented by means of a transformer
  --   stack on top of IO.
  newtype Process a b c = Process (ReaderT a (StateT b IO) c)
    deriving (Functor, Applicative, Monad, MonadIO, MonadState b, MonadReader a)
  
  data StopException = StopException
    deriving (Show, Typeable)
  
  instance Exception StopException
  
  stopP :: Process a b c
  stopP = throw StopException
  
  -- | Run the process monad given a configuation of type @a@ and a initial state of type @b@
  runP :: a -> b -> Process a b c -> IO (c, b)
  runP c st (Process p) = runStateT (runReaderT p c) st
  
  -- | Spawn and run a process monad
  spawnP :: a -> b -> Process a b () -> IO ThreadId
  spawnP c st p = forkIO proc
    where proc = runP c st p >> return ()
  
  -- | Run the process monad for its side effect, with a stopHandler if exceptions
  --   are raised in the process
  catchP :: Logging a => Process a b () -> Process a b () -> Process a b ()
  catchP proc stopH = cleanupP proc stopH (return ())
  
  -- | Run the process monad for its side effect. @cleanupP p sh ch@ describes to
  --   run @p@. If @p@ dies by a kill from a supervisor, run @ch@. Otherwise it runs
  --   @ch >> sh@ on death.
  cleanupP :: Logging a => Process a b () -> Process a b () -> Process a b () -> Process a b ()
  cleanupP proc stopH cleanupH = do
    st <- get
    c  <- ask
    (a, s') <- liftIO $ runP c st proc `catches`
                  [ Handler (\ThreadKilled ->
                      runP c st ( do infoP $ "Process Terminated by Supervisor"
                                     cleanupH ))
                  , Handler (\StopException ->
                       runP c st (do infoP $ "Process Terminating gracefully"
                                     cleanupH >> stopH)) -- This one is ok
                  , Handler (\(ex :: SomeException) ->
                      runP c st (do criticalP $ "Process exiting due to ex: " ++ show ex
                                    cleanupH >> stopH))
                  ]
    put s'
    return a
  
  ------ LOGGING
  
  --
  -- | The class of types where we have a logger inside them somewhere
  class Logging a where
    -- | Returns a channel for logging and an Identifying string to use
    logName :: a -> String
  
  logP :: Logging a => Priority -> String -> Process a b ()
  logP prio msg = do
      n <- asks logName
      liftIO $ logM n prio (n ++ ":\t" ++ msg)
  
  infoP, debugP, criticalP, warningP, errorP :: Logging a => String -> Process a b ()
  infoP  = logP INFO
  #ifdef NDEBUG
  debugP _ = return ()
  #else
  debugP = logP DEBUG
  #endif
  criticalP = logP CRITICAL
  warningP  = logP WARNING
  errorP    = logP ERROR
  
  