{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, ScopedTypeVariables, ConstraintKinds, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, RankNTypes, PatternGuards #-}
module Network.Anticiv.Masks where

import Control.Monad
import Control.Monad.State
import Data.Char
import Data.List
import Data.Chatty.Atoms
import Data.Chatty.Hetero
import Network.Anticiv.Monad
import System.Chatty.Misc

class MatchMask mm l | mm -> l where
  matchmask :: forall m. MonadAnticiv m => mm -> StateT String m (Maybe l)
  verbosemask :: mm -> String

data CatchString = Remaining | RemString | QuotString | ServerHost
data CatchUser = ChannelUser | UserMask
data CatchInt = CatchInt
data Token = Token String | CIToken String | CIString String
newtype Optional a = Optional a
newtype Which a = Which [a]

instance Tuplify Token Token where
  tuplify = id

instance MatchMask String Nil where
  matchmask t = do
    ss <- get
    if take (length t) ss == t
       then modify (drop $ length t) >> return (Just Nil)
       else return Nothing
  verbosemask t = "the case sensitive string \""++t++"\""

instance MatchMask Token Nil where
  matchmask (Token t) = do
    ss <- liftM (takeUntil isSpace . dropWhile isSpace) get
    if ss == t
       then modify (drop (length ss) . dropWhile isSpace) >> return (Just Nil)
       else return Nothing
  matchmask (CIToken t) = do
    ss <- liftM (takeUntil isSpace . dropWhile isSpace) get
    if ss `strEq` t
       then modify (drop (length ss) . dropWhile isSpace) >> return (Just Nil)
       else return Nothing
  matchmask (CIString t) = do
    ss <- get
    if take (length t) ss `strEq` t
       then modify (drop $ length t) >> return (Just Nil)
       else return Nothing     
  verbosemask (Token t) = "the case sensitive token \""++t++"\""
  verbosemask (CIToken t) = "the case insensitive token \""++t++"\""
  verbosemask (CIString t) = "the case insenstive string \""++t++"\""

takeUntil = takeWhile . (not.)
nickfirstchars = ['A'..'Z'] ++ ['a'..'z'] ++ "_\\`|^"
nicknextchars = nickfirstchars ++ ['0'..'9']
namefirstchars = "~_-" ++ ['A'..'Z'] ++ ['a'..'z']
namenextchars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_-"
hostfirstchars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_-:"
hostnextchars = hostfirstchars ++ "./"
strEq a b = map toLower a == map toLower b

instance MatchMask CatchInt (Cons Int Nil) where
  matchmask CatchInt = do
    ss <- gets (takeWhile isDigit . dropWhile isSpace)
    if null ss
      then return Nothing
      else do
        modify (dropWhile isDigit . dropWhile isSpace)
        return $ Just (read ss :-: Nil)
  verbosemask CatchInt = "integer"

instance MatchMask CatchString (Cons String Nil) where
  matchmask Remaining = do
    ss <- get
    put []
    return $ Just (ss :-: Nil)
  matchmask RemString = do
    ss <- liftM (dropWhile isSpace) get
    if null ss then return Nothing
               else if head ss == ':' then put [] >> return (Just (tail ss :-: Nil))
                                      else return Nothing
  matchmask QuotString = do
    let catchquote [] = Nothing
        catchquote ('\"':rs) = Just ("",rs)
        catchquote ('\\':'\"':rs)
          | Nothing <- catchquote rs = Nothing
          | Just (as,rx) <- catchquote rs = Just ('\"':as, rx)
        catchquote ('\\':'\\':rs)
          | Nothing <- catchquote rs = Nothing
          | Just (as,rx) <- catchquote rs = Just ('\\':as, rx)
        catchquote (a:rs)
          | Nothing <- catchquote rs = Nothing
          | Just (as,rx) <- catchquote rs = Just (a:as, rx)
    ss <- get
    if null ss
      then return Nothing
      else if head ss /= '\"'
              then return Nothing
              else     
                case catchquote ss of
                  Nothing -> return Nothing
                  Just (as,rx) -> put rx >> return (Just (as :-: Nil))
  matchmask ServerHost = do
    ss <- gets (dropWhile isSpace)
    if null ss
       then return Nothing
       else if head ss /= ':'
               then return Nothing
               else if null (tail ss)
                       then return Nothing
                       else if not (head (tail ss) `elem` hostfirstchars)
                               then return Nothing
                               else let ho = head (tail ss) : takeWhile (`elem` hostnextchars) (tail $ tail ss)
                                    in modify (drop (length ho) . tail) >> return (Just (ho :-: Nil))    
  verbosemask Remaining = "free form content"
  verbosemask RemString = "colon-introduced string to line end"
  verbosemask QuotString = "quoted string"
  verbosemask ServerHost = "server host mask starting with a colon"

simul a b k = do
  a' <- lift $ a k
  b' <- lift $ b k
  return (a',b')

instance MatchMask CatchUser (Cons UserA Nil) where
  matchmask UserMask = do
    let consumeColon = do
          ss <- gets (dropWhile isSpace)
          if null ss
            then return Nothing
            else if head ss /= ':'
                    then return Nothing
                    else modify (tail . dropWhile isSpace) >> return (Just ())
        consumeNick = do
          ss <- get
          if null ss
             then return Nothing
             else if not (head ss `elem` nickfirstchars)
                     then return Nothing
                     else let nm = head ss : takeWhile (`elem` nicknextchars) (tail ss)
                          in modify (drop $ length nm) >> return (Just nm)
        consumeBang = do
          ss <- get
          if null ss
             then return Nothing
             else if head ss /= '!'
                     then return Nothing
                     else modify tail >> return (Just ())
        consumeName = do
          ss <- get
          if null ss
             then return Nothing
             else if not (head ss `elem` namefirstchars)
                     then return Nothing
                     else let nm = head ss : takeWhile (`elem` namenextchars) (tail ss)
                          in modify (drop $ length nm) >> return (Just nm)
        consumeAt = do
          ss <- get
          if null ss
             then return Nothing
             else if head ss /= '@'
                     then return Nothing
                     else modify tail >> return (Just ())
        consumeHost = do
          ss <- get
          if null ss
             then return Nothing
             else if not (head ss `elem` hostfirstchars)
                     then return Nothing
                     else let ho = head ss : takeWhile (`elem` hostnextchars) (tail ss)
                          in modify (drop $ length ho) >> return (Just ho)
    colon <- consumeColon
    nick <- consumeNick
    bang <- consumeBang
    name <- consumeName
    at <- consumeAt
    host <- consumeHost
    let u = do
          colon
          ni <- nick
          bang
          na <- name
          at
          ho <- host
          return (User ni na ho 0)
    case u of
      Nothing -> return Nothing
      Just u -> do
        us <- lift $ bgets channelUsers
        us' <- mapM (getAtom `simul` return) us
        a <- lift $ case filter (strEq (userNick u) . userNick . fst) us' of
          [] -> do
            a <- newAtom
            r <- mrandomR (1,40000)
            putAtom a u{reauthId=r}
            bmodify $ \b -> b{channelUsers=a:channelUsers b}
            return a
          ((k,a):_) -> do
            putAtom a u{reauthId=reauthId k}
            return a
        return (Just (a :-: Nil))
  matchmask ChannelUser = do
    ss <- liftM (dropWhile isSpace) get
    if null ss
       then return Nothing
       else if not (head ss `elem` nickfirstchars)
               then return Nothing
               else let nm = head ss : takeWhile (`elem` nicknextchars) (tail ss)
                    in do
                      us <- lift $ bgets channelUsers
                      us' <- mapM (getAtom `simul` return) us
                      let ux = filter (strEq nm . userNick . fst) us'
                      if not $ null ux
                        then do
                          modify (drop (length nm) . dropWhile isSpace)
                          return (Just (snd (head ux) :-: Nil))
                        else return Nothing
  verbosemask UserMask = "full user mask starting with a colon"
  verbosemask ChannelUser = "a user nick present in this channel"


instance (MatchMask a ar, IntoMaybe ar am, Append am Nil am) => MatchMask (Optional a) am where
  matchmask (Optional a) = do
    matchmask a >>= \a -> case a of
      Nothing -> return $ Just $ tnothing (undefined :: ar)
      Just k -> return $ Just $ tjust k
  verbosemask (Optional a) = "optionally [" ++ verbosemask a ++ "]"

firstSeq :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe (a,b))
firstSeq _ [] = return Nothing
firstSeq f (p:ps) = f p >>= \c -> case c of
  Nothing -> firstSeq f ps
  Just k -> return $ Just (p,k)

