-- | Talk to hot chixxors.

-- (c) Mark Wotton
-- Serialisation (c) 2007 Don Stewart

module Lambdabot.Plugin.Novelty.Vixen (vixenPlugin) where

import Lambdabot.Plugin
import Lambdabot.Util

import Control.Arrow ((***))
import Control.Monad
import Data.Binary
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy as L
import System.Directory
import Text.Regex.TDFA

vixenPlugin :: Module (Bool, String -> IO [Char])
vixenPlugin :: Module (Bool, String -> IO String)
vixenPlugin = forall st. Module st
newModule
    { moduleCmds :: ModuleT
  (Bool, String -> IO String)
  LB
  [Command (ModuleT (Bool, String -> IO String) LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"vixen")
            { help :: Cmd (ModuleT (Bool, String -> IO String) LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"vixen <phrase>. Sergeant Curry's lonely hearts club"
            , process :: String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
process = \String
txt -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ String
txt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
            }
        , (String -> Command Identity
command String
"vixen-on")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT (Bool, String -> IO String) LB) ()
help = do
                String
me <- forall (m :: * -> *). Monad m => Nick -> Cmd m String
showNick forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). Monad m => Cmd m Nick
getLambdabotName
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String
"vixen-on: turn " forall a. [a] -> [a] -> [a]
++ String
me forall a. [a] -> [a] -> [a]
++ String
" into a chatterbot")
            , process :: String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
process = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS forall a b. (a -> b) -> a -> b
$ \(Bool
_,String -> IO String
r) -> (Bool
True, String -> IO String
r)
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"What's this channel about?"
            }
        , (String -> Command Identity
command String
"vixen-off")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT (Bool, String -> IO String) LB) ()
help = do
                String
me <- forall (m :: * -> *). Monad m => Nick -> Cmd m String
showNick forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). Monad m => Cmd m Nick
getLambdabotName
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String
"vixen-off: shut " forall a. [a] -> [a] -> [a]
++ String
me forall a. [a] -> [a] -> [a]
++ String
"up")
            , process :: String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
process = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS forall a b. (a -> b) -> a -> b
$ \(Bool
_,String -> IO String
r) -> (Bool
False, String -> IO String
r)
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Bye!"
            }
        ]

    -- if vixen-chat is on, we can just respond to anything
    , contextual :: String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
contextual = \String
txt -> do
        (Bool
alive, String -> IO String
k) <- forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
        if Bool
alive then forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO String
k String
txt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => String -> Cmd m ()
say
                 else forall (m :: * -> *) a. Monad m => a -> m a
return ()

    , moduleDefState :: LB (Bool, String -> IO String)
moduleDefState = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return String
"<undefined>"))

    -- suck in our (read only) regex state from disk
    -- compile it, and stick it in the plugin state
    , moduleSerialize :: Maybe (Serial (Bool, String -> IO String))
moduleSerialize = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b. (ByteString -> b) -> Serial b
readOnly forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
         let st :: [(String, WTree)]
st = forall a. Binary a => ByteString -> a
decode (ByteString -> ByteString
L.fromStrict ByteString
bs)
             compiled :: [(Regex, WTree)]
compiled = forall a b. (a -> b) -> [a] -> [b]
map (forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. a -> a
id) ([(String, WTree)]
st :: [(String, WTree)])
         in  (Bool
False, (String -> WTree) -> String -> IO String
vixen ([(Regex, WTree)] -> String -> WTree
mkResponses [(Regex, WTree)]
compiled))
    }

------------------------------------------------------------------------

vixen :: (String -> WTree) -> String -> IO String
vixen :: (String -> WTree) -> String -> IO String
vixen String -> WTree
k String
key = ByteString -> String
P.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` WTree -> IO ByteString
randomW (String -> WTree
k String
key)

randomW :: WTree -> IO P.ByteString
randomW :: WTree -> IO ByteString
randomW (Leaf ByteString
a)  = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
a
randomW (Node [WTree]
ls) = forall (m :: * -> *) a. MonadIO m => [a] -> m a
random [WTree]
ls forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WTree -> IO ByteString
randomW

mkResponses :: RChoice -> String -> WTree
mkResponses :: [(Regex, WTree)] -> String -> WTree
mkResponses [(Regex, WTree)]
choices String
them = (\((Regex
_,WTree
wtree):[(Regex, WTree)]
_) -> WTree
wtree) forall a b. (a -> b) -> a -> b
$
    forall a. (a -> Bool) -> [a] -> [a]
filter (\(Regex
reg,WTree
_) -> forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
reg String
them) [(Regex, WTree)]
choices

------------------------------------------------------------------------
-- serialisation for the vixen state
--
-- The tree of regexes and responses is written in binary form to
-- State/vixen, and we suck it in on module init, then lazily regexify it all

data WTree = Leaf !P.ByteString | Node ![WTree]
             deriving Int -> WTree -> ShowS
[WTree] -> ShowS
WTree -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WTree] -> ShowS
$cshowList :: [WTree] -> ShowS
show :: WTree -> String
$cshow :: WTree -> String
showsPrec :: Int -> WTree -> ShowS
$cshowsPrec :: Int -> WTree -> ShowS
Show

instance Binary WTree where
    put :: WTree -> Put
put (Leaf ByteString
s)  = Word8 -> Put
putWord8 Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put ByteString
s
    put (Node [WTree]
ls) = Word8 -> Put
putWord8 Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put [WTree]
ls
    get :: Get WTree
get = do
        Word8
tag <- Get Word8
getWord8
        case Word8
tag of
            Word8
0 -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> WTree
Leaf forall t. Binary t => Get t
get
            Word8
1 -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [WTree] -> WTree
Node forall t. Binary t => Get t
get
            Word8
_ -> forall a. HasCallStack => String -> a
error String
"Vixen plugin error: unknown tag"

type RChoice = [(Regex, WTree)] -- compiled choices