{-# 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.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
    { IRCRState -> MVar ()
ircInitDoneMVar   :: MVar ()
    , IRCRState -> MVar ()
ircQuitMVar       :: MVar ()
    , IRCRState -> DMap Config Identity
ircConfig         :: D.DMap Config Identity
    }

-- | Default ro state
initRoState :: [DSum Config Identity] -> IO IRCRState
initRoState :: [DSum Config Identity] -> IO IRCRState
initRoState [DSum Config Identity]
configuration = do
    MVar ()
quitMVar     <- IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
    MVar ()
initDoneMVar <- IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
    
    let mergeConfig' :: Config a -> Identity a -> Identity a -> Identity a
mergeConfig' Config a
k (Identity a
x) (Identity a
y) = a -> Identity a
forall a. a -> Identity a
Identity (Config a -> a -> a -> a
forall t. Config t -> t -> t -> t
mergeConfig Config a
k a
y a
x)
    
    IRCRState -> IO IRCRState
forall (m :: * -> *) a. Monad m => a -> m a
return IRCRState :: MVar () -> MVar () -> DMap Config Identity -> IRCRState
IRCRState 
        { ircQuitMVar :: MVar ()
ircQuitMVar       = MVar ()
quitMVar
        , ircInitDoneMVar :: MVar ()
ircInitDoneMVar   = MVar ()
initDoneMVar
        , ircConfig :: DMap Config Identity
ircConfig         = (forall v. Config v -> Identity v -> Identity v -> Identity v)
-> [DSum Config Identity] -> DMap Config Identity
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> [DSum k2 f] -> DMap k2 f
D.fromListWithKey forall v. Config v -> Identity v -> Identity v -> Identity v
mergeConfig' [DSum Config Identity]
configuration
        }

reportInitDone :: LB ()
reportInitDone :: LB ()
reportInitDone = do
    MVar ()
mvar <- ReaderT (IRCRState, IORef IRCRWState) IO (MVar ()) -> LB (MVar ())
forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (((IRCRState, IORef IRCRWState) -> MVar ())
-> ReaderT (IRCRState, IORef IRCRWState) IO (MVar ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (IRCRState -> MVar ()
ircInitDoneMVar (IRCRState -> MVar ())
-> ((IRCRState, IORef IRCRWState) -> IRCRState)
-> (IRCRState, IORef IRCRWState)
-> MVar ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IRCRState, IORef IRCRWState) -> IRCRState
forall a b. (a, b) -> a
fst))
    IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
mvar ()

askLB :: MonadLB m => (IRCRState -> a) -> m a
askLB :: (IRCRState -> a) -> m a
askLB IRCRState -> a
f  = LB a -> m a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB a -> m a)
-> (ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a)
-> ReaderT (IRCRState, IORef IRCRWState) IO a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (ReaderT (IRCRState, IORef IRCRWState) IO a -> m a)
-> ReaderT (IRCRState, IORef IRCRWState) IO a -> m a
forall a b. (a -> b) -> a -> b
$ ((IRCRState, IORef IRCRWState) -> a)
-> ReaderT (IRCRState, IORef IRCRWState) IO a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (IRCRState -> a
f (IRCRState -> a)
-> ((IRCRState, IORef IRCRWState) -> IRCRState)
-> (IRCRState, IORef IRCRWState)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IRCRState, IORef IRCRWState) -> IRCRState
forall a b. (a, b) -> a
fst)

waitForInit :: MonadLB m => m ()
waitForInit :: m ()
waitForInit = MVar () -> m ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar (MVar () -> m ()) -> m (MVar ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IRCRState -> MVar ()) -> m (MVar ())
forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> MVar ()
ircInitDoneMVar

waitForQuit :: MonadLB m => m ()
waitForQuit :: m ()
waitForQuit = MVar () -> m ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar (MVar () -> m ()) -> m (MVar ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IRCRState -> MVar ()) -> m (MVar ())
forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> MVar ()
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
    { IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap       :: M.Map String (DSum ModuleID ServerRef)
    , IRCRWState -> Set Nick
ircPrivilegedUsers :: S.Set Nick
    , IRCRWState -> Set Nick
ircIgnoredUsers    :: S.Set Nick
    
    , IRCRWState -> Map ChanName String
ircChannels        :: M.Map ChanName String
    -- ^ maps channel names to topics
    , IRCRWState -> Map String Bool
ircPersists        :: M.Map String Bool
    -- ^ lists servers to which to reconnect on failure (one-time or always)
    
    , IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName   :: M.Map String (Some ModuleInfo)
    , IRCRWState -> DMap ModuleID ModuleInfo
ircModulesByID     :: D.DMap ModuleID ModuleInfo
    , IRCRWState -> Map String (DMap ModuleID CallbackRef)
ircCallbacks       :: M.Map String (D.DMap ModuleID CallbackRef)
    , IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters   :: [DSum ModuleID OutputFilterRef]
    -- ^ Output filters, invoked from right to left
    
    , IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands        :: M.Map String (DSum ModuleID CommandRef)
    }

