lambdabotMain now takes a list of modules

(instead of an LB action that loads them)

lambdabot-core/src/Lambdabot/Bot.hs

@@ -44,8 +44,8 @@ import qualified Data.Set as S
 --
 -- | Register a module in the irc state
 --
-ircLoadModule :: Module st -> String -> LB ()
-ircLoadModule m mName = do
+ircLoadModule :: String -> Module st -> LB ()
+ircLoadModule mName m = do
     infoM ("Loading module " ++ show mName)
 
     savedState <- readGlobalState m mName
@@ -77,7 +77,7 @@ ircUnloadModule mName = do
             `E.catch` \e@SomeException{} -> 
                 errorM ("Module " ++ show mName ++ " threw the following exception in moduleExit: " ++ show e)
 
-        writeGlobalState m mName
+        writeGlobalState
 
     unregisterModule mName
 

lambdabot-core/src/Lambdabot/Main.hs

@@ -20,7 +20,6 @@ import Lambdabot.Logging
 import Lambdabot.Module
 import Lambdabot.Monad
 import Lambdabot.Plugin.Core
-import Lambdabot.State
 import Lambdabot.Util
 import Lambdabot.Util.Signals
 
@@ -29,7 +28,7 @@ import Control.Monad.Identity
 import Data.Dependent.Sum
 import Data.List
 import Data.IORef
-import Data.Typeable
+import Data.Some
 import Data.Version
 import Language.Haskell.TH
 import Paths_lambdabot_core (version)
@@ -66,48 +65,48 @@ setupLogging = do
 -- Also, handle any fatal exceptions (such as non-recoverable signals),
 -- (i.e. print a message and exit). Non-fatal exceptions should be dealt
 -- with in the mainLoop or further down.
-lambdabotMain :: LB () -> [DSum Config Identity] -> IO ExitCode
+lambdabotMain :: Modules -> [DSum Config Identity] -> IO ExitCode
 lambdabotMain initialise cfg = withSocketsDo . withIrcSignalCatch $ do
     rost <- initRoState cfg
     rwst <- newIORef initRwState
-    r <- try $ flip runLB (rost, rwst) $ do
-        setupLogging
-        noticeM "Initialising plugins"
-        initialise
-        noticeM "Done loading plugins"
-        reportInitDone rost
-        mainLoop
-        return ExitSuccess
-
-
-    -- clean up and go home
-    case r of
-        Left (SomeException er) -> do
-            case cast er of
+    runLB (lambdabotRun initialise) (rost, rwst)
+        `E.catch` \e -> do
+            -- clean up and go home
+            case fromException e of
                 Just code -> return code
-                Nothing -> do
-                    putStrLn "exception:"
-                    print er
+                Nothing   -> do
+                    errorM (show e)
                     return (ExitFailure 1)
-        Right code -> return code
 
