{-# 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
data IRCRState = IRCRState
{ IRCRState -> MVar ()
ircInitDoneMVar :: MVar ()
, IRCRState -> MVar ()
ircQuitMVar :: MVar ()
, IRCRState -> DMap Config Identity
ircConfig :: D.DMap Config Identity
}
initRoState :: [DSum Config Identity] -> IO IRCRState
initRoState :: [DSum Config Identity] -> IO IRCRState
initRoState [DSum Config Identity]
configuration = do
MVar ()
quitMVar <- forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
MVar ()
initDoneMVar <- 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) = forall a. a -> Identity a
Identity (forall t. Config t -> t -> t -> t
mergeConfig Config a
k a
y a
x)
forall (m :: * -> *) a. Monad m => a -> m a
return IRCRState
{ ircQuitMVar :: MVar ()
ircQuitMVar = MVar ()
quitMVar
, ircInitDoneMVar :: MVar ()
ircInitDoneMVar = MVar ()
initDoneMVar
, ircConfig :: DMap Config Identity
ircConfig = 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 {a}. Config a -> Identity a -> Identity a -> Identity a
mergeConfig' [DSum Config Identity]
configuration
}
reportInitDone :: LB ()
reportInitDone :: LB ()
reportInitDone = do
MVar ()
mvar <- forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (IRCRState -> MVar ()
ircInitDoneMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
mvar ()
askLB :: MonadLB m => (IRCRState -> a) -> m a
askLB :: forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> a
f = forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (IRCRState -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
waitForInit :: MonadLB m => m ()
waitForInit :: forall (m :: * -> *). MonadLB m => m ()
waitForInit = forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> MVar ()
ircInitDoneMVar
waitForQuit :: MonadLB m => m ()
waitForQuit :: forall (m :: * -> *). MonadLB m => m ()
waitForQuit = forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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)
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
, IRCRWState -> Map String Bool
ircPersists :: M.Map String Bool
, 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]
, IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands :: M.Map String (DSum ModuleID CommandRef)
}
initRwState :: IRCRWState
initRwState :: IRCRWState
initRwState = IRCRWState
{ ircPrivilegedUsers :: Set Nick
ircPrivilegedUsers = forall a. Set a
S.empty
, ircIgnoredUsers :: Set Nick
ircIgnoredUsers = forall a. Set a
S.empty
, ircChannels :: Map ChanName String
ircChannels = forall k a. Map k a
M.empty
, ircPersists :: Map String Bool
ircPersists = forall k a. Map k a
M.empty
, ircModulesByName :: Map String (Some ModuleInfo)
ircModulesByName = forall k a. Map k a
M.empty
, ircModulesByID :: DMap ModuleID ModuleInfo
ircModulesByID = forall {k1} (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f
D.empty
, ircServerMap :: Map String (DSum ModuleID ServerRef)
ircServerMap = forall k a. Map k a
M.empty
, ircCallbacks :: Map String (DMap ModuleID CallbackRef)
ircCallbacks = forall k a. Map k a
M.empty
, ircOutputFilters :: [DSum ModuleID OutputFilterRef]
ircOutputFilters = []
, ircCommands :: Map String (DSum ModuleID CommandRef)
ircCommands = forall k a. Map k a
M.empty
}
newtype LB a = LB { forall a. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
unLB :: ReaderT (IRCRState, IORef IRCRWState) IO a }
deriving (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
<$ :: forall a b. a -> LB b -> LB a
$c<$ :: forall a b. a -> LB b -> LB a
fmap :: forall a b. (a -> b) -> LB a -> LB b
$cfmap :: forall a b. (a -> b) -> LB a -> LB b
Functor, Functor LB
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
<* :: forall a b. LB a -> LB b -> LB a
$c<* :: forall a b. LB a -> LB b -> LB a
*> :: forall a b. LB a -> LB b -> LB b
$c*> :: forall a b. LB a -> LB b -> LB b
liftA2 :: forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c
$cliftA2 :: forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c
<*> :: forall a b. LB (a -> b) -> LB a -> LB b
$c<*> :: forall a b. LB (a -> b) -> LB a -> LB b
pure :: forall a. a -> LB a
$cpure :: forall a. a -> LB a
Applicative, Applicative LB
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 :: forall a. a -> LB a
$creturn :: forall a. a -> LB a
>> :: forall a b. LB a -> LB b -> LB b
$c>> :: forall a b. LB a -> LB b -> LB b
>>= :: forall a b. LB a -> (a -> LB b) -> LB b
$c>>= :: forall a b. LB a -> (a -> LB b) -> LB b
Monad, Monad LB
forall a. IO a -> LB a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> LB a
$cliftIO :: forall a. IO a -> LB a
MonadIO, Monad LB
forall a. String -> LB a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> LB a
$cfail :: forall a. String -> LB a
MonadFail,
#if !defined(MIN_VERSION_haskeline) || !MIN_VERSION_haskeline(0,8,0)
MonadException,
#endif
Monad LB
forall e a. Exception e => e -> LB a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> LB a
$cthrowM :: forall e a. Exception e => e -> LB a
MonadThrow, MonadThrow LB
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 :: forall e a. Exception e => LB a -> (e -> LB a) -> LB a
$ccatch :: forall e a. Exception e => LB a -> (e -> LB a) -> LB a
MonadCatch, MonadCatch LB
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 :: forall a b c.
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 b. ((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 b. ((forall a. LB a -> LB a) -> LB b) -> LB b
$cmask :: forall b. ((forall a. LB a -> LB a) -> LB b) -> LB b
MonadMask)
runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a
runLB :: forall a. LB a -> (IRCRState, IORef IRCRWState) -> IO a
runLB = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
unLB
instance MonadBase IO LB where
liftBase :: forall a. IO a -> LB a
liftBase = forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. (RunInBase LB IO -> IO a) -> LB a
liftBaseWith RunInBase LB IO -> IO a
action = forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB (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 (RunInBase (ReaderT (IRCRState, IORef IRCRWState) IO) IO
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. LB a -> ReaderT (IRCRState, IORef IRCRWState) IO a
unLB)))
restoreM :: forall a. StM LB a -> LB a
restoreM = forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. LB a -> LB a
lb = forall a. a -> a
id
instance MonadLB m => MonadLB (ModuleT st m) where lb :: forall a. LB a -> ModuleT st m a
lb = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb
instance MonadLB m => MonadLB (Cmd m) where lb :: forall a. LB a -> Cmd m a
lb = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb
instance MonadState IRCRWState LB where
state :: forall a. (IRCRWState -> (a, IRCRWState)) -> LB a
state IRCRWState -> (a, IRCRWState)
f = forall a. ReaderT (IRCRState, IORef IRCRWState) IO a -> LB a
LB forall a b. (a -> b) -> a -> b
$ do
IORef IRCRWState
ref <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> b
snd
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef IRCRWState
ref forall a b. (a -> b) -> a -> b
$ \IRCRWState
s ->
let (a
s', IRCRWState
x) = IRCRWState -> (a, IRCRWState)
f IRCRWState
s
in seq :: forall a b. a -> b -> b
seq a
s' (IRCRWState
x, a
s')
instance MonadConfig LB where
getConfig :: forall a. Config a -> LB a
getConfig Config a
k = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall t. Config t -> t
getConfigDefault Config a
k) forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
D.lookup Config a
k) (forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> DMap Config Identity
ircConfig))
instance MonadLogging LB where
getCurrentLogger :: LB [String]
getCurrentLogger = 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall (m :: * -> *).
MonadLogging m =>
String -> Priority -> String -> m ()
logM String
a Priority
b String
c)
registerModule :: String -> Module st -> st -> LB (ModuleInfo st)
registerModule :: forall st. String -> Module st -> st -> LB (ModuleInfo st)
registerModule String
mName Module st
m st
mState = do
ModuleID st
mTag <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall st. IO (ModuleID st)
newModuleID
ModuleInfo st
mInfo <- forall st.
String -> ModuleID st -> Module st -> MVar st -> ModuleInfo st
ModuleInfo String
mName ModuleID st
mTag Module st
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar st
mState
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
{ ircModulesByName :: Map String (Some ModuleInfo)
ircModulesByName = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
mName (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 = 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)
}
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleInfo st
mInfo
registerCommands :: [Command (ModuleT st LB)] -> ModuleT st LB ()
registerCommands :: forall st. [Command (ModuleT st LB)] -> ModuleT st LB ()
registerCommands [Command (ModuleT st LB)]
cmds = do
ModuleID st
mTag <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> ModuleID st
moduleID
let taggedCmds :: [(String, DSum ModuleID CommandRef)]
taggedCmds =
[ (String
cName, ModuleID st
mTag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> 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 <- forall (m :: * -> *). Command m -> [String]
cmdNames Command (ModuleT st LB)
cmd
]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
{ ircCommands :: Map String (DSum ModuleID CommandRef)
ircCommands = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (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 :: forall st. String -> Callback st -> ModuleT st LB ()
registerCallback String
str Callback st
f = do
ModuleID st
mTag <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> ModuleID st
moduleID
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
{ ircCallbacks :: Map String (DMap ModuleID CallbackRef)
ircCallbacks = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
DMap k2 f -> DMap k2 f -> DMap k2 f
D.union String
str
(forall {k1} (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
D.singleton ModuleID st
mTag (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 :: forall st. OutputFilter st -> ModuleT st LB ()
registerOutputFilter OutputFilter st
f = do
ModuleID st
mTag <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> ModuleID st
moduleID
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
{ ircOutputFilters :: [DSum ModuleID OutputFilterRef]
ircOutputFilters = (ModuleID st
mTag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall st. OutputFilter st -> OutputFilterRef st
OutputFilterRef OutputFilter st
f) forall a. a -> [a] -> [a]
: IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters IRCRWState
s
}
unregisterModule :: String -> LB ()
unregisterModule :: String -> LB ()
unregisterModule String
mName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). MonadLogging m => String -> m ()
warningM forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \IRCRWState
s ->
case 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 -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"Tried to unregister module that wasn't registered: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
mName, IRCRWState
s)
Just (Some ModuleInfo a
modInfo) ->
let mTag :: ModuleID a
mTag = forall st. ModuleInfo st -> ModuleID st
moduleID ModuleInfo a
modInfo
notSomeTag :: DSum ModuleID f -> Bool
notSomeTag :: forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag (ModuleID a
tag :=> f a
_) = forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some ModuleID a
tag forall a. Eq a => a -> a -> Bool
/= 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 = 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 = 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 = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag (IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands IRCRWState
s)
, ircCallbacks :: Map String (DMap ModuleID CallbackRef)
ircCallbacks = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (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 = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag (IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
s)
, ircOutputFilters :: [DSum ModuleID OutputFilterRef]
ircOutputFilters = forall a. (a -> Bool) -> [a] -> [a]
filter forall (f :: * -> *). DSum ModuleID f -> Bool
notSomeTag (IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters IRCRWState
s)
}
in (forall a. Maybe a
Nothing, IRCRWState
s')
registerServer :: String -> Server st -> ModuleT st LB ()
registerServer :: forall st. String -> Callback st -> ModuleT st LB ()
registerServer String
sName Server st
sendf = do
ModuleID st
mTag <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> ModuleID st
moduleID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \IRCRWState
s ->
case 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
_ -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"attempted to create two servers named " 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 = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
sName (ModuleID st
mTag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall st. Server st -> ServerRef st
ServerRef Server st
sendf) (IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
s)}
in (forall a. Maybe a
Nothing, IRCRWState
s')
unregisterServer :: String -> ModuleT mod LB ()
unregisterServer :: forall mod. String -> ModuleT mod LB ()
unregisterServer String
tag = forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall a b. (a -> b) -> a -> b
$ do
IRCRWState
s <- 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 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' = forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
tag Map String (DSum ModuleID ServerRef)
svrs
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IRCRWState
s { ircServerMap :: Map String (DSum ModuleID ServerRef)
ircServerMap = Map String (DSum ModuleID ServerRef)
svrs' })
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Map k a -> Bool
M.null Map String (DSum ModuleID ServerRef)
svrs') forall a b. (a -> b) -> a -> b
$ do
MVar ()
quitMVar <- forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> MVar ()
ircQuitMVar
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
quitMVar ()
Maybe (DSum ModuleID ServerRef)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"attempted to delete nonexistent servers named " forall a. [a] -> [a] -> [a]
++ String
tag
withUEHandler :: LB () -> LB ()
withUEHandler :: LB () -> LB ()
withUEHandler LB ()
f = do
DIH
handler <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config DIH
uncaughtExceptionHandler
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch LB ()
f (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap
let bogus :: LB ()
bogus = forall (m :: * -> *). MonadLogging m => String -> m ()
warningM forall a b. (a -> b) -> a -> b
$ String
"sending message to bogus server: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IrcMessage
msg
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (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 (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 <- forall s (m :: * -> *). MonadState s m => m s
get
case 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 -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
D.toList DMap ModuleID CallbackRef
cbs) forall a b. (a -> b) -> a -> b
$ \(ModuleID a
tag :=> CallbackRef Callback a
cb) ->
LB () -> LB ()
withUEHandler (forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
tag (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Callback a
cb IrcMessage
msg))
Maybe (DMap ModuleID CallbackRef)
_ -> 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 =
forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
mTag (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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> [DSum ModuleID OutputFilterRef]
ircOutputFilters
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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB [String]
x) ((forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
msg) [DSum ModuleID OutputFilterRef]
filters
inModuleNamed :: String -> LB a -> (forall st. ModuleT st LB a) -> LB a
inModuleNamed :: forall a. 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name 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) -> forall st (m :: * -> *) a. ModuleT st m a -> ModuleInfo st -> m a
runModuleT forall st. ModuleT st LB a
just ModuleInfo a
modInfo
inModuleWithID :: ModuleID st -> LB a -> (ModuleT st LB a) -> LB a
inModuleWithID :: forall st a. 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
D.lookup ModuleID st
tag 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 -> 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 :: forall a.
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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
cmdname 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) -> forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID a
tag LB a
def (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 = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName)
withAllModules :: (forall st. ModuleT st LB a) -> LB ()
withAllModules :: forall a. (forall st. ModuleT st LB a) -> LB ()
withAllModules forall st. ModuleT st LB a
f = do
[Some ModuleInfo]
mods <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (Some ModuleInfo)
ircModulesByName
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Some ModuleInfo]
mods forall a b. (a -> b) -> a -> b
$ \(Some ModuleInfo a
modInfo) -> forall st (m :: * -> *) a. ModuleT st m a -> ModuleInfo st -> m a
runModuleT forall st. ModuleT st LB a
f ModuleInfo a
modInfo