{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Network.IRC.Bot.Parsec where
import Control.Monad
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C
import Data.Char (digitToInt)
import Data.List (intercalate, 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 :: ParsecT s u m BotEnv
askBotEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). BotMonad m => m BotEnv
askBotEnv
askMessage :: ParsecT s u m Message
askMessage = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). BotMonad m => m Message
askMessage
askOutChan :: ParsecT s u m (Chan Message)
askOutChan = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). BotMonad m => m (Chan Message)
askOutChan
localMessage :: forall a.
(Message -> Message) -> ParsecT s u m a -> ParsecT s u m a
localMessage Message -> Message
f ParsecT s u m a
m = forall (m :: * -> *) (n :: * -> *) s u a b.
(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 (forall (m :: * -> *) a.
BotMonad m =>
(Message -> Message) -> m a -> m a
localMessage Message -> Message
f) ParsecT s u m a
m
sendMessage :: Message -> ParsecT s u m ()
sendMessage = 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 :: * -> *). BotMonad m => Message -> m ()
sendMessage
logM :: LogLevel -> ByteString -> ParsecT s u m ()
logM LogLevel
lvl ByteString
msg' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *). BotMonad m => LogLevel -> ByteString -> m ()
logM LogLevel
lvl ByteString
msg')
whoami :: ParsecT s u m ByteString
whoami = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). BotMonad m => m ByteString
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 :: forall (m :: * -> *) (n :: * -> *) s u a b.
(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 m (Consumed (m (Reply s u a))) -> n (Consumed (n (Reply s u b)))
f ParsecT s u m a
p = forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
mkPT forall a b. (a -> b) -> a -> b
$ \State s u
s -> m (Consumed (m (Reply s u a))) -> n (Consumed (n (Reply s u b)))
f (forall (m :: * -> *) s u a.
Monad m =>
ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))
runParsecT ParsecT s u m a
p State s u
s)
nat :: (Monad m) => ParsecT ByteString () m Integer
nat :: forall (m :: * -> *). Monad m => ParsecT ByteString () m Integer
nat =
do [Char]
digits <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Integer
x Char
d -> Integer
x forall a. Num a => a -> a -> a
* Integer
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)) Integer
0 [Char]
digits
botPrefix :: (BotMonad m) => ParsecT ByteString () m ()
botPrefix :: forall (m :: * -> *). BotMonad m => ParsecT ByteString () m ()
botPrefix =
do ByteString
recv <- forall a. a -> Maybe a -> a
fromMaybe ByteString
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Alternative m, BotMonad m) =>
m (Maybe ByteString)
askReceiver
[Char]
pref <- BotEnv -> [Char]
cmdPrefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). BotMonad m => m BotEnv
askBotEnv
if ByteString
"#" ByteString -> ByteString -> Bool
`C.isPrefixOf` ByteString
recv
then (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
pref forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) a. MonadPlus m => m a
mzero
else (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
pref forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return ()
parsecPart :: (BotMonad m) =>
(ParsecT ByteString () m a)
-> m a
parsecPart :: forall (m :: * -> *) a.
BotMonad m =>
ParsecT ByteString () m a -> m a
parsecPart ParsecT ByteString () m a
p =
do PrivMsg
priv <- forall (m :: * -> *).
(Functor m, MonadPlus m, BotMonad m) =>
m PrivMsg
privMsg
forall (m :: * -> *). BotMonad m => LogLevel -> ByteString -> m ()
logM LogLevel
Debug forall a b. (a -> b) -> a -> b
$ ByteString
"I got a message: " forall a. Semigroup a => a -> a -> a
<> PrivMsg -> ByteString
msg PrivMsg
priv forall a. Semigroup a => a -> a -> a
<> ByteString
" sent to " forall a. Semigroup a => a -> a -> a
<> (ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
", " (PrivMsg -> [ByteString]
receivers PrivMsg
priv))
Either ParseError a
ma <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> [Char] -> s -> m (Either ParseError a)
runParserT ParsecT ByteString () m a
p () [Char]
"" (PrivMsg -> ByteString
msg PrivMsg
priv)
case Either ParseError a
ma of
(Left ParseError
e) ->
do forall (m :: * -> *). BotMonad m => LogLevel -> ByteString -> m ()
logM LogLevel
Debug forall a b. (a -> b) -> a -> b
$ ByteString
"Parse error: " forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
C.pack (forall a. Show a => a -> [Char]
show ParseError
e)
ByteString
target <- forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
maybeZero forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). BotMonad m => m (Maybe ByteString)
replyTo
forall (m :: * -> *).
BotMonad m =>
ByteString -> ParseError -> m ()
reportError ByteString
target ParseError
e
forall (m :: * -> *) a. MonadPlus m => m a
mzero
(Right a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
reportError :: (BotMonad m) => ByteString -> ParseError -> m ()
reportError :: forall (m :: * -> *).
BotMonad m =>
ByteString -> ParseError -> m ()
reportError ByteString
target ParseError
err =
let errStrs :: [[Char]]
errStrs = [Char]
-> [Char] -> [Char] -> [Char] -> [Char] -> [Message] -> [[Char]]
showErrorMessages [Char]
"or" [Char]
"unknown parse error" [Char]
"expecting" [Char]
"unexpected" [Char]
"end of input" (ParseError -> [Message]
errorMessages ParseError
err)
errStr :: [Char]
errStr = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
errStrs
in forall c (m :: * -> *).
(ToMessage c, BotMonad m, Functor m) =>
c -> m ()
sendCommand (Maybe Prefix -> [ByteString] -> ByteString -> PrivMsg
PrivMsg forall a. Maybe a
Nothing [ByteString
target] ([Char] -> ByteString
C.pack [Char]
errStr))
showErrorMessages ::
String -> String -> String -> String -> String -> [P.Message] -> [String]
showErrorMessages :: [Char]
-> [Char] -> [Char] -> [Char] -> [Char] -> [Message] -> [[Char]]
showErrorMessages [Char]
msgOr [Char]
msgUnknown [Char]
msgExpecting [Char]
msgUnExpected [Char]
msgEndOfInput [Message]
msgs'
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs' = [[Char]
msgUnknown]
| Bool
otherwise = [[Char]] -> [[Char]]
clean forall a b. (a -> b) -> a -> b
$
[[Char]
showSysUnExpect,[Char]
showUnExpect,[Char]
showExpect,[Char]
showMessages]
where
([Message]
sysUnExpect,[Message]
msgs1) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
P.SysUnExpect [Char]
"") forall a. Eq a => a -> a -> Bool
==) [Message]
msgs'
([Message]
unExpect,[Message]
msgs2) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
P.UnExpect [Char]
"") forall a. Eq a => a -> a -> Bool
==) [Message]
msgs1
([Message]
expect,[Message]
messages) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
P.Expect [Char]
"") forall a. Eq a => a -> a -> Bool
==) [Message]
msgs2
showExpect :: [Char]
showExpect = [Char] -> [Message] -> [Char]
showMany [Char]
msgExpecting [Message]
expect
showUnExpect :: [Char]
showUnExpect = [Char] -> [Message] -> [Char]
showMany [Char]
msgUnExpected [Message]
unExpect
showSysUnExpect :: [Char]
showSysUnExpect | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
unExpect) Bool -> Bool -> Bool
||
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
sysUnExpect = [Char]
""
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
firstMsg = [Char]
msgUnExpected forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [Char]
msgEndOfInput
| Bool
otherwise = [Char]
msgUnExpected forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [Char]
firstMsg
where
firstMsg :: [Char]
firstMsg = Message -> [Char]
messageString (forall a. [a] -> a
head [Message]
sysUnExpect)
showMessages :: [Char]
showMessages = [Char] -> [Message] -> [Char]
showMany [Char]
"" [Message]
messages
showMany :: [Char] -> [Message] -> [Char]
showMany [Char]
pre [Message]
msgs = case [[Char]] -> [[Char]]
clean (forall a b. (a -> b) -> [a] -> [b]
map Message -> [Char]
messageString [Message]
msgs) of
[] -> [Char]
""
[[Char]]
ms | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
pre -> [[Char]] -> [Char]
commasOr [[Char]]
ms
| Bool
otherwise -> [Char]
pre forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
commasOr [[Char]]
ms
commasOr :: [[Char]] -> [Char]
commasOr [] = [Char]
""
commasOr [[Char]
m] = [Char]
m
commasOr [[Char]]
ms = [[Char]] -> [Char]
commaSep (forall a. [a] -> [a]
init [[Char]]
ms) forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [Char]
msgOr forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> a
last [[Char]]
ms
commaSep :: [[Char]] -> [Char]
commaSep = forall {t}. (IsString t, Semigroup t) => t -> [t] -> t
seperate [Char]
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
clean
seperate :: t -> [t] -> t
seperate t
_ [] = t
""
seperate t
_ [t
m] = t
m
seperate t
sep (t
m:[t]
ms) = t
m forall a. Semigroup a => a -> a -> a
<> t
sep forall a. Semigroup a => a -> a -> a
<> t -> [t] -> t
seperate t
sep [t]
ms
clean :: [[Char]] -> [[Char]]
clean = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)