{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
{-# 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 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)

-- | parse a positive integer
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

-- | parser that checks for the 'cmdPrefix' (from the 'BotEnv')
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 ()

-- | 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 :: 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

      -- helpers
      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)