{-# LANGUAGE RankNTypes, ConstraintKinds, FlexibleContexts, FlexibleInstances, UndecidableInstances, IncoherentInstances, MultiParamTypeClasses #-}
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 []

{-repll :: String -> String -> [String] -> String
repll ('%':'s':s) p (t:ts) = t++repll s p ts
repll ('%':'f':s) p (t:ts) = repll (t++s) p ts
repll ('%':'p':s) p ts = p++repll s p ts
repll ('%':'%':s) p ts = '%' : repll s p ts
repll ('#':s) p ts =
  let n = read $ takeWhile isDigit s
      s' = dropWhile isDigit s
  in (ts !! n) ++ repll s' p ts
repll (c:s) p ts = c : repll s p ts
repll [] _ _ = []-}

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}