module Network.IRC.Bot.Parsec where
import Control.Applicative ((<$>))
import Control.Monad
import Control.Monad.Reader (MonadReader, ask)
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C
import Data.Char (digitToInt)
import Data.List (intercalate, isPrefixOf, nub)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
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 ByteString () m Integer
nat =
do digits <- many1 digit
return $ foldl (\x d -> x * 10 + fromIntegral (digitToInt d)) 0 digits
botPrefix :: (BotMonad m) => ParsecT ByteString () m ()
botPrefix =
do recv <- fromMaybe "" <$> askReceiver
pref <- cmdPrefix <$> askBotEnv
if "#" `C.isPrefixOf` recv
then (try $ string pref >> return ()) <|> lift mzero
else (try $ string pref >> return ()) <|> return ()
parsecPart :: (BotMonad m) =>
(ParsecT ByteString () m a)
-> m a
parsecPart p =
do priv <- privMsg
logM Debug $ "I got a message: " <> msg priv <> " sent to " <> (C.intercalate ", " (receivers priv))
ma <- runParserT p () "" (msg priv)
case ma of
(Left e) ->
do logM Debug $ "Parse error: " <> C.pack (show e)
target <- maybeZero =<< replyTo
reportError target e
mzero
(Right a) -> return a
reportError :: (BotMonad m) => ByteString -> 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] (C.pack 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)