{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
-- Enable when GHC7.10 support is not needed
-- where this fails with 'unknown flag'
-- {-# OPTIONS_GHC -Wno-orphans #-}

module Network.IRC.Bot.Parsec where

{-

The parsec part is supposed to make it easy to use Parsec to parse the command arguments.

We would also like to be able to generate a help menu. But the help
menu should not be for only Parsec commands. Or do we? Maybe all interactive commands should be implementing through parsec part.

Some commands like @seen (and @tell) are two part. There is the part that collects
the data. And there is the command itself. How would that integrate
with a parsec command master list?

We would like the parsec commands to be non-blocking.

Each top-level part is run in a separate thread. But if we only have one thread for all the parsecParts, then blocking could occur.

We could run every handler for every message, even though we only expect at most one command to match. That seems bogus. Do we really want to allow to different parts to respond to @foo ?

Seems better to have each part register.

data Part m =
    Part { name            :: String
         , description     :: String
         , backgroundParts :: [BotPartT m ()]
         , command         :: Maybe (String, String, BotPartT m ()) -- ^ (name, usage, handler)
         }

This is good, unless multiple plugins wanted to depend on some common backgroundParts
-}

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 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 :: ParsecT s u m BotEnv
askBotEnv        = m BotEnv -> ParsecT s u m BotEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m BotEnv
forall (m :: * -> *). BotMonad m => m BotEnv
askBotEnv
    askMessage :: ParsecT s u m Message
askMessage       = m Message -> ParsecT s u m Message
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Message
forall (m :: * -> *). BotMonad m => m Message
askMessage
    askOutChan :: ParsecT s u m (Chan Message)
askOutChan       = m (Chan Message) -> ParsecT s u m (Chan Message)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Chan Message)
forall (m :: * -> *). BotMonad m => m (Chan Message)
askOutChan
    localMessage :: (Message -> Message) -> ParsecT s u m a -> ParsecT s u m a
localMessage Message -> Message
f ParsecT s u m a
m = (m (Consumed (m (Reply s u a))) -> m (Consumed (m (Reply s u a))))
-> ParsecT s u m a -> ParsecT s u m a
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 ((Message -> Message)
-> m (Consumed (m (Reply s u a))) -> m (Consumed (m (Reply s u a)))
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      = m () -> ParsecT s u m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ParsecT s u m ())
-> (Message -> m ()) -> Message -> ParsecT s u m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> m ()
forall (m :: * -> *). BotMonad m => Message -> m ()
sendMessage
    logM :: LogLevel -> ByteString -> ParsecT s u m ()
logM LogLevel
lvl ByteString
msg'     = m () -> ParsecT s u m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LogLevel -> ByteString -> m ()
forall (m :: * -> *). BotMonad m => LogLevel -> ByteString -> m ()
logM LogLevel
lvl ByteString
msg')
    whoami :: ParsecT s u m ByteString
whoami           = m ByteString -> ParsecT s u m ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ByteString
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 :: (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 = (State s u -> n (Consumed (n (Reply s u b)))) -> ParsecT s u n b
forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
mkPT ((State s u -> n (Consumed (n (Reply s u b)))) -> ParsecT s u n b)
-> (State s u -> n (Consumed (n (Reply s u b)))) -> ParsecT s u n b
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 (ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))
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)

-- | parse a positive integer
nat :: (Monad m) => ParsecT ByteString () m Integer
nat :: ParsecT ByteString () m Integer
nat =
    do [Char]
digits <- ParsecT ByteString () m Char -> ParsecT ByteString () m [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT ByteString () m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
       Integer -> ParsecT ByteString () m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ParsecT ByteString () m Integer)
-> Integer -> ParsecT ByteString () m Integer
forall a b. (a -> b) -> a -> b
$ (Integer -> Char -> Integer) -> Integer -> [Char] -> Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Integer
x Char
d -> Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)) Integer
0 [Char]
digits

-- | parser that checks for the 'cmdPrefix' (from the 'BotEnv')
botPrefix :: (BotMonad m) => ParsecT ByteString () m ()
botPrefix :: ParsecT ByteString () m ()
botPrefix =
    do ByteString
recv <- ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString)
-> ParsecT ByteString () m (Maybe ByteString)
-> ParsecT ByteString () m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () m (Maybe ByteString)
forall (m :: * -> *).
(Alternative m, BotMonad m) =>
m (Maybe ByteString)
askReceiver
       [Char]
pref <- BotEnv -> [Char]
cmdPrefix (BotEnv -> [Char])
-> ParsecT ByteString () m BotEnv -> ParsecT ByteString () m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () m BotEnv
forall (m :: * -> *). BotMonad m => m BotEnv
askBotEnv
       if ByteString
"#" ByteString -> ByteString -> Bool
`C.isPrefixOf` ByteString
recv
          then (ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT ByteString () m () -> ParsecT ByteString () m ())
-> ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT ByteString () m [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
pref ParsecT ByteString () m [Char]
-> ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT ByteString () m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ParsecT ByteString () m ()
-> ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> m () -> ParsecT ByteString () m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          else (ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT ByteString () m () -> ParsecT ByteString () m ())
-> ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT ByteString () m [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
pref ParsecT ByteString () m [Char]
-> ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT ByteString () m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ParsecT ByteString () m ()
-> ParsecT ByteString () m () -> ParsecT ByteString () m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> () -> ParsecT ByteString () m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | create a bot part by using Parsec to parse the command
--
-- The argument to 'parsecPart' is a parser function.
--
-- The argument to that parsec function is the 'target' that the response should be sent to.
--
-- The parser will receive the 'msg' from the 'PrivMsg'.
--
-- see 'dicePart' for an example usage.
parsecPart :: (BotMonad m) =>
              (ParsecT ByteString () m a)
           -> m a
parsecPart :: ParsecT ByteString () m a -> m a
parsecPart ParsecT ByteString () m a
p =
    do PrivMsg
priv <- m PrivMsg
forall (m :: * -> *).
(Functor m, MonadPlus m, BotMonad m) =>
m PrivMsg
privMsg
       LogLevel -> ByteString -> m ()
forall (m :: * -> *). BotMonad m => LogLevel -> ByteString -> m ()
logM LogLevel
Debug (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString
"I got a message: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> PrivMsg -> ByteString
msg PrivMsg
priv ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" sent to " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
", " (PrivMsg -> [ByteString]
receivers PrivMsg
priv))
       Either ParseError a
ma <- ParsecT ByteString () m a
-> () -> [Char] -> ByteString -> m (Either ParseError a)
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 LogLevel -> ByteString -> m ()
forall (m :: * -> *). BotMonad m => LogLevel -> ByteString -> m ()
logM LogLevel
Debug (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Parse error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
C.pack (ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e)
                ByteString
target <- Maybe ByteString -> m ByteString
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
maybeZero (Maybe ByteString -> m ByteString)
-> m (Maybe ByteString) -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe ByteString)
forall (m :: * -> *). BotMonad m => m (Maybe ByteString)
replyTo
                ByteString -> ParseError -> m ()
forall (m :: * -> *).
BotMonad m =>
ByteString -> ParseError -> m ()
reportError ByteString
target ParseError
e
                m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         (Right a
a) -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

reportError :: (BotMonad m) => ByteString -> ParseError -> m ()
reportError :: 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 = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
errStrs
    in PrivMsg -> m ()
forall c (m :: * -> *).
(ToMessage c, BotMonad m, Functor m) =>
c -> m ()
sendCommand (Maybe Prefix -> [ByteString] -> ByteString -> PrivMsg
PrivMsg Maybe Prefix
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'
    | [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs' = [[Char]
msgUnknown]
    | Bool
otherwise = [[Char]] -> [[Char]]
clean ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
                 [[Char]
showSysUnExpect,[Char]
showUnExpect,[Char]
showExpect,[Char]
showMessages]
    where
      ([Message]
sysUnExpect,[Message]
msgs1) = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
P.SysUnExpect [Char]
"") Message -> Message -> Bool
forall a. Eq a => a -> a -> Bool
==) [Message]
msgs'
      ([Message]
unExpect,[Message]
msgs2)    = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
P.UnExpect    [Char]
"") Message -> Message -> Bool
forall a. Eq a => a -> a -> Bool
==) [Message]
msgs1
      ([Message]
expect,[Message]
messages)   = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (([Char] -> Message
P.Expect      [Char]
"") Message -> Message -> Bool
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 ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
unExpect) Bool -> Bool -> Bool
||
                        [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
sysUnExpect = [Char]
""
                      | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
firstMsg    = [Char]
msgUnExpected [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msgEndOfInput
                      | Bool
otherwise        = [Char]
msgUnExpected [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
firstMsg
          where
              firstMsg :: [Char]
firstMsg  = Message -> [Char]
messageString ([Message] -> Message
forall a. [a] -> a
head [Message]
sysUnExpect)

      showMessages :: [Char]
showMessages      = [Char] -> [Message] -> [Char]
showMany [Char]
"" [Message]
messages

      -- helpers
      showMany :: [Char] -> [Message] -> [Char]
showMany [Char]
pre [Message]
msgs = case [[Char]] -> [[Char]]
clean ((Message -> [Char]) -> [Message] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Message -> [Char]
messageString [Message]
msgs) of
                            [] -> [Char]
""
                            [[Char]]
ms | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
pre  -> [[Char]] -> [Char]
commasOr [[Char]]
ms
                               | Bool
otherwise -> [Char]
pre [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [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 ([[Char]] -> [[Char]]
forall a. [a] -> [a]
init [[Char]]
ms) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msgOr [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
forall a. [a] -> a
last [[Char]]
ms

      commaSep :: [[Char]] -> [Char]
commaSep          = [Char] -> [[Char]] -> [Char]
forall a. (IsString a, Semigroup a) => a -> [a] -> a
seperate [Char]
", " ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
clean

      seperate :: a -> [a] -> a
seperate   a
_ []     = a
""
      seperate   a
_ [a
m]    = a
m
      seperate a
sep (a
m:[a]
ms) = a
m a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
sep a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> [a] -> a
seperate a
sep [a]
ms

      clean :: [[Char]] -> [[Char]]
clean             = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)