{-# LANGUAGE ConstraintKinds, RankNTypes, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
module Network.Anticiv.Monad where

import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Monoid
import Data.Time.Clock
import Data.Typeable
import Game.Antisplice.Monad
import Game.Antisplice.Templates
import Data.Chatty.Atoms
import Data.Chatty.Counter
import Data.Chatty.AVL
import Data.Chatty.Hetero
import Data.Chatty.TST
import Network.Anticiv.Config
import System.Chatty.Misc
import System.IO
import Text.Chatty.Channel.Printer
import Text.Chatty.Finalizer
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Interactor
import Text.Chatty.Interactor.Templates
import Text.Printf

newtype BotT m a = BotT { runBotT :: BotState -> m (a,BotState) }

instance Functor f => Functor (BotT f) where
  fmap f (BotT a) = BotT $ \s -> fmap (first f) $ a s

instance (Functor f, Monad f) => Applicative (BotT f) where
  pure = return
  fm <*> fa = do
    f <- fm
    a <- fa
    return (f a)

instance Monad m => Monad (BotT m) where
  return a = BotT $ \s -> return (a,s)
  m >>= f = BotT $ \s -> do (a,s') <- runBotT m s; runBotT (f a) s'

instance MonadTrans BotT where
  lift m = BotT $ \s -> do a <- m; return (a,s)

instance MonadIO m => MonadIO (BotT m) where
  liftIO = lift . liftIO

data User = User {
    userNick :: String,
    userName :: String,
    userHost :: String,
    reauthId :: Int
  } deriving Eq

type UserA = Atom User

instance Show User where
  show (User ni "" "" _) = ni
  show (User ni na ho _) = printf "%s!%s@%s" ni na ho

instance Tuplify User User where
  tuplify = id

instance Tuplify (Atom a) (Atom a) where
  tuplify = id

data BotState = BotState {
    channelUsers :: [UserA],
    orphanedUsers :: [UserA],
    priorityChanmsg :: [HandlerA],
    emergencyChanmsg :: [HandlerA],
    priorityQuerymsg :: [HandlerA],
    emergencyQuerymsg :: [HandlerA],
    tickRecipients :: [AnticivA ()],
    botConfig :: Config,
    moduleStack :: [String],
    localizations :: TST Config,
    botLingua :: String,
    linguaOverride :: AVL (UserA, String),
    moduleStereo :: TST String,
    moduleLister :: [(String,Packciv [String])],
    lastMsg :: NominalDiffTime,
    lastReport :: NominalDiffTime
  }

type MonadAnticiv m = (Functor m, Monad m, ChPrinter m, ChScanner m, ChClock m, ChChannelPrinter Target m, MonadBot m, ChAtoms m,ChRandom m)

type Anticiv a = forall m. MonadAnticiv m => m a
newtype Packciv a = Anticiv { runAnticiv :: Anticiv a }
type AnticivA a = Atom (Packciv a)

instance Monad Packciv where
  return a = Anticiv $ return a
  m >>= f = Anticiv $ runAnticiv m >>= runAnticiv . f

instance Functor Packciv where
  fmap f a = liftM f a

class Monad m => MonadBot m where
  bget :: m BotState
  bput :: BotState -> m ()

instance Monad m => MonadBot (BotT m) where
  bget = BotT $ \s -> return (s,s)
  bput s = BotT $ \_ -> return ((),s)

bmodify :: MonadBot m => (BotState -> BotState) -> m ()
bmodify f = bgets f >>= bput

bgets :: MonadBot m => (BotState -> a) -> m a
bgets f = f `liftM` bget

sleep :: ChClock m => Int -> m ()
sleep ms = do
  a <- mgetstamp
  let loop = do
        b <- mgetstamp
        if a + fromRational (fromIntegral ms/1000) > b
           then loop
           else return ()
  loop

type Handler = UserA -> String -> Packciv Bool
type HandlerA = Atom Handler

data Target = Log | Target String | Notice String | Address User | Raw deriving Eq

-- | Directs Log messages through the underlying MonadPrinter, and server communication through the passed handle
newtype OutPlexT m a = OutPlex { runOutPlex :: Handle -> [Target] -> m (a,[Target]) }

instance Functor f => Functor (OutPlexT f) where
  fmap f a = OutPlex $ \h ts -> fmap (first f) $ runOutPlex a h ts

instance (Functor f, Monad f) => Applicative (OutPlexT f) where
  pure = return
  fm <*> fa = do
    f <- fm
    a <- fa
    return (f a)

instance Monad m => Monad (OutPlexT m) where
  return a = OutPlex $ \h ts -> return (a,ts)
  m >>= f = OutPlex $ \h ts -> do
    (a,ts') <- runOutPlex m h ts
    runOutPlex (f a) h ts'

instance MonadTrans OutPlexT where
  lift m = OutPlex $ \h ts -> do a <- m; return (a,ts)

instance MonadIO m => MonadIO (OutPlexT m) where
  liftIO = lift . liftIO

instance (MonadIO m,ChPrinter m,MonadBot m,ChClock m,ChAtoms m) => ChPrinter (OutPlexT m) where
  mprint s = OutPlex $ \h ts -> do
    unless (head ts == Log) $ do
      t <- bgets lastMsg
      tw <- bkInt "Throttle"
      let wait = do
            t' <- mgetstamp
            if t' > t+(fromRational (fromIntegral tw / 1000))
              then return ()
              else wait
      wait
      t' <- mgetstamp
      bmodify $ \b -> b{lastMsg=t'}
    case head ts of
      Log -> do
        m <- bmodule
        mprint ("["++m++"] "++s)
      Raw -> liftIO $ hPutStr h s
      Target ch -> liftIO $ hPrintf h "PRIVMSG %s :%s" ch s
      Address de -> do
        ch <- bkStr "Connection/Channel"
        liftIO $ hPrintf h "PRIVMSG %s :%s: %s" ch (userNick de) s
      Notice ch -> liftIO $ hPrintf h "NOTICE %s :%s" ch s
    return ((),ts)
  mflush = OutPlex $ \h ts -> (case head ts of
    Log -> mflush
    _ -> liftIO $ hFlush h ) >> return ((),ts)

instance (MonadIO m,ChPrinter m,MonadBot m,ChClock m,ChAtoms m) => ChChannelPrinter Target (OutPlexT m) where
  cstart c = OutPlex $ \_ ts -> return ((),c:ts)
  cfin _ = OutPlex $ \_ ts -> return ((),tail ts)
  cthis = OutPlex $ \_ ts -> return (head ts,ts)

instance MonadBot m => MonadBot (OutPlexT m) where
  bget = lift bget
  bput = lift . bput

instance MonadBot m => MonadBot (OutRedirT m) where
  bget = lift bget
  bput = lift . bput

instance MonadBot m => MonadBot (InRedirT m) where
  bget = lift bget
  bput = lift . bput

bkInt :: (MonadBot m,ChAtoms m) => String -> m Int
bkInt s = do
  c <- bgets botConfig
  m <- bmodule
  case mgetKey m s c of
    Nothing -> error $ printf "Could not find essential key %s. Check your config file." s
    Just (TempLeaf (IntValT i)) -> return i
    Just (RefLeaf (IntVal a)) -> getAtom a
    _ -> error $ printf "Key %s has the wrong type. Check your config file." s

bkStr :: (MonadBot m,ChAtoms m) => String -> m String
bkStr s = do
  c <- bgets botConfig
  m <- bmodule
  case mgetKey m s c of
    Nothing -> error $ printf "Could not find essential key %s. Check your config file." s
    Just (TempLeaf (StrValT i)) -> return i
    Just (RefLeaf (StrVal a)) -> getAtom a
    _ -> error $ printf "Key %s has the wrong type. Check your config file." s

bkStrL :: (MonadBot m,ChAtoms m) => String -> m [String]
bkStrL s = do
  c <- bgets botConfig
  m <- bmodule
  case mgetKey m s c of
    Nothing -> error $ printf "Could not find essential key %s. Check your config file." s
    Just (TempLeaf (StrListT i)) -> return i
    Just (RefLeaf (StrList a)) -> getAtom a
    _ -> error $ printf "Key %s has the wrong type. Check your config file." s

bmodule :: MonadBot m => m String
bmodule = bgets $ head . moduleStack

bstereo :: MonadBot m => m String
bstereo = do
  m <- bmodule
  ms <- bgets moduleStereo
  return $ case tstLookup m ms of
    Just s -> s
    Nothing -> []

mkInteractor ''BotT mkPrinter mkScanner mkFinalizer mkRandom mkClock mkAtoms mkCounter
mkInteractor ''OutPlexT mkScanner mkFinalizer mkRandom mkClock mkAtoms mkCounter

instance ChPrinter Packciv where
  mprint s = Anticiv $ mprint s
  mnoecho s = Anticiv $ mnoecho s
  mflush = Anticiv mflush
  mnomask s = Anticiv $ mnomask s
instance ChScanner Packciv where
  mscan1 = Anticiv mscan1
  mscanL = Anticiv mscanL
  mscannable = Anticiv mscannable
  mscanh = Anticiv mscanh
  mready = Anticiv mready
instance ChClock Packciv where
  mutctime = Anticiv mutctime
  mgetstamp = Anticiv mgetstamp
instance ChChannelPrinter Target Packciv where
  cstart c = Anticiv $ cstart c
  cfin c = Anticiv $ cfin c
  cprint c s = Anticiv $ cprint c s
  cthis = Anticiv cthis
instance ChAtoms Packciv where
  newAtom = Anticiv newAtom
  putAtom a v = Anticiv $ putAtom a v
  getAtom a = Anticiv $ getAtom a
  dispAtom a = Anticiv $ dispAtom a
  cloneAtom a = Anticiv $ cloneAtom a
instance ChCounter Packciv where
  countOn = Anticiv countOn
instance ChRandom Packciv where
  mrandom = Anticiv mrandom
  mrandomR r = Anticiv $ mrandomR r
instance MonadBot Packciv where
  bget = Anticiv bget
  bput s = Anticiv $ bput s