content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  module Lambdabot.Monad
      ( IRCRState
      , initRoState
      , reportInitDone
      , waitForInit
      , waitForQuit
      
      , Callback
      , OutputFilter
      , Server
      , IRCRWState(..)
      , initRwState
      
      , LB
      , runLB
      
      , MonadLB(..)
      
      , registerModule
      , registerCommands
      , registerCallback
      , registerOutputFilter
      , unregisterModule
      
      , registerServer
      , unregisterServer
      , send
      , received
      
      , applyOutputFilters
      
      , inModuleNamed
      , inModuleWithID
      
      , withCommand
      
      , listModules
      , withAllModules
      ) where
  
  import           Lambdabot.ChanName
  import           Lambdabot.Command
  import           Lambdabot.Config
  import           Lambdabot.Config.Core
  import           Lambdabot.IRC
  import           Lambdabot.Logging
  import           Lambdabot.Module
  import qualified Lambdabot.Message as Msg
  import           Lambdabot.Nick
  import           Lambdabot.Util
  
  import Control.Applicative
  import Control.Concurrent.Lifted
  import Control.Exception.Lifted as E (catch)
  import Control.Monad.Fail (MonadFail)
  import qualified Control.Monad.Fail
  import Control.Monad
  import Control.Monad.Base
  import Control.Monad.Identity
  import Control.Monad.Reader
  import Control.Monad.State
  import Control.Monad.Trans.Control
  import qualified Data.Dependent.Map as D
  import Data.Dependent.Sum
  import Data.IORef
  import Data.Some
  import qualified Data.Map as M
  import qualified Data.Set as S
  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
  
  ------------------------------------------------------------------------
  --
  -- Lambdabot state
  --
  
  -- | Global read-only state.
  data IRCRState = IRCRState
      { ircInitDoneMVar   :: MVar ()
      , ircQuitMVar       :: MVar ()
      , ircConfig         :: D.DMap Config Identity
      }
  
  -- | Default ro state
  initRoState :: [DSum Config Identity] -> IO IRCRState
  initRoState configuration = do
      quitMVar     <- newEmptyMVar
      initDoneMVar <- newEmptyMVar
      
      let mergeConfig' k (Identity x) (Identity y) = Identity (mergeConfig k y x)
      
      return IRCRState 
          { ircQuitMVar       = quitMVar
          , ircInitDoneMVar   = initDoneMVar
          , ircConfig         = D.fromListWithKey mergeConfig' configuration
          }
  
  reportInitDone :: LB ()
  reportInitDone = do
      mvar <- LB (asks (ircInitDoneMVar . fst))
      io $ putMVar mvar ()
  
  askLB :: MonadLB m => (IRCRState -> a) -> m a
  askLB f  = lb . LB $ asks (f . fst)
  
  waitForInit :: MonadLB m => m ()
  waitForInit = readMVar =<< askLB ircInitDoneMVar
  
  waitForQuit :: MonadLB m => m ()
  waitForQuit = readMVar =<< askLB ircQuitMVar
  
  type Callback     st = IrcMessage -> ModuleT st LB ()
  type OutputFilter st = Nick -> [String] -> ModuleT st LB [String]
  type Server       st = IrcMessage -> ModuleT st LB ()
  
  newtype CallbackRef     st = CallbackRef     (Callback st)
  newtype CommandRef      st = CommandRef      (Command (ModuleT st LB))
  newtype OutputFilterRef st = OutputFilterRef (OutputFilter st)
  newtype ServerRef       st = ServerRef       (Server st)
  
  -- | Global read\/write state.
  data IRCRWState = IRCRWState
      { ircServerMap       :: M.Map String (DSum ModuleID ServerRef)
      , ircPrivilegedUsers :: S.Set Nick
      , ircIgnoredUsers    :: S.Set Nick
      
      , ircChannels        :: M.Map ChanName String
      -- ^ maps channel names to topics
      , ircPersists        :: M.Map String Bool
      -- ^ lists servers to which to reconnect on failure (one-time or always)
      
      , ircModulesByName   :: M.Map String (Some ModuleInfo)
      , ircModulesByID     :: D.DMap ModuleID ModuleInfo
      , ircCallbacks       :: M.Map String (D.DMap ModuleID CallbackRef)
      , ircOutputFilters   :: [DSum ModuleID OutputFilterRef]
      -- ^ Output filters, invoked from right to left
      
      , ircCommands        :: M.Map String (DSum ModuleID CommandRef)
      }
  
  -- | Default rw state
  initRwState :: IRCRWState
  initRwState = IRCRWState
      { ircPrivilegedUsers = S.empty
      , ircIgnoredUsers    = S.empty
      , ircChannels        = M.empty
      , ircPersists        = M.empty
      , ircModulesByName   = M.empty
      , ircModulesByID     = D.empty
      , ircServerMap       = M.empty
      , ircCallbacks       = M.empty
      , ircOutputFilters   = []
      , ircCommands        = M.empty
      }
  
  -- ---------------------------------------------------------------------
  --
  -- The LB (LambdaBot) monad
  --
  
  -- | The IRC Monad. The reader transformer holds information about the
  --   connection to the IRC server.
  --
  -- instances Monad, Functor, MonadIO, MonadState, MonadError
  
  newtype LB a = LB { unLB :: ReaderT (IRCRState, IORef IRCRWState) IO a }
      deriving (Functor, Applicative, Monad, MonadIO, MonadFail,
  #if !defined(MIN_VERSION_haskeline) || !MIN_VERSION_haskeline(0,8,0)
          MonadException,
  #endif
          MonadThrow, MonadCatch, MonadMask)
  
  runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a
  runLB = runReaderT . unLB
  
  instance MonadBase IO LB where
      liftBase = LB . liftBase
  
  instance MonadBaseControl IO LB where
      type StM LB a = StM (ReaderT (IRCRState,IORef IRCRWState) IO) a
      liftBaseWith action = LB (liftBaseWith (\run -> action (run . unLB)))
      restoreM = LB . restoreM
  
  class (MonadIO m, MonadBaseControl IO m, MonadConfig m, MonadLogging m, Applicative m, MonadFail m) => MonadLB m where
      lb :: LB a -> m a
  
  instance MonadLB LB where lb = id
  instance MonadLB m => MonadLB (ModuleT st m) where lb = lift . lb
  instance MonadLB m => MonadLB (Cmd m)        where lb = lift . lb
  
  instance MonadState IRCRWState LB where
      state f = LB $ do
          ref <- asks snd
          lift . atomicModifyIORef ref $ \s -> 
              let (s', x) = f s
               in seq s' (x, s')
  
  instance MonadConfig LB where
      getConfig k = liftM (maybe (getConfigDefault k) runIdentity . D.lookup k) (lb (askLB ircConfig))
  
  instance MonadLogging LB where
      getCurrentLogger = getConfig lbRootLoggerPath
      logM a b c = io (logM a b c)
  
  ---------------
  -- state management (registering/unregistering various things)
  
  registerModule :: String -> Module st -> st -> LB (ModuleInfo st)
  registerModule mName m mState = do
      mTag    <- io newModuleID
      mInfo   <- ModuleInfo mName mTag m <$> newMVar mState
      
      modify $ \s -> s
          { ircModulesByName  = M.insert mName (Some mInfo) (ircModulesByName s)
          , ircModulesByID    = D.insert mTag        mInfo  (ircModulesByID   s)
          }
      
      return mInfo
  
  registerCommands :: [Command (ModuleT st LB)] -> ModuleT st LB ()
  registerCommands cmds = do
      mTag <- asks moduleID
      let taggedCmds = 
              [ (cName, mTag :=> CommandRef cmd)
              | cmd   <- cmds
              , cName <- cmdNames cmd
              ]
      
      lift $ modify $ \s -> s
          { ircCommands = M.union (M.fromList taggedCmds) (ircCommands s)
          }
  
  registerCallback :: String -> Callback st -> ModuleT st LB ()
  registerCallback str f = do
      mTag <- asks moduleID
      
      lift . modify $ \s -> s
          { ircCallbacks = M.insertWith D.union str
              (D.singleton mTag (CallbackRef f))
              (ircCallbacks s)
          }
  
  registerOutputFilter :: OutputFilter st -> ModuleT st LB ()
  registerOutputFilter f = do
      mTag <- asks moduleID
      lift . modify $ \s -> s
          { ircOutputFilters = (mTag :=> OutputFilterRef f) : ircOutputFilters s
          }
  
  unregisterModule :: String -> LB ()
  unregisterModule mName = maybe (return ()) warningM <=< state $ \s -> 
      case M.lookup mName (ircModulesByName s) of
          Nothing                 -> (Just $ "Tried to unregister module that wasn't registered: " ++ show mName, s)
          Just (Some modInfo)     ->
              let mTag = moduleID modInfo
                  
                  notSomeTag :: DSum ModuleID f -> Bool
                  notSomeTag (tag :=> _) = Some tag /= Some mTag
                  s' = s
                      { ircModulesByName  = M.delete mName        (ircModulesByName s)
                      , ircModulesByID    = D.delete mTag         (ircModulesByID   s)
                      , ircCommands       = M.filter notSomeTag   (ircCommands      s)
                      , ircCallbacks      = M.map (D.delete mTag) (ircCallbacks     s)
                      , ircServerMap      = M.filter notSomeTag   (ircServerMap     s)
                      , ircOutputFilters  =   filter notSomeTag   (ircOutputFilters s)
                      }
               in (Nothing, s')
  
  -- The virtual chat system.
  --
  -- The virtual chat system sits between the chat drivers and the rest of
  -- Lambdabot.  It provides a mapping between the String server "tags" and
  -- functions which are able to handle sending messages.
  --
  -- When a message is received, the chat module is expected to call
  -- `Lambdabot.Main.received'.  This is not ideal.
  
  registerServer :: String -> Server st -> ModuleT st LB ()
  registerServer sName sendf = do
      mTag <- asks moduleID
      maybe (return ()) fail <=< lb . state $ \s ->
          case M.lookup sName (ircServerMap s) of
              Just _  -> (Just $ "attempted to create two servers named " ++ sName, s)
              Nothing -> 
                  let s' = s { ircServerMap = M.insert sName (mTag :=> ServerRef sendf) (ircServerMap s)}
                   in (Nothing, s')
  
  -- TODO: fix race condition
  unregisterServer :: String -> ModuleT mod LB ()
  unregisterServer tag = lb $ do
      s <- get
      let svrs = ircServerMap s
      case M.lookup tag svrs of
          Just _ -> do
              let svrs' = M.delete tag svrs
              put (s { ircServerMap = svrs' })
              when (M.null svrs') $ do
                  quitMVar <- askLB ircQuitMVar
                  io $ putMVar quitMVar ()
          Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag
  
  withUEHandler :: LB () -> LB ()
  withUEHandler f = do
      handler <- getConfig uncaughtExceptionHandler
      E.catch f (io . handler)
  
  send :: IrcMessage -> LB ()
  send msg = do
      s <- gets ircServerMap
      let bogus = warningM $ "sending message to bogus server: " ++ show msg
      case M.lookup (Msg.server msg) s of
          Just (mTag :=> ServerRef sendf) -> 
              withUEHandler (inModuleWithID mTag bogus (sendf msg))
          Nothing -> bogus
  
  received :: IrcMessage -> LB ()
  received msg = do
      s       <- get
      case M.lookup (ircMsgCommand msg) (ircCallbacks s) of
          Just cbs -> forM_ (D.toList cbs) $ \(tag :=> CallbackRef cb) ->
              withUEHandler (inModuleWithID tag (return ()) (cb msg))
          _        -> return ()
  
  applyOutputFilter :: Nick -> DSum ModuleID OutputFilterRef -> [String] -> LB [String]
  applyOutputFilter who (mTag :=> OutputFilterRef f) msg =
      inModuleWithID mTag (return msg) (f who msg)
  
  applyOutputFilters :: Nick -> String -> LB [String]
  applyOutputFilters who msg = do
      filters   <- gets ircOutputFilters
      foldr (\a x -> applyOutputFilter who a =<< x) ((return . lines) msg) filters
  
  ------------------------------------------------------------------------
  -- Module handling
  
  -- | Interpret an expression in the context of a module.
  inModuleNamed :: String -> LB a -> (forall st. ModuleT st LB a) -> LB a
  inModuleNamed name nothing just = do
      mbMod <- gets (M.lookup name . ircModulesByName)
      case mbMod of
          Nothing             -> nothing
          Just (Some modInfo) -> runModuleT just modInfo
  
  inModuleWithID :: ModuleID st -> LB a -> (ModuleT st LB a) -> LB a
  inModuleWithID tag nothing just = do
      mbMod <- gets (D.lookup tag . ircModulesByID )
      case mbMod of
          Nothing         -> nothing
          Just modInfo    -> runModuleT just modInfo
  
  withCommand :: String -> LB a -> (forall st. Command (ModuleT st LB) -> ModuleT st LB a) -> LB a
  withCommand cmdname def f = do
      mbCmd <- gets (M.lookup cmdname . ircCommands)
      case mbCmd of
          Just (tag :=> CommandRef cmd)   -> inModuleWithID tag def (f cmd)
          _                               -> def
  
  listModules :: LB [String]
  listModules = gets (M.keys . ircModulesByName)
  
  -- | Interpret a function in the context of all modules
  withAllModules :: (forall st. ModuleT st LB a) -> LB ()
  withAllModules f = do
      mods <- gets $ M.elems . ircModulesByName
      forM_ mods $ \(Some modInfo) -> runModuleT f modInfo
  