    -- | 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 a. a -> ModuleT (Bool, String -> IO String) LB a
    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)
    Cmd
      (ModuleT (Bool, String -> IO String) LB)
      (LBState (Cmd (ModuleT (Bool, String -> IO String) LB)))
    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
    $ \(Bool
    _,String -> IO String
    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
    $ \(Bool
    _,String -> IO String
    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)
    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 :: LB (Bool, String -> IO String)
    moduleDefState = (Bool, String -> IO String) -> LB (Bool, String -> IO String)
    forall a. a -> LB a
    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 a. a -> IO a
    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 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