import Control.Concurrent
import Control.Monad (liftM4)
import FLTK hiding(message)
import Network
import System
import System.IO
import System.IO.Unsafe
import Text.ParserCombinators.Parsec hiding(spaces, label)

data S = S { win :: Window, inp :: Input, tabs :: Tabs, ws :: [(String,Input)], sel :: String, h :: Handle }

data IrcMessage = IM { prefixIM :: String, commandIM :: String, paramsIM  :: [String] } 

state :: MVar S
state = unsafePerformIO newEmptyMVar

current = do s <- readMVar state
             w <- get (tabs s) value 
             name <- get w label
             let Just w = lookup name (ws s)
             return w

die = putStrLn "usage: hirc <nick> <server>" >> exitWith (ExitFailure 1)

main = do args <- getArgs
          if length args /= 2 then die else return ()
          let [nick,serv] = args
          w <- newWindow 0 0 640 480 [ label := "hirc" ]
          h <- connectTo serv (PortNumber 6667)
          hPutStr h ("NICK "++nick++"\r\nUSER hirc 0 * :Hirc Alpha\r\n")
          hFlush h
          i <- newInput 0 460 640 20 []
          t <- newTabs 0 0 640 460 []
          w `resizable` t
          set i [action := send h t, when := wEnter ]
          putMVar state (S w i t [] "" h)
          forkIO (loop h)
          set w [shown := True]
          let l = wait >> yield >> l in l

send :: Handle -> Tabs -> Input -> IO ()
send h tabs inp = set inp [ value ::=> parse ]
    where parse ('/':'c':_) = do o <- current
                                 set o [ value := "" ]
                                 redraw o
                                 return ""
          parse "/quit"     = hPutStr h "QUIT\r\n" >> exitWith ExitSuccess
          parse ('/':msg)   = put msg
          parse msg         = do w <- current
                                 s <- get w label
                                 addMsg s ("=> "++msg)
                                 put (concat ["PRIVMSG ",s," :",msg])
          put s = hPutStr h s >> hPutChar h '\r' >> hPutChar h '\n' >> return ""


loop h = hSetBuffering h NoBuffering >> hGetContents h >>= \str -> l str >> pfun str 
    where pfun str = 
              case parse message "irc" str of
               Right (IM "" "PING" [a],r) -> hPutStr h ("PONG :"++a++"\r\n") >> pfun r
               Right (x,r) -> addMsg (wnd x) (fmt x) >> pfun r
               Left  e     -> do let (el,r) = break (/= '\n') str
                                 addMsg "" (show e ++ " '" ++ el ++ "'") >> pfun r

l str = forkIO (mapM_ putStrLn (lines str))

wnd (IM _ _ (('#':x):_)) = ('#':x)
wnd _              = ""

fmt (IM p "PRIVMSG" [c,msg]) = concat ["<",takeWhile (/= '!') p,"> ",msg]
fmt (IM p c ps)              = unwords (p:":":c:ps)


addMsg :: String -> String -> IO ()
addMsg win str = modifyMVar_ state f
    where f s  = case lookup win (ws s) of
                  Just w -> set w [value :=> (\old -> old ++ ('\n':str))] >> return s
                  Nothing-> do begin (tabs s)
                               (x,y,w,h) <- get (tabs s) coords 
                               out <- newMultiOutput 0 40 w (h-40) [label := win]
                               redraw (tabs s)
                               f (s { ws = ((win,out):ws s) }) 


-- Parsing IRC messages with Parsec

message = newMsg prefix command params crlf
prefix  = option "" (between (char ':') spaces nws)
command = many1 upper <|> count 3 digit
params  = option [] (spaces >> append (nws `sepEndBy` spaces) trailing)
trailing= option [] (char ':' >> many (noneOf "\r\n\0"))
nws     = many1 (noneOf " \r\n\0:")
spaces  = many1 (char ' ')
crlf    = between (char '\r') (char '\n') getInput

newMsg = liftM4 (\p c ps inp -> (IM p c ps,tail inp)) 
append l e = do { l' <- l; e' <- e; return (l' ++ [e']) }