-- | Default rw state
initRwState :: IRCRWState
initRwState :: IRCRWState
initRwState = IRCRWState :: Map String (DSum ModuleID ServerRef)
-> Set Nick
-> Set Nick
-> Map ChanName String
-> Map String Bool
-> Map String (Some ModuleInfo)
-> DMap ModuleID ModuleInfo
-> Map String (DMap ModuleID CallbackRef)
-> [DSum ModuleID OutputFilterRef]
-> Map String (DSum ModuleID CommandRef)
-> IRCRWState
IRCRWState
    { ircPrivilegedUsers :: Set Nick
ircPrivilegedUsers = Set Nick
forall a. Set a
S.empty
    , ircIgnoredUsers :: Set Nick
ircIgnoredUsers    = Set Nick
forall a. Set a
S.empty
    , ircChannels :: Map ChanName String
ircChannels        = Map ChanName String
forall k a. Map k a
M.empty
    , ircPersists :: Map String Bool
ircPersists        = Map String Bool
forall k a. Map k a
M.empty
    , ircModulesByName :: Map String (Some ModuleInfo)
ircModulesByName   = Map String (Some ModuleInfo)
forall k a. Map k a
M.empty
    , ircModulesByID :: DMap ModuleID ModuleInfo
ircModulesByID     = DMap ModuleID ModuleInfo
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f
D.empty
    , ircServerMap :: Map String (DSum ModuleID ServerRef)
ircServerMap       = Map String (DSum ModuleID ServerRef)
forall k a. Map k a
M.empty
    , ircCallbacks :: Map String (DMap ModuleID CallbackRef)
ircCallbacks       = Map String (DMap ModuleID CallbackRef)
forall k a. Map k a
M.empty
    , ircOutputFilters :: [DSum ModuleID OutputFilterRef]
ircOutputFilters   = []
    , ircCommands :: Map String (DSum ModuleID CommandRef)
ircCommands        = Map String (DSum ModuleID CommandRef)
forall k a. Map k a
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 { LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
unLB :: ReaderT (IRCRState, IORef IRCRWState) IO a }
    deriving (a -> LB b -> LB a
(a -> b) -> LB a -> LB b
(forall a b. (a -> b) -> LB a -> LB b)
-> (forall a b. a -> LB b -> LB a) -> Functor LB
forall a b. a -> LB b -> LB a
forall a b. (a -> b) -> LB a -> LB b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LB b -> LB a
$c<$ :: forall a b. a -> LB b -> LB a
fmap :: (a -> b) -> LB a -> LB b
$cfmap :: forall a b. (a -> b) -> LB a -> LB b
Functor, Functor LB
a -> LB a
Functor LB
-> (forall a. a -> LB a)
-> (forall a b. LB (a -> b) -> LB a -> LB b)
-> (forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c)
-> (forall a b. LB a -> LB b -> LB b)
-> (forall a b. LB a -> LB b -> LB a)
-> Applicative LB
LB a -> LB b -> LB b
LB a -> LB b -> LB a
LB (a -> b) -> LB a -> LB b
(a -> b -> c) -> LB a -> LB b -> LB c
forall a. a -> LB a
forall a b. LB a -> LB b -> LB a
forall a b. LB a -> LB b -> LB b
forall a b. LB (a -> b) -> LB a -> LB b
forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: LB a -> LB b -> LB a
$c<* :: forall a b. LB a -> LB b -> LB a
*> :: LB a -> LB b -> LB b
$c*> :: forall a b. LB a -> LB b -> LB b
liftA2 :: (a -> b -> c) -> LB a -> LB b -> LB c
$cliftA2 :: forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c
<*> :: LB (a -> b) -> LB a -> LB b
$c<*> :: forall a b. LB (a -> b) -> LB a -> LB b
pure :: a -> LB a
$cpure :: forall a. a -> LB a
$cp1Applicative :: Functor LB
Applicative, Applicative LB
a -> LB a
Applicative LB
-> (forall a b. LB a -> (a -> LB b) -> LB b)
-> (forall a b. LB a -> LB b -> LB b)
-> (forall a. a -> LB a)
-> Monad LB
LB a -> (a -> LB b) -> LB b
LB a -> LB b -> LB b
forall a. a -> LB a
forall a b. LB a -> LB b -> LB b
forall a b. LB a -> (a -> LB b) -> LB b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> LB a
$creturn :: forall a. a -> LB a
>> :: LB a -> LB b -> LB b
$c>> :: forall a b. LB a -> LB b -> LB b
>>= :: LB a -> (a -> LB b) -> LB b
$c>>= :: forall a b. LB a -> (a -> LB b) -> LB b
$cp1Monad :: Applicative LB
Monad, Monad LB
Monad LB -> (forall a. IO a -> LB a) -> MonadIO LB
IO a -> LB a
forall a. IO a -> LB a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> LB a
$cliftIO :: forall a. IO a -> LB a
$cp1MonadIO :: Monad LB
MonadIO, Monad LB
Monad LB -> (forall a. String -> LB a) -> MonadFail LB
String -> LB a
forall a. String -> LB a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> LB a
$cfail :: forall a. String -> LB a
$cp1MonadFail :: Monad LB
MonadFail,
#if !defined(MIN_VERSION_haskeline) || !MIN_VERSION_haskeline(0,8,0)
        MonadException,
#endif
        Monad LB
e -> LB a
Monad LB -> (forall e a. Exception e => e -> LB a) -> MonadThrow LB
forall e a. Exception e => e -> LB a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> LB a
$cthrowM :: forall e a. Exception e => e -> LB a
$cp1MonadThrow :: Monad LB
MonadThrow, MonadThrow LB
MonadThrow LB
-> (forall e a. Exception e => LB a -> (e -> LB a) -> LB a)
-> MonadCatch LB
LB a -> (e -> LB a) -> LB a
forall e a. Exception e => LB a -> (e -> LB a) -> LB a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: LB a -> (e -> LB a) -> LB a
$ccatch :: forall e a. Exception e => LB a -> (e -> LB a) -> LB a
$cp1MonadCatch :: MonadThrow LB
MonadCatch, MonadCatch LB
MonadCatch LB
-> (forall b. ((forall a. LB a -> LB a) -> LB b) -> LB b)
-> (forall b. ((forall a. LB a -> LB a) -> LB b) -> LB b)
-> (forall a b c.
    LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c))
-> MonadMask LB
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
((forall a. LB a -> LB a) -> LB b) -> LB b
((forall a. LB a -> LB a) -> LB b) -> LB b
forall b. ((forall a. LB a -> LB a) -> LB b) -> LB b
forall a b c.
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
$cgeneralBracket :: forall a b c.
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
uninterruptibleMask :: ((forall a. LB a -> LB a) -> LB b) -> LB b
$cuninterruptibleMask :: forall b. ((forall a. LB a -> LB a) -> LB b) -> LB b
mask :: ((forall a. LB a -> LB a) -> LB b) -> LB b
$cmask :: forall b. ((forall a. LB a -> LB a) -> LB b) -> LB b
$cp1MonadMask :: MonadCatch LB
MonadMask)

runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a
runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a
runLB = ReaderT (IRCRState, IORef IRCRWState) IO a
-> (IRCRState, IORef IRCRWState) -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT (IRCRState, IORef IRCRWState) IO a
 -> (IRCRState, IORef IRCRWState) -> IO a)
-> (LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a)
-> LB a
-> (IRCRState, IORef IRCRWState)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
forall a. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
unLB

instance MonadBase IO LB where
    liftBase :: IO α -> LB α
liftBase = ReaderT (IRCRState, IORef IRCRWState) IO α -> LB α
forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (ReaderT (IRCRState, IORef IRCRWState) IO α -> LB α)
-> (IO α -> ReaderT (IRCRState, IORef IRCRWState) IO α)
-> IO α
-> LB α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO α -> ReaderT (IRCRState, IORef IRCRWState) IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance MonadBaseControl IO LB where
    type StM LB a = StM (ReaderT (IRCRState,IORef IRCRWState) IO) a
    liftBaseWith :: (RunInBase LB IO -> IO a) -> LB a
liftBaseWith RunInBase LB IO -> IO a
action = ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB ((RunInBase (ReaderT (IRCRState, IORef IRCRWState) IO) IO -> IO a)
-> ReaderT (IRCRState, IORef IRCRWState) IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase (ReaderT (IRCRState, IORef IRCRWState) IO) IO
run -> RunInBase LB IO -> IO a
action (ReaderT (IRCRState, IORef IRCRWState) IO a -> IO a
RunInBase (ReaderT (IRCRState, IORef IRCRWState) IO) IO
run (ReaderT (IRCRState, IORef IRCRWState) IO a -> IO a)
-> (LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a)
-> LB a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
forall a. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
unLB)))
    restoreM :: StM LB a -> LB a
restoreM = ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a)
-> (a -> ReaderT (IRCRState, IORef IRCRWState) IO a) -> a -> LB a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT (IRCRState, IORef IRCRWState) IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
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 :: LB a -> LB a
lb = LB a -> LB a
forall a. a -> a
id
instance MonadLB m => MonadLB (ModuleT st m) where lb :: LB a -> ModuleT st m a
lb = m a -> ModuleT st m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ModuleT st m a) -> (LB a -> m a) -> LB a -> ModuleT st m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB a -> m a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb
instance MonadLB m => MonadLB (Cmd m)        where lb :: LB a -> Cmd m a
lb = m a -> Cmd m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Cmd m a) -> (LB a -> m a) -> LB a -> Cmd m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB a -> m a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb

instance MonadState IRCRWState LB where
    state :: (IRCRWState -> (a, IRCRWState)) -> LB a
state IRCRWState -> (a, IRCRWState)
f = ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a)
-> ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
forall a b. (a -> b) -> a -> b
$ do
        IORef IRCRWState
ref <- ((IRCRState, IORef IRCRWState) -> IORef IRCRWState)
-> ReaderT (IRCRState, IORef IRCRWState) IO (IORef IRCRWState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (IRCRState, IORef IRCRWState) -> IORef IRCRWState
forall a b. (a, b) -> b
snd
        IO a -> ReaderT (IRCRState, IORef IRCRWState) IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT (IRCRState, IORef IRCRWState) IO a)
-> ((IRCRWState -> (IRCRWState, a)) -> IO a)
-> (IRCRWState -> (IRCRWState, a))
-> ReaderT (IRCRState, IORef IRCRWState) IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef IRCRWState -> (IRCRWState -> (IRCRWState, a)) -> IO a
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef IRCRWState
ref ((IRCRWState -> (IRCRWState, a))
 -> ReaderT (IRCRState, IORef IRCRWState) IO a)
