module Network.IRC.Bot.Parsec where
import Control.Applicative ((<$>))
import Control.Monad
import Control.Monad.Reader (MonadReader, ask)
import Control.Monad.Trans
import Data.Char (digitToInt)
import Data.List (intercalate, isPrefixOf, nub)
import Data.Maybe (fromMaybe)
import Network.IRC.Bot.Log
import Network.IRC.Bot.BotMonad
import Network.IRC.Bot.Commands
import Text.Parsec
import Text.Parsec.Error (errorMessages, messageString)
import qualified Text.Parsec.Error as P
instance (BotMonad m, Monad m) => BotMonad (ParsecT s u m) where
askBotEnv = lift askBotEnv
askMessage = lift askMessage
askOutChan = lift askOutChan
localMessage f m = mapParsecT (localMessage f) m
sendMessage = lift . sendMessage
logM lvl msg = lift (logM lvl msg)
whoami = lift whoami
mapParsecT :: (Monad m, Monad n) => (m (Consumed (m (Reply s u a))) -> n (Consumed (n (Reply s u b)))) -> ParsecT s u m a -> ParsecT s u n b
mapParsecT f p = mkPT $ \s -> f (runParsecT p s)
nat :: (Monad m) => ParsecT String () m Integer
nat =
do digits <- many1 digit
return $ foldl (\x d -> x * 10 + fromIntegral (digitToInt d)) 0 digits
botPrefix :: (BotMonad m) => ParsecT String () m ()
botPrefix =
do recv <- fromMaybe "" <$> askReceiver
pref <- cmdPrefix <$> askBotEnv
if "#" `isPrefixOf` recv
then (try $ string pref >> return ()) <|> lift mzero
else (try $ string pref >> return ()) <|> return ()
parsecPart :: (BotMonad m) =>
(ParsecT String () m a)
-> m a
parsecPart p =
do priv <- privMsg
logM Debug $ "I got a message: " ++ msg priv ++ " sent to " ++ show (receivers priv)
ma <- runParserT p () (msg priv) (msg priv)
case ma of
(Left e) ->
do logM Debug $ "Parse error: " ++ show e
reportError (head (receivers priv)) e
mzero
(Right a) -> return a
reportError :: (BotMonad m) => String -> ParseError -> m ()
reportError target err =
let errStrs = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages err)
errStr = intercalate "; " errStrs
in sendCommand (PrivMsg Nothing [target] errStr)
showErrorMessages ::
String -> String -> String -> String -> String -> [P.Message] -> [String]
showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
| null msgs = [msgUnknown]
| otherwise = clean $
[showSysUnExpect,showUnExpect,showExpect,showMessages]
where
(sysUnExpect,msgs1) = span ((P.SysUnExpect "") ==) msgs
(unExpect,msgs2) = span ((P.UnExpect "") ==) msgs1
(expect,messages) = span ((P.Expect "") ==) msgs2
showExpect = showMany msgExpecting expect
showUnExpect = showMany msgUnExpected unExpect
showSysUnExpect | not (null unExpect) ||
null sysUnExpect = ""
| null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput
| otherwise = msgUnExpected ++ " " ++ firstMsg
where
firstMsg = messageString (head sysUnExpect)
showMessages = showMany "" messages
showMany pre msgs = case clean (map messageString msgs) of
[] -> ""
ms | null pre -> commasOr ms
| otherwise -> pre ++ " " ++ commasOr ms
commasOr [] = ""
commasOr [m] = m
commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
commaSep = seperate ", " . clean
seperate _ [] = ""
seperate _ [m] = m
seperate sep (m:ms) = m ++ sep ++ seperate sep ms
clean = nub . filter (not . null)