{-# 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.Base
import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
import Control.Monad.Trans (MonadTrans(..), MonadIO(..))
import Control.Monad.Trans.Control
import Data.Unique.Tag
import System.Console.Haskeline.MonadException (MonadException)

------------------------------------------------------------------------

-- | 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, MonadException, MonadConfig)

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 #-}