-> (IRCRWState -> (IRCRWState, a))
-> ReaderT (IRCRState, IORef IRCRWState) IO a
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> 
            let (a
s', IRCRWState
x) = IRCRWState -> (a, IRCRWState)
f IRCRWState
s
             in a -> (IRCRWState, a) -> (IRCRWState, a)
seq a
s' (IRCRWState
x, a
s')

instance MonadConfig LB where
    getConfig :: Config a -> LB a
getConfig Config a
k = (DMap Config Identity -> a) -> LB (DMap Config Identity) -> LB a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a -> (Identity a -> a) -> Maybe (Identity a) -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Config a -> a
forall t. Config t -> t
getConfigDefault Config a
k) Identity a -> a
forall a. Identity a -> a
runIdentity (Maybe (Identity a) -> a)
-> (DMap Config Identity -> Maybe (Identity a))
-> DMap Config Identity
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config a -> DMap Config Identity -> Maybe (Identity a)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
D.lookup Config a
k) (LB (DMap Config Identity) -> LB (DMap Config Identity)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb ((IRCRState -> DMap Config Identity) -> LB (DMap Config Identity)
forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> DMap Config Identity
ircConfig))

instance MonadLogging LB where
    getCurrentLogger :: LB [String]
getCurrentLogger = Config [String] -> LB [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
lbRootLoggerPath
    logM :: String -> Priority -> String -> LB ()
logM String
a Priority
b String
c = IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> Priority -> String -> IO ()
forall (m :: * -> *).
MonadLogging m =>
String -> Priority -> String -> m ()
logM String
a Priority
b String
c)

---------------
-- state management (registering/unregistering various things)

registerModule :: String -> Module st -> st -> LB (ModuleInfo st)
registerModule :: String -> Module st -> st -> LB (ModuleInfo st)
registerModule String
mName Module st
m st
mState = do
    ModuleID st
mTag    <- IO (ModuleID st) -> LB (ModuleID st)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO (ModuleID st)
forall st. IO (ModuleID st)
newModuleID
    ModuleInfo st
mInfo   <- String -> ModuleID st -> Module st -> MVar st -> ModuleInfo st
forall st.
String -> ModuleID st -> Module st -> MVar st -> ModuleInfo st
ModuleInfo String
mName ModuleID st
mTag Module st
m (MVar st -> ModuleInfo st) -> LB (MVar st) -> LB (ModuleInfo st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> st -> LB (MVar st)
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar st
mState
    
    (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
        { ircModulesByName :: Map String (Some ModuleInfo)
ircModulesByName  = String
-> Some ModuleInfo
-> Map String (Some ModuleInfo)
-> Map String (Some ModuleInfo)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
mName (ModuleInfo st -> Some ModuleInfo
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some ModuleInfo st
mInfo) (IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName IRCRWState
s)
        , ircModulesByID :: DMap ModuleID ModuleInfo
ircModulesByID    = ModuleID st
-> ModuleInfo st
-> DMap ModuleID ModuleInfo
-> DMap ModuleID ModuleInfo
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
D.insert ModuleID st
mTag        ModuleInfo st
mInfo  (IRCRWState -> DMap ModuleID ModuleInfo
ircModulesByID   IRCRWState
s)
        }
    
    ModuleInfo st -> LB (ModuleInfo st)
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleInfo st
mInfo

registerCommands :: [Command (ModuleT st LB)] -> ModuleT st LB ()
registerCommands :: [Command (ModuleT st LB)] -> ModuleT st LB ()
registerCommands [Command (ModuleT st LB)]
cmds = do
    ModuleID st
mTag <- (ModuleInfo st -> ModuleID st) -> ModuleT st LB (ModuleID st)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ModuleInfo st -> ModuleID st
forall st. ModuleInfo st -> ModuleID st
moduleID
    let taggedCmds :: [(String, DSum ModuleID CommandRef)]
taggedCmds = 
            [ (String
cName, ModuleID st
mTag ModuleID st -> CommandRef st -> DSum ModuleID CommandRef
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> Command (ModuleT st LB) -> CommandRef st
forall st. Command (ModuleT st LB) -> CommandRef st
CommandRef Command (ModuleT st LB)
cmd)
            | Command (ModuleT st LB)
cmd   <- [Command (ModuleT st LB)]
cmds
            , String
cName <- Command (ModuleT st LB) -> [String]
forall (m :: * -> *). Command m -> [String]
cmdNames Command (ModuleT st LB)
cmd
            ]
    
    LB () -> ModuleT st LB ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> ModuleT st LB ()) -> LB () -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
        { ircCommands :: Map String (DSum ModuleID CommandRef)
ircCommands = Map String (DSum ModuleID CommandRef)
-> Map String (DSum ModuleID CommandRef)
-> Map String (DSum ModuleID CommandRef)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union ([(String, DSum ModuleID CommandRef)]
-> Map String (DSum ModuleID CommandRef)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, DSum ModuleID CommandRef)]
taggedCmds) (IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands IRCRWState
s)
        }

registerCallback :: String -> Callback st -> ModuleT st LB ()
registerCallback :: String -> Callback st -> ModuleT st LB ()
registerCallback String
str Callback st
f = do
    ModuleID st
