{-# 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
quitMVar <- IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
initDoneMVar <- newEmptyMVar
let 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)
return IRCRState
{ ircQuitMVar = quitMVar
, ircInitDoneMVar = initDoneMVar
, ircConfig = D.fromListWithKey mergeConfig' configuration
}
reportInitDone :: LB ()
reportInitDone :: LB ()
reportInitDone = do
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 $ putMVar mvar ()
askLB :: MonadLB m => (IRCRState -> a) -> m a
askLB :: forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> a
f = LB a -> m a
forall a. 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 :: forall (m :: * -> *). MonadLB m => 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 :: forall (m :: * -> *). MonadLB m => 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)
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 = 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
}
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 -> 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
$cfmap :: forall a b. (a -> b) -> LB a -> LB b
fmap :: forall a b. (a -> b) -> LB a -> LB b
$c<$ :: forall a b. a -> LB b -> LB a
<$ :: forall a b. a -> LB b -> LB a
Functor, Functor LB
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
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
$cpure :: forall a. a -> LB a
pure :: forall a. a -> LB a
$c<*> :: forall a b. LB (a -> b) -> LB a -> LB b
<*> :: forall a b. LB (a -> b) -> LB a -> LB b
$cliftA2 :: forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c
liftA2 :: forall a b c. (a -> b -> c) -> LB a -> LB b -> LB c
$c*> :: forall a b. LB a -> LB b -> LB b
*> :: forall a b. LB a -> LB b -> LB b
$c<* :: forall a b. LB a -> LB b -> LB a
<* :: forall a b. LB a -> LB b -> LB a
Applicative, Applicative LB
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
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
$c>>= :: forall a b. LB a -> (a -> LB b) -> LB b
>>= :: forall a b. LB a -> (a -> LB b) -> LB b
$c>> :: forall a b. LB a -> LB b -> LB b
>> :: forall a b. LB a -> LB b -> LB b
$creturn :: forall a. a -> LB a
return :: forall a. a -> LB a
Monad, Monad LB
Monad LB => (forall a. IO a -> LB a) -> MonadIO LB
forall a. IO a -> LB a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> LB a
liftIO :: forall a. IO a -> LB a
MonadIO, Monad LB
Monad LB => (forall a. String -> LB a) -> MonadFail LB
forall a. String -> LB a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> LB a
fail :: forall a. String -> LB a
MonadFail,
#if !defined(MIN_VERSION_haskeline) || !MIN_VERSION_haskeline(0,8,0)
MonadException,
#endif
Monad LB
Monad LB =>
(forall e a. (HasCallStack, Exception e) => e -> LB a)
-> MonadThrow LB
forall e a. (HasCallStack, Exception e) => e -> LB a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> LB a
throwM :: forall e a. (HasCallStack, Exception e) => e -> LB a
MonadThrow, MonadThrow LB
MonadThrow LB =>
(forall e a.
(HasCallStack, Exception e) =>
LB a -> (e -> LB a) -> LB a)
-> MonadCatch LB
forall e a.
(HasCallStack, Exception e) =>
LB a -> (e -> LB a) -> LB a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
(HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
LB a -> (e -> LB a) -> LB a
catch :: forall e a.
(HasCallStack, Exception e) =>
LB a -> (e -> LB a) -> LB a
MonadCatch, MonadCatch LB
MonadCatch LB =>
(forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b)
-> (forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b)
-> (forall a b c.
HasCallStack =>
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c))
-> MonadMask LB
forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b
forall a b c.
HasCallStack =>
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
HasCallStack =>
((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
HasCallStack =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b
mask :: forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. LB a -> LB a) -> LB b) -> LB b
$cgeneralBracket :: forall a b c.
HasCallStack =>
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
generalBracket :: forall a b c.
HasCallStack =>
LB a -> (a -> ExitCase b -> LB c) -> (a -> LB b) -> LB (b, c)
MonadMask)
runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a
runLB :: forall a. 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 :: forall a. IO a -> LB a
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 α. 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 :: forall a. (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 a.
(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
ReaderT (IRCRState, IORef IRCRWState) IO a
-> IO (StM (ReaderT (IRCRState, IORef IRCRWState) 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 :: forall a. 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
StM (ReaderT (IRCRState, IORef IRCRWState) IO) a
-> ReaderT (IRCRState, IORef IRCRWState) IO a
forall a.
StM (ReaderT (IRCRState, IORef IRCRWState) IO) 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 :: forall a. LB a -> LB a
lb = LB a -> LB a
forall a. a -> a
id
instance MonadLB m => MonadLB (ModuleT st m) where lb :: forall a. LB a -> ModuleT st m a
lb = m a -> ModuleT st m a
forall (m :: * -> *) a. Monad m => 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 a. LB a -> m a
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 = m a -> Cmd m a
forall (m :: * -> *) a. Monad m => 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 a. LB a -> m a
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 = 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
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
lift . atomicModifyIORef ref $ \IRCRWState
s ->
let (a
s', IRCRWState
x) = IRCRWState -> (a, IRCRWState)
f IRCRWState
s
in a -> (IRCRWState, a) -> (IRCRWState, a)
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 = (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 a. LB a -> LB a
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 a. Config a -> LB a
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)
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
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
mInfo <- ModuleInfo mName mTag m <$> newMVar mState
modify $ \IRCRWState
s -> IRCRWState
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 :: forall st. [Command (ModuleT st LB)] -> ModuleT st LB ()
registerCommands [Command (ModuleT st LB)]
cmds = do
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
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
]
lift $ modify $ \IRCRWState
s -> IRCRWState
s
{ ircCommands = M.union (M.fromList taggedCmds) (ircCommands s)
}
registerCallback :: String -> Callback st -> ModuleT st LB ()
registerCallback :: forall st. String -> Callback st -> ModuleT st LB ()
registerCallback String
str Callback st
f = do
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
lift . modify $ \IRCRWState
s -> IRCRWState
s
{ ircCallbacks = M.insertWith D.union str
(D.singleton mTag (CallbackRef f))
(ircCallbacks s)
}
registerOutputFilter :: OutputFilter st -> ModuleT st LB ()
registerOutputFilter :: forall st. OutputFilter st -> ModuleT st LB ()
registerOutputFilter OutputFilter st
f = do
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
lift . modify $ \IRCRWState
s -> IRCRWState
s
{ ircOutputFilters = (mTag :=> OutputFilterRef f) : ircOutputFilters 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 a. a -> LB a
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 a. (IRCRWState -> (a, IRCRWState)) -> LB a
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 :: forall (f :: * -> *). 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 = 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 (Maybe String
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
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
maybe (return ()) fail <=< lb . state $ \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 = M.insert sName (mTag :=> ServerRef sendf) (ircServerMap s)}
in (Maybe String
forall a. Maybe a
Nothing, IRCRWState
s')
unregisterServer :: String -> ModuleT mod LB ()
unregisterServer :: forall mod. String -> ModuleT mod LB ()
unregisterServer String
tag = LB () -> ModuleT mod LB ()
forall a. LB a -> ModuleT mod LB a
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
s <- LB IRCRWState
forall s (m :: * -> *). MonadState s m => m s
get
let svrs = IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
s
case M.lookup tag 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 = 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
quitMVar <- (IRCRState -> MVar ()) -> LB (MVar ())
forall (m :: * -> *) a. MonadLB m => (IRCRState -> a) -> m a
askLB IRCRState -> MVar ()
ircQuitMVar
io $ putMVar quitMVar ()
Maybe (DSum ModuleID ServerRef)
Nothing -> String -> LB ()
forall a. String -> LB a
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
handler <- Config DIH -> LB DIH
forall a. Config a -> LB a
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config DIH
uncaughtExceptionHandler
E.catch f (io . handler)
send :: IrcMessage -> LB ()
send :: IrcMessage -> LB ()
send IrcMessage
msg = do
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 = 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 M.lookup (Msg.server msg) 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
s <- LB IRCRWState
forall s (m :: * -> *). MonadState s m => m s
get
case M.lookup (ircMsgCommand msg) (ircCallbacks 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 a. a -> LB a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Callback a
cb IrcMessage
msg))
Maybe (DMap ModuleID CallbackRef)
_ -> () -> LB ()
forall a. a -> LB a
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 a. a -> LB a
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
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
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) ((return . lines) msg) 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
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 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 :: 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
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 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 :: 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
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 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)
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
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
forM_ mods $ \(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