-- | Cmd.hs
-- A module which parse command from user and return answer.

module Cmd (
    doCmd
) where

import Buffers
import Config
import Help
import Jabber
import Utils

import Control.Monad
import Data.List
import Data.List.Utils

-- TODO: tab auto-completion


-- | Execute user command.
doCmd mev config buffers acc cur str w =
    case runParseCmd str of
        Left err -> ins2cur_e err
        Right args -> doCmd' args
  where
    -- connect
    doCmd' ["connect"] = do
        buffer <- connect mev config acc
        return $ insElem'' (accName acc) buffer
    -- disconnect
    doCmd' ["disconnect"] = do
        buffer <- disconnect acc
        let buffers' = insElem'' (accName acc) buffer
            buffers'' = killBuffers (accName acc++"|") buffers'
        return buffers''
    -- join room
    doCmd' ["join", room] = case connection acc of
        OK _ _ | not $ isBuf k buffers -> do
          buffer <- joinRoom acc Nothing room
          let buffers' = insElem'' k buffer
              buffers'' = case conf_group of
                BufGroup grp -> insElem group (new_buf grp) buffers'
              conf_group = getBuf group buffers
              new_buf grp = BufGroup grp{grpItems = k:(grpItems grp)}
              group = accName acc++"|"++getCF "conferences_group" config
          return buffers''
        _ -> ins2cur_e "account not connected"
        where
          k = accName acc++"|"++room
    -- show/set topic
    doCmd' ("topic":args) | length args < 2
      = case getBuf cur buffers of
          BufRoom room | null args -> ins2cur_i (roomSubject room)
          BufRoom room -> setRoomSubject acc room (head args) >> skip
          _ -> ins2cur_e "not a room"
    -- set new nickname
    doCmd' ["nick", nick] = case getBuf cur buffers of
      BufRoom room -> do
          joinRoom acc (Just nick) jid
          return $ insElem'' cur (BufRoom room{roomNick=nick})
        where
          jid = name $ roomName room
    -- show room participants
    doCmd' ["names"] = case getBuf cur buffers of
      BufRoom room ->
          ins2cur_i (showOccupants (roomOccupants room) w)
      _ -> ins2cur_e "not a room"
    -- room lists
    doCmd' ["list", arg] = case getBuf cur buffers of
      BufRoom room ->
          getRoomList acc room arg >>= maybe (return buffers) ins2cur_e
      _ -> ins2cur_e "not a room"
    -- admin room
    doCmd' (rank:arg:nOrJ:reason)
        | (rank == "rank" || rank == "rankj") &&
          length reason < 2 =
              if rank == "rank" then admin (Left nOrJ) arg reason
                                else admin (Right nOrJ) arg reason
      where
        admin nickOrJ arg reason =
          case getBuf cur buffers of
            BufRoom room ->
                adminRoom acc room nickOrJ arg mReason
                >>= maybe (return buffers) ins2cur_e
            _ -> ins2cur_e "not a room"
          where mReason | length reason == 0 = Nothing
                        | otherwise          = Just $ head reason
    -- simple
    doCmd' ["help"] = ins2acc_i help_all
    doCmd' ["nya"]  = ins2cur_i "Nya-nya nya-nya nihao nya coda tsugeraha tsude karu saa!"
    -- try find alias
    doCmd' (cmd:params) | not $ null $ alias cmd =
      let (cmd', params') = doArgs (alias cmd, params)
      in case runParseCmd cmd' of
             Left err -> ins2cur_e err
             Right args | not $ null $ alias $ head args ->
                            ins2cur_e "looping aliases forbidden"
                        | otherwise ->
                            doCmd' (args++params')
    -- unknown cmd
    doCmd' _ = ins2cur_e $ "unknown `/"++str++"' command, try `/help'"

    ---
    skip = return buffers
    alias n = getCF ("alias "++n) config
    insElem'' k v = insElem k v buffers
    -- insert info to acc buffer (help)
    ins2acc_i = withTime " == " >=> ins2acc . InfoMsg
    ins2acc_e = withTime " !! " >=> ins2acc . ErrorMsg
    ins2acc msg = return $ insElem'' (accName acc) (acc' msg)
    acc' msg = BufAccount acc{accContents=msg:(accContents acc)}
    -- insert info to current buffer
    -- FIXME: looks ugly :/
    ins2cur_i = withTime " == " >=> ins2cur . InfoMsg
    ins2cur_e = withTime " !! " >=> ins2cur . ErrorMsg
    ins2cur msg = return $ insElem'' cur $ case getBuf cur buffers of
        BufAccount _ -> acc' msg
        BufGroup grp -> BufGroup grp{grpContents=msg:(grpContents grp)}
        BufChat chat -> BufChat chat{chatContents=msg:(chatContents chat)}
        BufRoom room -> BufRoom room{roomContents=msg:(roomContents room)}


-- | Run parser.
runParseCmd :: String -> Either String [String]
runParseCmd str = parseCmd Arg str "" []


-- | Parse command from user like in shell with quotes and escaping.
parseCmd :: State -> String -> String -> [String] -> Either String [String]
-- end of input
parseCmd _ "" "" [] = Left "no input"
parseCmd Arg "" arg args = Right (args++[arg])
parseCmd Quoted1 "" _ _ = Left "unbalansed quotes"
parseCmd Quoted2 "" _ _ = Left "unbalansed quotes"
parseCmd Spaces "" _ args = Right args

parseCmd Arg (' ':cs) "" args = Left "empty argument"
parseCmd Arg (' ':cs) arg args = parseCmd Spaces cs "" (args++[arg])
parseCmd Arg ('\\':' ':cs) arg args = parseCmd Arg cs (arg++" ") args
parseCmd Arg ('\\':'\\':cs) arg args = parseCmd Arg cs (arg++"\\") args
parseCmd Arg ( c :cs) arg args = parseCmd Arg cs (arg++[c]) args

parseCmd Quoted1 ('\'':cs) "" args = Left "empty argument"
parseCmd Quoted1 ('\'':cs) arg args = parseCmd Spaces cs "" (args++[arg])
parseCmd Quoted1 ('\\':'\'':cs) arg args = parseCmd Quoted1 cs (arg++"'") args
parseCmd Quoted1 ('\\':'\\':cs) arg args = parseCmd Quoted1 cs (arg++"\\") args
parseCmd Quoted1 ( c  :cs) arg args = parseCmd Quoted1 cs (arg++[c]) args

parseCmd Quoted2 ('"':cs) "" args = Left "empty argument"
parseCmd Quoted2 ('"':cs) arg args = parseCmd Spaces cs "" (args++[arg])
parseCmd Quoted2 ('\\':'"':cs) arg args = parseCmd Quoted2 cs (arg++"\"") args
parseCmd Quoted2 ('\\':'\\':cs) arg args = parseCmd Quoted2 cs (arg++"\\") args
parseCmd Quoted2 ( c :cs) arg args = parseCmd Quoted2 cs (arg++[c]) args

parseCmd Spaces (' ' :cs) _ args = parseCmd Spaces cs "" args
parseCmd Spaces ('\'':cs) _ args = parseCmd Quoted1 cs "" args
parseCmd Spaces ('"' :cs) _ args = parseCmd Quoted2 cs "" args
parseCmd Spaces ('\\':'\'':cs) _ args = parseCmd Arg cs "'" args
parseCmd Spaces ('\\':'"':cs) _ args = parseCmd Arg cs "\"" args
parseCmd Spaces ( c  :cs) _ args = parseCmd Arg cs [c] args


-- | Parser states.
data State = Arg -- ^ arg without spaces
           | Quoted1 -- ^ arg quoted with '
           | Quoted2 -- ^ arg quoted with "
           | Spaces -- ^ spaces


-- | Add arguments to alias. Replace $1..$9 in alias to appropriate
-- argument. If no such argument then simply replace $1..$9 to "".
-- Example: alias cjr = join $1@conference.jabber.ru
-- /cjr test -> /join test@conference.jabber.ru
doArgs :: (String, [String]) -> (String, [String])
doArgs (str, args) =
    foldr (\i b@(str', args') ->
               if (arg i) `isInfixOf` str'
               then (replace (arg i) (getArg i) str', head' args')
               else b
          ) (str, args) [1..9]
  where
    arg i = '$':(show i)
    len = length args
    getArg i | i <= len  = args!!(i-1)
             | otherwise = ""
    head' []     = []
    head' (_:xs) = xs