mTag <- (ModuleInfo st -> ModuleID st) -> ModuleT st LB (ModuleID st)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ModuleInfo st -> ModuleID st
forall st. ModuleInfo st -> ModuleID st
moduleID
    
    LB () -> ModuleT st LB ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> ModuleT st LB ())
-> ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState)
-> ModuleT st LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> ModuleT st LB ())
-> (IRCRWState -> IRCRWState) -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
        { ircCallbacks :: Map String (DMap ModuleID CallbackRef)
ircCallbacks = (DMap ModuleID CallbackRef
 -> DMap ModuleID CallbackRef -> DMap ModuleID CallbackRef)
-> String
-> DMap ModuleID CallbackRef
-> Map String (DMap ModuleID CallbackRef)
-> Map String (DMap ModuleID CallbackRef)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith DMap ModuleID CallbackRef
-> DMap ModuleID CallbackRef -> DMap ModuleID CallbackRef
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
DMap k2 f -> DMap k2 f -> DMap k2 f
D.union String
str
            (ModuleID st -> CallbackRef st -> DMap ModuleID CallbackRef
forall k1 (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
D.singleton ModuleID st
mTag (Callback st -> CallbackRef st
forall st. Callback st -> CallbackRef st
CallbackRef Callback st
f))
            (IRCRWState -> Map String (DMap ModuleID CallbackRef)
ircCallbacks IRCRWState
s)
        }

registerOutputFilter :: OutputFilter st -> ModuleT st LB ()
registerOutputFilter :: OutputFilter st -> ModuleT st LB ()
registerOutputFilter OutputFilter st
f = do
    ModuleID st
mTag <- (ModuleInfo st -> ModuleID st) -> ModuleT st LB (ModuleID st)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ModuleInfo st -> ModuleID st
forall st. ModuleInfo st -> ModuleID st
moduleID
    LB () -> ModuleT st LB ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> ModuleT st LB ())
-> ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState)
-> ModuleT st LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> ModuleT st LB ())
-> (IRCRWState -> IRCRWState) -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
        { ircOutputFilters :: [DSum ModuleID OutputFilterRef]
ircOutputFilters = (ModuleID st
mTag ModuleID st -> OutputFilterRef st -> DSum ModuleID OutputFilterRef
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> OutputFilter st -> OutputFilterRef st
forall st. OutputFilter st -> OutputFilterRef st
OutputFilterRef OutputFilter st
f) DSum ModuleID OutputFilterRef
-> [DSum ModuleID OutputFilterRef]
-> [DSum ModuleID OutputFilterRef]
forall a. a -> [a] -> [a]
: IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters IRCRWState
s
        }

unregisterModule :: String -> LB ()
unregisterModule :: String -> LB ()
unregisterModule String
mName = LB () -> (String -> LB ()) -> Maybe String -> LB ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> LB ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
warningM (Maybe String -> LB ())
-> ((IRCRWState -> (Maybe String, IRCRWState))
    -> LB (Maybe String))
