-- | 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 = return
        [ (command "vixen")
            { help = say "vixen <phrase>. Sergeant Curry's lonely hearts club"
            , 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)
Cmd
  (ModuleT (Bool, String -> IO String) LB)
  (LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
            }
        , (command "vixen-on")
            { privileged = True
            , help = do
                me <- showNick =<< getLambdabotName
                say ("vixen-on: turn " ++ me ++ " into a chatterbot")
            , process = const $ do
                modifyMS $ \(Bool
_,String -> IO String
r) -> (Bool
True, String -> IO String
r)
                say "What's this channel about?"
            }
        , (command "vixen-off")
            { privileged = True
            , help = do
                me <- showNick =<< getLambdabotName
                say ("vixen-off: shut " ++ me ++ "up")
            , process = const $ do
                modifyMS $ \(Bool
_,String -> IO String
r) -> (Bool
False, String -> IO String
r)
                say "Bye!"
            }
        ]

    -- if vixen-chat is on, we can just respond to anything
    , contextual = \String
txt -> do
        (Bool
alive, String -> IO String
k) <- Cmd
  (ModuleT (Bool, String -> IO String) LB)
  (Bool, String -> IO String)
Cmd
  (ModuleT (Bool, String -> IO String) LB)
  (LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
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 a b.
Cmd (ModuleT (Bool, String -> IO String) LB) a
-> (a -> Cmd (ModuleT (Bool, String -> IO String) LB) b)
-> Cmd (ModuleT (Bool, String -> IO String) LB) b
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 a. a -> Cmd (ModuleT (Bool, String -> IO String) LB) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    , moduleDefState = return (False, const (return "<undefined>"))

    -- suck in our (read only) regex state from disk
    -- compile it, and stick it in the plugin state
    , moduleSerialize = Just $ readOnly $ \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 b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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
$cshowsPrec :: Int -> WTree -> String -> String
showsPrec :: Int -> WTree -> String -> String
$cshow :: WTree -> String
show :: WTree -> String
$cshowList :: [WTree] -> String -> String
showList :: [WTree] -> String -> String
Show

instance Binary WTree where
    put :: WTree -> Put
put (Leaf ByteString
s)  = Word8 -> Put
putWord8 Word8
0 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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