-- | 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 = Module (Bool, String -> IO String)
forall st. Module st
newModule
    { moduleCmds :: ModuleT
  (Bool, String -> IO String)
  LB
  [Command (ModuleT (Bool, String -> IO String) LB)]
moduleCmds = [Command (ModuleT (Bool, String -> IO String) LB)]
-> ModuleT
     (Bool, String -> IO String)
     LB
     [Command (ModuleT (Bool, String -> IO String) LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"vixen")
            { help :: Cmd (ModuleT (Bool, String -> IO String) LB) ()
help = String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
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 -> String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT (Bool, String -> IO String) LB) ())
-> Cmd (ModuleT (Bool, String -> IO String) LB) String
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> Cmd (ModuleT (Bool, String -> IO String) LB) String)
-> ((Bool, String -> IO String) -> IO String)
-> (Bool, String -> IO String)
-> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
txt) ((String -> IO String) -> IO String)
-> ((Bool, String -> IO String) -> String -> IO String)
-> (Bool, String -> IO String)
-> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String -> IO String) -> String -> IO String
forall a b. (a, b) -> b
snd ((Bool, String -> IO String)
 -> Cmd (ModuleT (Bool, String -> IO String) LB) String)
-> Cmd
     (ModuleT (Bool, String -> IO String) LB)
     (Bool, String -> IO String)
-> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cmd
  (ModuleT (Bool, String -> IO String) LB)
  (Bool, String -> IO String)
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 <- Nick -> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *). Monad m => Nick -> Cmd m String
showNick (Nick -> Cmd (ModuleT (Bool, String -> IO String) LB) String)
-> Cmd (ModuleT (Bool, String -> IO String) LB) Nick
-> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cmd (ModuleT (Bool, String -> IO String) LB) Nick
forall (m :: * -> *). Monad m => Cmd m Nick
getLambdabotName
                String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String
"vixen-on: turn " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
me String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" into a chatterbot")
            , process :: String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
process = Cmd (ModuleT (Bool, String -> IO String) LB) ()
-> String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall a b. a -> b -> a
const (Cmd (ModuleT (Bool, String -> IO String) LB) ()
 -> String -> Cmd (ModuleT (Bool, String -> IO String) LB) ())
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
-> String
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall a b. (a -> b) -> a -> b
$ do
                (LBState (Cmd (ModuleT (Bool, String -> IO String) LB))
 -> LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS ((LBState (Cmd (ModuleT (Bool, String -> IO String) LB))
  -> LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
 -> Cmd (ModuleT (Bool, String -> IO String) LB) ())
-> (LBState (Cmd (ModuleT (Bool, String -> IO String) LB))
    -> LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall a b. (a -> b) -> a -> b
$ \(_,r) -> (Bool
True, String -> IO String
r)
                String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
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 <- Nick -> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *). Monad m => Nick -> Cmd m String
showNick (Nick -> Cmd (ModuleT (Bool, String -> IO String) LB) String)
-> Cmd (ModuleT (Bool, String -> IO String) LB) Nick
-> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cmd (ModuleT (Bool, String -> IO String) LB) Nick
forall (m :: * -> *). Monad m => Cmd m Nick
getLambdabotName
                String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String
"vixen-off: shut " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
me String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"up")
            , process :: String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
process = Cmd (ModuleT (Bool, String -> IO String) LB) ()
-> String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall a b. a -> b -> a
const (Cmd (ModuleT (Bool, String -> IO String) LB) ()
 -> String -> Cmd (ModuleT (Bool, String -> IO String) LB) ())
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
-> String
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall a b. (a -> b) -> a -> b
$ do
                (LBState (Cmd (ModuleT (Bool, String -> IO String) LB))
 -> LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS ((LBState (Cmd (ModuleT (Bool, String -> IO String) LB))
  -> LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
 -> Cmd (ModuleT (Bool, String -> IO String) LB) ())
-> (LBState (Cmd (ModuleT (Bool, String -> IO String) LB))
    -> LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall a b. (a -> b) -> a -> b
$ \(_,r) -> (Bool
False, String -> IO String
r)
                String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
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) <- Cmd
  (ModuleT (Bool, String -> IO String) LB)
  (Bool, String -> IO String)
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
        if Bool
alive then IO String -> Cmd (ModuleT (Bool, String -> IO String) LB) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO String
k String
txt) Cmd (ModuleT (Bool, String -> IO String) LB) String
-> (String -> Cmd (ModuleT (Bool, String -> IO String) LB) ())
-> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say
                 else () -> Cmd (ModuleT (Bool, String -> IO String) LB) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    , moduleDefState :: LB (Bool, String -> IO String)
moduleDefState = (Bool, String -> IO String) -> LB (Bool, String -> IO String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, IO String -> String -> IO String
forall a b. a -> b -> a
const (String -> IO String
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 = Serial (Bool, String -> IO String)
-> Maybe (Serial (Bool, String -> IO String))
forall a. a -> Maybe a
Just (Serial (Bool, String -> IO String)
 -> Maybe (Serial (Bool, String -> IO String)))
-> Serial (Bool, String -> IO String)
-> Maybe (Serial (Bool, String -> IO String))
forall a b. (a -> b) -> a -> b
$ (ByteString -> (Bool, String -> IO String))
-> Serial (Bool, String -> IO String)
forall b. (ByteString -> b) -> Serial b
readOnly ((ByteString -> (Bool, String -> IO String))
 -> Serial (Bool, String -> IO String))
-> (ByteString -> (Bool, String -> IO String))
-> Serial (Bool, String -> IO String)
forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
         let st :: [(String, WTree)]
st = ByteString -> [(String, WTree)]
forall a. Binary a => ByteString -> a
decode (ByteString -> ByteString
L.fromStrict ByteString
bs)
             compiled :: [(Regex, WTree)]
compiled = ((String, WTree) -> (Regex, WTree))
-> [(String, WTree)] -> [(Regex, WTree)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex (String -> Regex)
-> (WTree -> WTree) -> (String, WTree) -> (Regex, WTree)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** WTree -> WTree
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 (ByteString -> String) -> IO ByteString -> IO String
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)  = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
a
randomW (Node [WTree]
ls) = [WTree] -> IO WTree
forall (m :: * -> *) a. MonadIO m => [a] -> m a
random [WTree]
ls IO WTree -> (WTree -> IO ByteString) -> IO ByteString
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) ([(Regex, WTree)] -> WTree) -> [(Regex, WTree)] -> WTree
forall a b. (a -> b) -> a -> b
$
    ((Regex, WTree) -> Bool) -> [(Regex, WTree)] -> [(Regex, WTree)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Regex
reg,WTree
_) -> Regex -> String -> Bool
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 -> String -> String
[WTree] -> String -> String
WTree -> String
(Int -> WTree -> String -> String)
-> (WTree -> String) -> ([WTree] -> String -> String) -> Show WTree
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [WTree] -> String -> String
$cshowList :: [WTree] -> String -> String
show :: WTree -> String
$cshow :: WTree -> String
showsPrec :: Int -> WTree -> String -> String
$cshowsPrec :: Int -> WTree -> String -> String
Show

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

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