-> (IRCRWState -> (Maybe String, IRCRWState))
-> LB ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (IRCRWState -> (Maybe String, IRCRWState)) -> LB (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((IRCRWState -> (Maybe String, IRCRWState)) -> LB ())
-> (IRCRWState -> (Maybe String, IRCRWState)) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> 
    case String -> Map String (Some ModuleInfo) -> Maybe (Some ModuleInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
mName (IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName IRCRWState
s) of
        Maybe (Some ModuleInfo)
Nothing                 -> (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Tried to unregister module that wasn't registered: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
mName, IRCRWState
s)
        Just (Some ModuleInfo a
modInfo)     ->
            let mTag :: ModuleID a
mTag = ModuleInfo a -> ModuleID a
forall st. ModuleInfo st -> ModuleID st
moduleID ModuleInfo a
modInfo
                
                notSomeTag :: DSum ModuleID f -> Bool
                notSomeTag :: DSum ModuleID f -> Bool
notSomeTag (ModuleID a
tag :=> f a
_) = ModuleID a -> Some ModuleID
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some ModuleID a
tag Some ModuleID -> Some ModuleID -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleID a -> Some ModuleID
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some ModuleID a
mTag
                s' :: IRCRWState
s' = IRCRWState
s
                    { ircModulesByName :: Map String (Some ModuleInfo)
ircModulesByName  = String
-> Map String (Some ModuleInfo) -> Map String (Some ModuleInfo)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
mName        (IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName IRCRWState
s)
                    , ircModulesByID :: DMap ModuleID ModuleInfo
ircModulesByID    = ModuleID a -> DMap ModuleID ModuleInfo -> DMap ModuleID ModuleInfo
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> DMap k2 f
D.delete ModuleID a
mTag         (IRCRWState -> DMap ModuleID ModuleInfo
ircModulesByID   IRCRWState
s)
                    , ircCommands :: Map String (DSum ModuleID CommandRef)
ircCommands       = (DSum ModuleID CommandRef -> Bool)
-> Map String (DSum ModuleID CommandRef)
-> Map String (DSum ModuleID CommandRef)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter DSum ModuleID CommandRef -> Bool
forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag   (IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands      IRCRWState
s)
                    , ircCallbacks :: Map String (DMap ModuleID CallbackRef)
ircCallbacks      = (DMap ModuleID CallbackRef -> DMap ModuleID CallbackRef)
-> Map String (DMap ModuleID CallbackRef)
-> Map String (DMap ModuleID CallbackRef)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (ModuleID a
-> DMap ModuleID CallbackRef -> DMap ModuleID CallbackRef
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> DMap k2 f
D.delete ModuleID a
mTag) (IRCRWState -> Map String (DMap ModuleID CallbackRef)
ircCallbacks     IRCRWState
s)
                    , ircServerMap :: Map String (DSum ModuleID ServerRef)
ircServerMap      = (DSum ModuleID ServerRef -> Bool)
-> Map String (DSum ModuleID ServerRef)
-> Map String (DSum ModuleID ServerRef)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter DSum ModuleID ServerRef -> Bool
forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag   (IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap     IRCRWState
s)
                    , ircOutputFilters :: [DSum ModuleID OutputFilterRef]
ircOutputFilters  =   (DSum ModuleID OutputFilterRef -> Bool)
-> [DSum ModuleID OutputFilterRef]
-> [DSum ModuleID OutputFilterRef]
forall a. (a -> Bool) -> [a] -> [a]
filter DSum ModuleID OutputFilterRef -> Bool
forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag   (IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters IRCRWState
s)
                    }
             in (Maybe String
forall a. Maybe a
Nothing, IRCRWState
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 :: String -> Server st -> ModuleT st LB ()
registerServer String
sName Server st
sendf = do
    ModuleID st
mTag <- (ModuleInfo st -> ModuleID st) -> ModuleT st LB (ModuleID st)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ModuleInfo st -> ModuleID st
forall st. ModuleInfo st -> ModuleID st
moduleID
    ModuleT st LB ()
-> (String -> ModuleT st LB ()) -> Maybe String -> ModuleT st LB ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ModuleT st LB ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> ModuleT st LB ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Maybe String -> ModuleT st LB ())
-> ((IRCRWState -> (Maybe String, IRCRWState))
    -> ModuleT st LB (Maybe String))
-> (IRCRWState -> (Maybe String, IRCRWState))
-> ModuleT st LB ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< LB (Maybe String) -> ModuleT st LB (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB (Maybe String) -> ModuleT st LB (Maybe String))
-> ((IRCRWState -> (Maybe String, IRCRWState))
    -> LB (Maybe String))
-> (IRCRWState -> (Maybe String, IRCRWState))
-> ModuleT st LB (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IRCRWState -> (Maybe String, IRCRWState)) -> LB (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((IRCRWState -> (Maybe String, IRCRWState)) -> ModuleT st LB ())
-> (IRCRWState -> (Maybe String, IRCRWState)) -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s ->
        case String
-> Map String (DSum ModuleID ServerRef)
-> Maybe (DSum ModuleID ServerRef)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
sName (IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
s) of
            Just DSum ModuleID ServerRef
_  -> (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"attempted to create two servers named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sName, IRCRWState
s)
            Maybe (DSum ModuleID ServerRef)
Nothing -> 
                let s' :: IRCRWState
s' = IRCRWState
s { ircServerMap :: Map String (DSum ModuleID ServerRef)
ircServerMap = String
-> DSum ModuleID ServerRef
-> Map String (DSum ModuleID ServerRef)
-> Map String (DSum ModuleID ServerRef)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
sName (ModuleID st
mTag ModuleID st -> ServerRef st -> DSum ModuleID ServerRef
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> Server st -> ServerRef st
forall st. Server st -> ServerRef st
ServerRef Server st
sendf) (IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
s)}
                 in (Maybe String
forall a. Maybe a
Nothing, IRCRWState
s')

-- TODO: fix race condition
unregisterServer :: String -> ModuleT mod LB ()
unregisterServer :: String -> ModuleT mod LB ()
unregisterServer String
tag = LB () -> ModuleT mod LB ()
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> ModuleT mod LB ()) -> LB () -> ModuleT mod LB ()
forall a b. (a -> b) -> a -> b
$ do
    IRCRWState
s <- LB IRCRWState
forall s (m :: * -> *). MonadState s m => m s
get
    let svrs :: Map String (DSum ModuleID ServerRef)
svrs = IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
s
    case String
-> Map String (DSum ModuleID ServerRef)
-> Maybe (DSum ModuleID ServerRef)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
tag Map String (DSum ModuleID ServerRef)
svrs of
        Just DSum ModuleID ServerRef
_ -> do
            let svrs' :: Map String (DSum ModuleID ServerRef)
svrs' = String
-> Map String (DSum ModuleID ServerRef)
-> Map String (DSum ModuleID ServerRef)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
tag Map String (DSum ModuleID ServerRef)
svrs
            IRCRWState -> LB ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IRCRWState
s { ircServerMap :: Map String (DSum ModuleID ServerRef)
ircServerMap = Map String (DSum ModuleID ServerRef)
svrs' })
            Bool -> LB () -> LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map String (DSum ModuleID ServerRef) -> Bool
forall k a. Map k a -> Bool
M.null Map String (DSum ModuleID ServerRef)
svrs') (LB () -> LB ()) -> LB () -> LB ()
forall a b. (a -> b) -> a -> b
$ do
                MVar ()
quitMVar <- (IRCRState -> MVar ()) -> LB (MVar ())
forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> MVar ()
ircQuitMVar
                IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
quitMVar ()
        Maybe (DSum ModuleID ServerRef)
Nothing -> String -> LB ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> LB ()) -> String -> LB ()
forall a b. (a -> b) -> a -> b
$ String
"attempted to delete nonexistent servers named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag

withUEHandler :: LB () -> LB ()
withUEHandler :: LB () -> LB ()
withUEHandler LB ()
f = do
    DIH
handler <- Config DIH -> LB DIH
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config DIH
uncaughtExceptionHandler
    LB () -> (SomeException -> LB ()) -> LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch LB ()
f (IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> DIH -> SomeException -> LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIH
handler)

send :: IrcMessage -> LB ()
send :: IrcMessage -> LB ()
send IrcMessage
msg = do
    Map String (DSum ModuleID ServerRef)
s <- (IRCRWState -> Map String (DSum ModuleID ServerRef))
-> LB (Map String (DSum ModuleID ServerRef))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap
    let bogus :: LB ()
bogus = String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
warningM (String -> LB ()) -> String -> LB ()
forall a b. (a -> b) -> a -> b
$ String
"sending message to bogus server: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IrcMessage -> String
forall a. Show a => a -> String
show IrcMessage
msg
    case String
-> Map String (DSum ModuleID ServerRef)
-> Maybe (DSum ModuleID ServerRef)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (IrcMessage -> String
forall a. Message a => a -> String
Msg.server IrcMessage
msg) Map String (DSum ModuleID ServerRef)
s of
        Just (ModuleID a
mTag :=> ServerRef Server a
sendf) -> 
            LB () -> LB ()
withUEHandler (ModuleID a -> LB () -> ModuleT a LB () -> LB ()
forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
mTag LB ()
bogus (Server a
sendf IrcMessage
msg))
        Maybe (DSum ModuleID ServerRef)
Nothing -> LB ()
bogus

received :: IrcMessage -> LB ()
received :: IrcMessage -> LB ()
received IrcMessage
msg = do
    IRCRWState
s       <- LB IRCRWState
forall s (m :: * -> *). MonadState s m => m s
get
    case String
-> Map String (DMap ModuleID CallbackRef)
-> Maybe (DMap ModuleID CallbackRef)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (IrcMessage -> String
ircMsgCommand IrcMessage
msg) (IRCRWState -> Map String (DMap ModuleID CallbackRef)
ircCallbacks IRCRWState
s) of
        Just DMap ModuleID CallbackRef
cbs -> [DSum ModuleID CallbackRef]
-> (DSum ModuleID CallbackRef -> LB ()) -> LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (DMap ModuleID CallbackRef -> [DSum ModuleID CallbackRef]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
D.toList DMap ModuleID CallbackRef
cbs) ((DSum ModuleID CallbackRef -> LB ()) -> LB ())
-> (DSum ModuleID CallbackRef -> LB ()) -> LB ()
forall a b. (a -> b) -> a -> b
$ \(ModuleID a
tag :=> CallbackRef Callback a
cb) ->
            LB () -> LB ()
withUEHandler (ModuleID a -> LB () -> ModuleT a LB () -> LB ()
forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
tag (() -> LB ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Callback a
cb IrcMessage
msg))
        Maybe (DMap ModuleID CallbackRef)
_        -> () -> LB ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

applyOutputFilter :: Nick -> DSum ModuleID OutputFilterRef -> [String] -> LB [String]
applyOutputFilter :: Nick -> DSum ModuleID OutputFilterRef -> [String] -> LB [String]
applyOutputFilter Nick
who (ModuleID a
mTag :=> OutputFilterRef OutputFilter a
f) [String]
msg =
    ModuleID a -> LB [String] -> ModuleT a LB [String] -> LB [String]
forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
mTag ([String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
msg) (OutputFilter a
f Nick
who [String]
msg)

applyOutputFilters :: Nick -> String -> LB [String]
applyOutputFilters :: Nick -> String -> LB [String]
applyOutputFilters Nick
who String
msg = do
    [DSum ModuleID OutputFilterRef]
filters   <- (IRCRWState -> [DSum ModuleID OutputFilterRef])
-> LB [DSum ModuleID OutputFilterRef]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters
    (DSum ModuleID OutputFilterRef -> LB [String] -> LB [String])
-> LB [String] -> [DSum ModuleID OutputFilterRef] -> LB [String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\DSum ModuleID OutputFilterRef
a LB [String]
x -> Nick -> DSum ModuleID OutputFilterRef -> [String] -> LB [String]
applyOutputFilter Nick
who DSum ModuleID OutputFilterRef
a ([String] -> LB [String]) -> LB [String] -> LB [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB [String]
x) (([String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> LB [String])
-> (String -> [String]) -> String -> LB [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
msg) [DSum ModuleID OutputFilterRef]
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 :: String -> LB a -> (forall st. ModuleT st LB a) -> LB a
inModuleNamed String
name LB a
nothing forall st. ModuleT st LB a
just = do
    Maybe (Some ModuleInfo)
mbMod <- (IRCRWState -> Maybe (Some ModuleInfo))
-> LB (Maybe (Some ModuleInfo))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String -> Map String (Some ModuleInfo) -> Maybe (Some ModuleInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Map String (Some ModuleInfo) -> Maybe (Some ModuleInfo))
-> (IRCRWState -> Map String (Some ModuleInfo))
-> IRCRWState
-> Maybe (Some ModuleInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName)
    case Maybe (Some ModuleInfo)
mbMod of
        Maybe (Some ModuleInfo)
Nothing             -> LB a
nothing
        Just (Some ModuleInfo a
modInfo) -> ModuleT a LB a -> ModuleInfo a -> LB a
forall st (m :: * -> *) a. ModuleT st m a -> ModuleInfo st -> m a
runModuleT ModuleT a LB a
forall st. ModuleT st LB a
just ModuleInfo a
modInfo

inModuleWithID :: ModuleID st -> LB a -> (ModuleT st LB a) -> LB a
inModuleWithID :: ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID st
tag LB a
nothing ModuleT st LB a
just = do
    Maybe (ModuleInfo st)
mbMod <- (IRCRWState -> Maybe (ModuleInfo st)) -> LB (Maybe (ModuleInfo st))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ModuleID st -> DMap ModuleID ModuleInfo -> Maybe (ModuleInfo st)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
D.lookup ModuleID st
tag (DMap ModuleID ModuleInfo -> Maybe (ModuleInfo st))
-> (IRCRWState -> DMap ModuleID ModuleInfo)
-> IRCRWState
-> Maybe (ModuleInfo st)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> DMap ModuleID ModuleInfo
ircModulesByID )
    case Maybe (ModuleInfo st)
mbMod of
        Maybe (ModuleInfo st)
Nothing         -> LB a
nothing
        Just ModuleInfo st
modInfo    -> ModuleT st LB a -> ModuleInfo st -> LB a
forall st (m :: * -> *) a. ModuleT st m a -> ModuleInfo st -> m a
runModuleT ModuleT st LB a
just ModuleInfo st
modInfo

withCommand :: String -> LB a -> (forall st. Command (ModuleT st LB) -> ModuleT st LB a) -> LB a
withCommand :: String
-> LB a
-> (forall st. Command (ModuleT st LB) -> ModuleT st LB a)
-> LB a
withCommand String
cmdname LB a
def forall st. Command (ModuleT st LB) -> ModuleT st LB a
f = do
    Maybe (DSum ModuleID CommandRef)
mbCmd <- (IRCRWState -> Maybe (DSum ModuleID CommandRef))
-> LB (Maybe (DSum ModuleID CommandRef))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String
-> Map String (DSum ModuleID CommandRef)
-> Maybe (DSum ModuleID CommandRef)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
cmdname (Map String (DSum ModuleID CommandRef)
 -> Maybe (DSum ModuleID CommandRef))
-> (IRCRWState -> Map String (DSum ModuleID CommandRef))
-> IRCRWState
-> Maybe (DSum ModuleID CommandRef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands)
    case Maybe (DSum ModuleID CommandRef)
mbCmd of
        Just (ModuleID a
tag :=> CommandRef Command (ModuleT a LB)
cmd)   -> ModuleID a -> LB a -> ModuleT a LB a -> LB a
forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
tag LB a
def (Command (ModuleT a LB) -> ModuleT a LB a
forall st. Command (ModuleT st LB) -> ModuleT st LB a
f Command (ModuleT a LB)
cmd)
        Maybe (DSum ModuleID CommandRef)
_                               -> LB a
def

listModules :: LB [String]
listModules :: LB [String]
listModules = (IRCRWState -> [String]) -> LB [String]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map String (Some ModuleInfo) -> [String]
forall k a. Map k a -> [k]
M.keys (Map String (Some ModuleInfo) -> [String])
-> (IRCRWState -> Map String (Some ModuleInfo))
-> IRCRWState
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName)

-- | Interpret a function in the context of all modules
withAllModules :: (forall st. ModuleT st LB a) -> LB ()
withAllModules :: (forall st. ModuleT st LB a) -> LB ()
withAllModules forall st. ModuleT st LB a
f = do
    [Some ModuleInfo]
mods <- (IRCRWState -> [Some ModuleInfo]) -> LB [Some ModuleInfo]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((IRCRWState -> [Some ModuleInfo]) -> LB [Some ModuleInfo])
-> (IRCRWState -> [Some ModuleInfo]) -> LB [Some ModuleInfo]
forall a b. (a -> b) -> a -> b
$ Map String (Some ModuleInfo) -> [Some ModuleInfo]
forall k a. Map k a -> [a]
M.elems (Map String (Some ModuleInfo) -> [Some ModuleInfo])
-> (IRCRWState -> Map String (Some ModuleInfo))
-> IRCRWState
-> [Some ModuleInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName
    [Some ModuleInfo] -> (Some ModuleInfo -> LB a) -> LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Some ModuleInfo]
mods ((Some ModuleInfo -> LB a) -> LB ())
-> (Some ModuleInfo -> LB a) -> LB ()
forall a b. (a -> b) -> a -> b
$ \(Some ModuleInfo a
modInfo) -> ModuleT a LB a -> ModuleInfo a -> LB a
forall st (m :: * -> *) a. ModuleT st m a -> ModuleInfo st -> m a
runModuleT ModuleT a LB a
forall st. ModuleT st LB a
f ModuleInfo a
modInfo