--- Actually, this isn't a loop anymore.  TODO: better name.
-mainLoop :: LB ()
-mainLoop = do
-    waitForQuit `E.catch`
-        (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up
+lambdabotRun :: Modules -> LB ExitCode
+lambdabotRun ms = do
+    setupLogging
+    infoM "Initialising plugins"
+    withModules ms $ do
+        infoM "Done loading plugins"
+        reportInitDone
+
+        waitForQuit `E.catch`
+            (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up
 
-    withAllModules moduleExit
-    flushModuleState
-
+    -- clean up any dynamically loaded modules
+    mapM_ ircUnloadModule =<< listModules
+    return ExitSuccess
 
 ------------------------------------------------------------------------
 
-type Modules = LB ()
+type Modules = [(String, Some Module)]
 
 modules :: [String] -> Q Exp
-modules xs = [| sequence_ $(listE $ map instalify (nub xs)) |]
+modules xs = [| $(listE $ map instalify (nub xs)) |]
     where
         instalify x =
             let module' = varE $ mkName (x ++ "Plugin")
-             in [| ircLoadModule $module' x |]
+             in [| (x, This $module') |]
+
+withModules :: Modules -> LB a -> LB a
+withModules []      = id
+withModules ((n, This m):ms)  = withModule n m . withModules ms
+
+withModule :: String -> Module st -> LB a -> LB a
+withModule name m = bracket_ (ircLoadModule name m) (ircUnloadModule name)

lambdabot-core/src/Lambdabot/Monad.hs

@@ -99,8 +99,10 @@ initRoState configuration = do
         , ircConfig         = D.fromListWithKey mergeConfig' configuration
         }
 
-reportInitDone :: MonadIO m => IRCRState -> m ()
-reportInitDone = io . flip putMVar () . ircInitDoneMVar
+reportInitDone :: LB ()
+reportInitDone = do
+    mvar <- LB (asks (ircInitDoneMVar . fst))
+    io $ putMVar mvar ()
 
 askLB :: MonadLB m => (IRCRState -> a) -> m a
 askLB f  = lb . LB $ asks (f . fst)
@@ -357,8 +359,7 @@ listModules :: LB [String]
 listModules = gets (M.keys . ircModulesByName)
 
 -- | Interpret a function in the context of all modules
-withAllModules :: (forall st. Module st -> ModuleT st LB a) -> LB ()
+withAllModules :: (forall st. ModuleT st LB a) -> LB ()
 withAllModules f = do
     mods <- gets $ M.elems . ircModulesByName
-    (`mapM_` mods) $ \(This modInfo) ->
-        runModuleT (f (theModule modInfo)) modInfo
+    forM_ mods $ \(This modInfo) -> runModuleT f modInfo

lambdabot-core/src/Lambdabot/Plugin/Core/Base.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards, FlexibleContexts #-}
 -- | Lambdabot base module. Controls message send and receive
 module Lambdabot.Plugin.Core.Base (basePlugin) where
 
@@ -280,11 +280,16 @@ docmd msg towhere rest cmd' = withPS towhere $ \_ _ -> do
 -- them bubble back up to the mainloop
 --
 doContextualMsg :: IrcMessage -> Nick -> Nick -> [Char] -> Base ()
-doContextualMsg msg target towhere r = lift $ withAllModules $ \m -> do
-    name' <- asks moduleName
-    E.catch
-        (lift . mapM_ (ircPrivmsg towhere) =<< execCmd (contextual m r) msg target "contextual") 
-        (\e@SomeException{} -> debugM . (name' ++) . (" module failed in contextual handler: " ++) $ show e)
+doContextualMsg msg target towhere r = lb (withAllModules (withHandler invokeContextual))
+    where
+        withHandler x = E.catch x $ \e@SomeException{} -> do
+            mName   <- asks moduleName
+            debugM ("Module " ++ show mName ++ " failed in contextual handler: " ++ show e)
+
+        invokeContextual = do
+            m       <- asks theModule
+            reply   <- execCmd (contextual m r) msg target "contextual"
+            lb $ mapM_ (ircPrivmsg towhere) reply
 
 ------------------------------------------------------------------------
 

lambdabot-core/src/Lambdabot/Plugin/Core/System.hs

@@ -114,7 +114,8 @@ systemPlugin = newModule
         , (command "flush")
             { privileged = True
             , help = say "flush. flush state to disk"
-            , process = \_ -> lb flushModuleState
+            , process = \_ -> lb (withAllModules writeGlobalState)
+
             }
         , (command "admin")
             { privileged = True

lambdabot-core/src/Lambdabot/State.hs

@@ -22,7 +22,6 @@ module Lambdabot.State
     , writeGS
 
     -- ** Handling global state
-    , flushModuleState
     , readGlobalState
     , writeGlobalState
   ) where
@@ -173,22 +172,21 @@ writeGS g = withGS (\_ writer -> writer g)
 -- Handling global state
 --
 
--- | flush state of modules
-flushModuleState :: LB ()
-flushModuleState = withAllModules (\m -> asks moduleName >>= writeGlobalState m)
-
 -- | Peristence: write the global state out
-writeGlobalState :: Module st -> String -> ModuleT st LB ()
-writeGlobalState module' name = do
-    debugM ("saving state for module " ++ show name)
-    case moduleSerialize module' of
+writeGlobalState :: ModuleT st LB ()
+writeGlobalState = do
+    m     <- asks theModule
+    mName <- asks moduleName
+
+    debugM ("saving state for module " ++ show mName)
+    case moduleSerialize m of
         Nothing  -> return ()
         Just ser -> do
             state' <- readMS
             case serialize ser state' of
                 Nothing  -> return ()   -- do not write any state
                 Just out -> do
-                    stateFile <- lb (findLBFileForWriting name)
+                    stateFile <- lb (findLBFileForWriting mName)
                     io (P.writeFile stateFile out)
 
 -- | Read it in