instance (MatchMask a r,Append (Cons a Nil) r ar) => MatchMask (Which a) ar where
  matchmask (Which []) = return Nothing
  matchmask (Which ps) = do
    ss <- get
    firstSeq matchmask ps >>= \c -> case c of
      Nothing -> return Nothing
      Just (k,r) -> return $ Just (tappend (k :-: Nil) r)
  verbosemask (Which []) = "empty choice (you should blame the bot's or module's author)"
  verbosemask (Which ps) = unwords $ intersperse "or" $ map verbosemask ps

instance MatchMask Nil Nil where
  matchmask Nil = return $ Just Nil
  verbosemask _ = "end of mask"

instance (MatchMask x r, MatchMask xs rs, Append r rs rx) => MatchMask (Cons x xs) rx where
  matchmask (x :-: xs) = do
    l1 <- matchmask x
    case l1 of
      Nothing -> return Nothing
      Just l1 -> do
        l2 <- matchmask xs
        case l2 of
          Nothing -> return Nothing
          Just l2 -> return $ Just $ tappend l1 l2
  verbosemask (x :-: xs) = verbosemask x ++ ", then " ++ verbosemask x

trymask :: (MatchMask m r,Tuplify r t) => m -> String -> Anticiv (Maybe t)
trymask m s = do
  r <- runStateT (matchmask m) s
  return $ case r of
    (Nothing,_) -> Nothing
    (Just a,[]) -> Just $ tuplify a
    (Just a,_) -> Nothing

infixr 8 #->
(#->) :: (MatchMask m r, Tuplify r t) => m -> (t -> Anticiv ()) -> String -> Anticiv Bool
mm #-> f = \s -> do
  b <- trymask mm s
  case b of
    Nothing -> return False
    Just t -> f t >> return True

infixr 8 #->>
(#->>) :: (MatchMask m r, Tuplify r t) => m -> Anticiv () -> String -> Anticiv Bool
mm #->> f = mm #-> const f

infixr 7 #||
(#||) :: Monad m => m Bool -> m Bool -> m Bool
a #|| b = do
  ax <- a
  if ax
    then return True
    else b     

infixr 7 .||
(.||) :: Monad m => (a -> m Bool) -> (a -> m Bool) -> (a -> m Bool)
a .|| b = \x -> a x #|| b x

infixl 6 &
(&) = flip ($)