module Network.Anticiv.Convenience where
import Control.Monad
import Control.Monad.State
import Data.Char
import Data.List
import Data.Chatty.Atoms
import Data.Chatty.AVL
import Data.Chatty.Hetero
import Data.Chatty.TST
import Network.Anticiv.Config
import Network.Anticiv.Masks
import Network.Anticiv.Monad
import System.Chatty.Misc
import Text.Chatty.Channel.Printer
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Scanner.Buffered
import Text.CTPL
import qualified Text.CTPL0 as Null
import Text.Printf
regPriorityChanmsg :: (Atom Handler -> UserA -> String -> Anticiv Bool) -> Anticiv (Atom Handler)
regPriorityChanmsg f = do
a <- newAtom
m <- bmodule
putAtom a $ \u s -> Anticiv $ switchTo m $ f a u s
bmodify $ \b -> b{priorityChanmsg=a : priorityChanmsg b}
return a
unregPriorityChanmsg :: Atom Handler -> Anticiv ()
unregPriorityChanmsg a = do
bmodify $ \b -> b{priorityChanmsg=delete a $ priorityChanmsg b}
dispAtom a
regEmergencyChanmsg :: (Atom Handler -> UserA -> String -> Anticiv Bool) -> Anticiv (Atom Handler)
regEmergencyChanmsg f = do
a <- newAtom
m <- bmodule
putAtom a $ \u s -> Anticiv $ switchTo m $ f a u s
bmodify $ \b -> b{emergencyChanmsg=a : emergencyChanmsg b}
return a
unregEmergencyChanmsg :: Atom Handler -> Anticiv ()
unregEmergencyChanmsg a = do
bmodify $ \b -> b{emergencyChanmsg=delete a $ emergencyChanmsg b}
dispAtom a
regPriorityQuerymsg :: (Atom Handler -> UserA -> String -> Anticiv Bool) -> Anticiv (Atom Handler)
regPriorityQuerymsg f = do
a <- newAtom
m <- bmodule
putAtom a $ \u s -> Anticiv $ switchTo m $ f a u s
bmodify $ \b -> b{priorityQuerymsg=a : priorityQuerymsg b}
return a
unregPriorityQuerymsg :: HandlerA -> Anticiv ()
unregPriorityQuerymsg a = do
bmodify $ \b -> b{priorityQuerymsg=delete a $ priorityQuerymsg b}
dispAtom a
regEmergencyQuerymsg :: (HandlerA -> UserA -> String -> Anticiv Bool) -> Anticiv (Atom Handler)
regEmergencyQuerymsg f = do
a <- newAtom
m <- bmodule
putAtom a $ \u s -> Anticiv $ switchTo m $ f a u s
bmodify $ \b -> b{emergencyQuerymsg=a : emergencyQuerymsg b}
return a
unregEmergencyQuerymsg :: HandlerA -> Anticiv ()
unregEmergencyQuerymsg a = do
bmodify $ \b -> b{emergencyQuerymsg=delete a $ emergencyQuerymsg b}
dispAtom a
regTickRecipient :: (AnticivA () -> Anticiv ()) -> Anticiv (AnticivA ())
regTickRecipient f = do
a <- newAtom
m <- bmodule
putAtom a $ Anticiv $ switchTo m $ f a
bmodify $ \b -> b{tickRecipients=a:tickRecipients b}
return a
unregTickRecipient :: AnticivA () -> Anticiv ()
unregTickRecipient a = do
bmodify $ \b -> b{tickRecipients=delete a $ tickRecipients b}
dispAtom a
bchan :: (MonadBot m,ChAtoms m) => m String
bchan = bkStr "Connection/Channel"
bnick :: (MonadBot m,ChAtoms m) => m String
bnick = bkStr "Connection/Nick"
bprefix :: (MonadBot m,ChAtoms m) => m String
bprefix = bkStr "Prefix"
switchTo :: MonadBot m => String -> m a -> m a
switchTo m f = do
bmodify $ \b -> b{moduleStack=m:moduleStack b}
a <- f
bmodify $ \b -> b{moduleStack=tail $ moduleStack b}
return a
blStr :: (MonadBot m,ChAtoms m) => String -> m String
blStr k = do
m <- bmodule
let unjust (Just u) = u
c <- bgets $ unjust . tstLookup m . localizations
case mgetKey m k c of
Just (TempLeaf (StrValT i)) -> return i
Just (RefLeaf (StrVal a)) -> getAtom a
Nothing -> error $ printf "Could not find essential key %s. Check your locale file." k
_ -> error $ printf "Key %s has the wrong type (string expected). Check your locale file." k
blStrL :: (MonadBot m,ChAtoms m) => String -> m [String]
blStrL k = do
m <- bmodule
let unjust (Just u) = u
c <- bgets $ unjust . tstLookup m . localizations
case mgetKey m k c of
Just (TempLeaf (StrListT i)) -> return i
Just (RefLeaf (StrList a)) -> getAtom a
Nothing -> error $ printf "Could not find essential key %s. Check your locale file." k
_ -> error $ printf "Key %s has the wrong type (string list expected). Check your locale file." k
blInt :: (MonadBot m,ChAtoms m) => String -> m Int
blInt k = do
m <- bmodule
let unjust (Just u) = u
c <- bgets $ unjust . tstLookup m . localizations
case mgetKey m k c of
Just (TempLeaf (IntValT i)) -> return i
Just (RefLeaf (IntVal a)) -> getAtom a
Nothing -> error $ printf "Could not find essential key %s. Check your locale file." k
_ -> error $ printf "Key %s has the wrong type (integer expected). Check your locale file." k
blFun :: (MonadBot m,ChAtoms m) => String -> m (String -> String)
blFun k = do
m <- bmodule
let unjust (Just u) = u
c <- bgets $ unjust . tstLookup m . localizations
case mgetKey m k c of
Just (TempLeaf (CtplT q)) -> return $ \s ->
case evalCTPL q s 40000 of
Null.Succ r -> r
_ -> s
Just (TempLeaf (Ctpl0T q)) -> return $ \s ->
case Null.evalCTPL0 q s 40000 of
Null.Succ r -> r
_ -> s
Just (RefLeaf (Ctpl0 a)) -> do
q <- getAtom a
return $ \s -> case Null.evalCTPL0 q s 40000 of
Null.Succ r -> r
_ -> s
Nothing -> error $ printf "Could not find essential key %s. Check your locale file." k
_ -> error $ printf "Key %s has the wrong type (function expected). Check your locale file." k
bvStr :: (MonadBot m,ChAtoms m,ChRandom m) => String -> String -> m String
bvStr l k = do
ls <- blStrL "Linguas"
let unjust (Just u) = u
m <- bmodule
s <- bstereo
c <- bgets $ unjust . tstLookup m . localizations
f <- blStr "Fallback"
fs <- blStr "FallbackStereo"
let fallbacks = [k++":"++f++"-"++s, k++":"++f++"-"++fs, k++":"++f]
wanted = [k++":"++l++"-"++s, k++":"++l++"-"++fs, k++":"++l] ++ fallbacks
errstr = printf "Could not find essential localization key %%%s/%s:%s." m k (if null s then l else l++"-"++s)
prock k = case k of
TempLeaf (StrValT i) -> return i
TempLeaf (StrListT i) -> do
r <- mrandomR (0, length i 1)
return (i !! r)
RefLeaf (StrVal a) -> getAtom a
RefLeaf (StrList a) -> do
i <- getAtom a
r <- mrandomR (0, length i 1)
return (i !! r)
if not $ elem l ls
then mgetFirstKey m fallbacks c & maybe (error errstr) id & prock
else mgetFirstKey m wanted c & maybe (error errstr) id & prock
private :: UserA -> String -> Anticiv ()
private ua s = do
u <- getAtom ua
cprint (Target $ userNick u) (s++"\r\n")
address :: UserA -> String -> Anticiv ()
address ua s = do
u <- getAtom ua
cprint (Address u) (s++"\r\n")
log :: String -> Anticiv ()
log = cprint Log . (++"\r\n")
action :: String -> Anticiv ()
action s = do
c <- bchan
cprint (Target c) (printf "\001ACTION %s\001\r\n" s)
notice :: UserA -> String -> Anticiv ()
notice ua s = do
u <- getAtom ua
cprint (Notice $ userNick u) (s++"\r\n")
type Speaker = forall r. PrintlType r => UserA -> String -> r
privatefl :: Speaker
privatefl u s = emitl (Just u) (return . Target . userNick =<< getAtom u) return s []
addressfl :: Speaker
addressfl u s = emitl (Just u) (liftM Target bchan) (\s -> getAtom u >>= \u -> return (userNick u++": "++s)) s []
actionfl :: PrintlType r => String -> r
actionfl s = emitl Nothing (liftM Target bchan) (\s -> return ("\001ACTION "++s++"\001")) s []
noticefl :: Speaker
noticefl u s = emitl (Just u) (return . Notice . userNick =<< getAtom u) return s []
globalfl :: PrintlType r => String -> r
globalfl s = emitl Nothing (liftM Target bchan) return s []
newtype PrintlArgW = PrintlArgW { runPrintlArgW :: String -> Anticiv String }
class PrintlType t where
emitl :: Maybe UserA -> Anticiv Target -> (String -> Anticiv String) -> String -> [PrintlArgW] -> t
instance MonadAnticiv m => PrintlType (m ()) where
emitl um t f s ss = do
li <- case um of
Nothing -> bgets botLingua
Just ua -> ulang ua
ls <- bvStr li s
ls' <- f ls
t' <- t
ss' <- forM ss $ \s -> runPrintlArgW s li
ssx <- liftM (++"\r\n") (repll ls' ss')
cprint t' ssx
case um of
Just _ -> return ()
Nothing -> do
us <- bgets channelUsers
orl <- bgets linguaOverride
forM_ us $ \ua ->
case avlLookup ua orl of
Nothing -> return ()
Just l | l == li -> return ()
Just l -> do
u <- getAtom ua
ls <- bvStr l s
ls' <- f ls
ssx <- liftM (++"\r\n") (repll ls' ss')
cprint (Notice $ userNick u) ssx
instance (PrintlArg a,PrintlType r) => PrintlType (a -> r) where
emitl u t f s ss a = emitl u t f s (ss++[printlargw a])
printlargw :: PrintlArg a => a -> PrintlArgW
printlargw a = PrintlArgW $ flip showl a
class PrintlArg a where
showl :: String -> a -> Anticiv String
instance PrintlArg String where
showl _ = return
instance PrintlArg Int where
showl _ = return . show
data Lookup = Lookup String | Lookupf String [PrintlArgW]
instance PrintlArg Lookup where
showl li (Lookup k) = bvStr li k
showl li (Lookupf k as) = do
fmt <- bvStr li k
as' <- forM as $ \a -> runPrintlArgW a li
repll fmt as'
ulang :: UserA -> Anticiv String
ulang ua = do
orl <- bgets linguaOverride
case avlLookup ua orl of
Just s -> return s
Nothing -> bgets botLingua
repll :: String -> [String] -> Anticiv String
repll ('%':'s':s) (t:ts) = liftM (t++) $ repll s ts
repll ('%':'f':s) (t:ts) = repll (t++s) ts
repll ('%':'p':s) ts = liftM2 (++) bprefix $ repll s ts
repll ('%':'%':s) ts = liftM ('%':) $ repll s ts
repll ('%':'[':s) (t:ts) =
let fs = takeWhile (/=']') s
s' = tail $ dropWhile (/=']') s
in do
fun <- blFun fs
liftM (fun t++) $ repll s' ts
repll ('#':s) ts =
let n = read $ takeWhile isDigit s
s' = dropWhile isDigit s
in liftM ((ts!!n)++) $ repll s' ts
repll (c:s) ts = liftM (c:) $ repll s ts
repll [] _ = return []
data LocalToken = LocalT UserA String
instance MatchMask LocalToken Nil where
matchmask (LocalT ua t) = do
let guardr a f = mscannable >>= \b -> if b then f else return a
skipWhite = guardr () $ do
k <- mpeek1
if isSpace k
then mscan1 >> skipWhite
else return ()
scanAnumToken = guardr [] $ do
k <- mpeek1
if isAlphaNum k
then do
mscan1
ks <- scanAnumToken
return (k:ks)
else return []
scanMiscToken = guardr [] $ do
k <- mpeek1
if not (isAlphaNum k) && not (isSpace k)
then do
mscan1
ks <- scanMiscToken
return (k:ks)
else return []
scanToken = guardr [] $ do
skipWhite
k <- mpeek1
if isAlphaNum k
then scanAnumToken
else scanMiscToken
rep k f = forM [1..k] $ const f
allTokens = do
ss <- get
if null ss
then return []
else do
t <- scanToken
ts <- allTokens
return (t:ts)
li <- lift $ ulang ua
ls <- lift $ bvStr li ("Commands/"++t)
lts <- lift $ evalStateT allTokens ls
sts <- rep (length lts) scanToken
if all (\(l,s) -> l `strEq` s) $ zip lts sts
then return (Just Nil)
else return Nothing
verbosemask (LocalT ua t) = "the localization of Commands/"++t
bsetStereo :: MonadBot m => String -> m ()
bsetStereo s = do
m <- bmodule
bmodify $ \b -> b{moduleStereo=tstInsert m s $ moduleStereo b}