content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  module Lambdabot.Module
      ( Module(..)
      , newModule
      
      , ModuleID
      , newModuleID
      
      , ModuleInfo(..)
      , ModuleT
      , runModuleT
      ) where
  
  import qualified Lambdabot.Command as Cmd
  import Lambdabot.Config
  import Lambdabot.Logging
  import {-# SOURCE #-} Lambdabot.Monad
  import Lambdabot.Util.Serial
  
  import Control.Applicative
  import Control.Concurrent (MVar)
  import Control.Monad
  import Control.Monad.Fail (MonadFail)
  import qualified Control.Monad.Fail
  import Control.Monad.Base
  import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
  import Control.Monad.Trans (MonadTrans(..), MonadIO(..))
  import Control.Monad.Trans.Control
  import Data.Unique.Tag
  import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
  #if !defined(MIN_VERSION_haskeline) || !MIN_VERSION_haskeline(0,8,0)
  import System.Console.Haskeline.MonadException (MonadException)
  #endif
  
  ------------------------------------------------------------------------
  
  -- | The Module type class.
  data Module st = Module {
          -- | If the module wants its state to be saved, this function should
          --   return a Serial.
          --
          --   The default implementation returns Nothing.
          moduleSerialize :: !(Maybe (Serial st)),
  
          -- | If the module maintains state, this method specifies the default state
          --   (for example in case the state can't be read from a state).
          --
          --   The default implementation returns an error and assumes the state is
          --   never accessed.
          moduleDefState  :: !(LB st),
  
          -- | Is the module sticky? Sticky modules (as well as static ones) can't be
          --   unloaded. By default, modules are not sticky.
          moduleSticky    :: !Bool,
  
          -- | The commands the module listens to.
          moduleCmds      :: !(ModuleT st LB [Cmd.Command (ModuleT st LB)]),
  
          -- | Initialize the module. The default implementation does nothing.
          moduleInit      :: !(ModuleT st LB ()),
  
          -- | Finalize the module. The default implementation does nothing.
          moduleExit      :: !(ModuleT st LB ()),
  
          -- | Process contextual input. A plugin that implements 'contextual'
          -- is able to respond to text not part of a normal command.
          contextual
              :: !(String                           --  the text
               -> Cmd.Cmd (ModuleT st LB) ())       -- ^ the action
      }
  
  ------------------------------------------------------------------------
  
  newModule :: Module st
  newModule = Module
      { contextual         = \_ -> return ()
      , moduleCmds         = return []
      , moduleExit         = return ()
      , moduleInit         = return ()
      , moduleSticky       = False
      , moduleSerialize    = Nothing
      , moduleDefState     = return $ error "state not initialized"
      }
  
  newtype ModuleID st = ModuleID (Tag RealWorld st)
      deriving (GEq, GCompare)
  
  newModuleID :: IO (ModuleID st)
  newModuleID = ModuleID <$> newTag
  
  -- |Info about a running module.
  data ModuleInfo st = ModuleInfo
      { moduleName   :: !String
      , moduleID     :: !(ModuleID st)
      , theModule    :: !(Module st)
      , moduleState  :: !(MVar st)
      }
  
  -- | This transformer encodes the additional information a module might
  --   need to access its name or its state.
  newtype ModuleT st m a = ModuleT { unModuleT :: ReaderT (ModuleInfo st) m a }
      deriving (Applicative, Functor, Monad, MonadReader (ModuleInfo st), 
          MonadTrans, MonadIO, MonadConfig, MonadFail,
  #if !defined(MIN_VERSION_haskeline) || !MIN_VERSION_haskeline(0,8,0)
          MonadException,
  #endif
          MonadThrow, MonadCatch, MonadMask)
  
  runModuleT :: ModuleT st m a -> ModuleInfo st -> m a
  runModuleT = runReaderT . unModuleT
  
  instance MonadLogging m => MonadLogging (ModuleT st m) where
      getCurrentLogger = do
          parent <- lift getCurrentLogger
          self   <- asks moduleName
          return (parent ++ ["Plugin", self])
      logM a b c = lift (logM a b c)
  
  instance MonadBase b m => MonadBase b (ModuleT st m) where
      liftBase = lift . liftBase
  
  instance MonadTransControl (ModuleT st) where
      type StT (ModuleT st) a = a
      liftWith f = do
          r <- ModuleT ask
          lift $ f $ \t -> runModuleT t r
      restoreT = lift
      {-# INLINE liftWith #-}
      {-# INLINE restoreT #-}
  
  instance MonadBaseControl b m => MonadBaseControl b (ModuleT st m) where
      type StM (ModuleT st m) a = ComposeSt (ModuleT st) m a
      liftBaseWith = defaultLiftBaseWith
      restoreM     = defaultRestoreM
      {-# INLINE liftBaseWith #-}
      {-# INLINE restoreM #-}
  