{-# 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     <- 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)

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

-- ---------------------------------------------------------------------
--
-- 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 { 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)

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

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')

-- 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 :: 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')

-- TODO: fix race condition
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

------------------------------------------------------------------------
-- Module handling

-- | Interpret an expression in the context of a module.
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)

-- | Interpret a function in the context of all modules
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