diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index fe48a00..37de52d 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.hs @@ -29,7 +29,7 @@ import Network.IRC.Util $(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR]) data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq) -data In = Timeout | EOD | Msg Message deriving (Show, Eq) +data In = Timeout | EOD | Msg !Message deriving (Show, Eq) sendCommandLoop :: MessageChannel Message -> Bot -> IO () sendCommandLoop commandChan bot@Bot { .. } = do diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index b5143cb..628630a 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/hask-irc-core/Network/IRC/Client.hs @@ -37,11 +37,11 @@ import Network.IRC.Util $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR]) data ConnectionResource = ConnectionResource - { bot :: Bot - , botStatus :: MVar BotStatus - , inChannel :: MessageChannel In - , mainMsgChannel :: MessageChannel Message - , handlerMsgChannels :: [MessageChannel Message] + { bot :: !Bot + , botStatus :: !(MVar BotStatus) + , inChannel :: !(MessageChannel In) + , mainMsgChannel :: !(MessageChannel Message) + , handlerMsgChannels :: !(Map MsgHandlerName (MessageChannel Message)) } connect :: BotConfig -> IO ConnectionResource @@ -63,7 +63,7 @@ connect botConfig@BotConfig { .. } = do mempty (mapToList msgHandlersChans) let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'} - let msgHandlerChannels = map snd (mapValues msgHandlersChans) + let msgHandlerChannels = map snd msgHandlersChans let msgHandlers = map fst msgHandlersChans return $ ConnectionResource @@ -132,7 +132,8 @@ runBotIntenal botConfig' = withSocketsDo $ do Just UserInterrupt -> debugM "User interrupt" >> return Interrupted _ -> debugM ("Exception! " ++ show e) >> return Errored - runHandler botConfig ((msgHandlerName, handler), msgChannel) = receiveMessage msgChannel >>= go + runHandler :: BotConfig -> (MsgHandlerName, (MsgHandler, MessageChannel Message)) -> IO () + runHandler botConfig (msgHandlerName, (handler, msgChannel)) = receiveMessage msgChannel >>= go where go msg@Message { .. } | Just QuitCmd <- fromMessage message = do @@ -143,7 +144,7 @@ runBotIntenal botConfig' = withSocketsDo $ do | otherwise = do resps <- handleMessage handler botConfig msg forM_ resps $ sendMessage msgChannel - runHandler botConfig ((msgHandlerName, handler), msgChannel) + runHandler botConfig (msgHandlerName, (handler, msgChannel)) run = bracket (connect botConfigWithCore) disconnect $ \ConnectionResource { .. } -> @@ -156,7 +157,7 @@ runBotIntenal botConfig' = withSocketsDo $ do fork $ sendCommandLoop mainMsgChannel bot fork $ readMessageLoop botStatus inChannel bot oneSec - forM_ (zip (mapToList msgHandlers) handlerMsgChannels) $ + forM_ (mapToList . asMap $ mergeMaps msgHandlers handlerMsgChannels) $ void . fork . runHandler botConfig runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel) diff --git a/hask-irc-core/Network/IRC/Util.hs b/hask-irc-core/Network/IRC/Util.hs index 0ad8e49..0caf74a 100644 --- a/hask-irc-core/Network/IRC/Util.hs +++ b/hask-irc-core/Network/IRC/Util.hs @@ -1,13 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} module Network.IRC.Util where -import qualified Data.Text.Format as TF +import qualified Data.Text.Format as TF import ClassyPrelude import Control.Monad.Base (MonadBase) import Data.Convertible (convert) +import Data.Maybe (fromJust) import Data.Text (strip) import Data.Time (diffUTCTime) @@ -20,6 +22,18 @@ mapKeys = map fst . mapToList mapValues :: IsMap map => map -> [MapValue map] mapValues = map snd . mapToList +mergeMaps :: forall map map1 map2. + (IsMap map1, IsMap map2, IsMap map, + MapValue map ~ (MapValue map1, MapValue map2), + ContainerKey map1 ~ ContainerKey map, + ContainerKey map2 ~ ContainerKey map) => + map1 -> map2 -> map +mergeMaps map1 map2 = + flip (`foldl'` mempty) (mapKeys map1) $ \acc key -> + if key `member` map2 + then insertMap key (fromJust $ lookup key map1, fromJust $ lookup key map2) acc + else acc + whenJust :: Monad m => Maybe t -> (t -> m ()) -> m () whenJust m f = maybe (return ()) f m