{-# LANGUAGE CPP #-}
module LocalChat
    ( module Chat
    , module LocalChat
    ) where

import Debug.Trace
import Control.Concurrent.STM
import Control.Monad
import Data.Function
import Data.List
import qualified Data.Map as Map
         ;import Data.Map (Map)
import qualified Data.Text as T
         ;import Data.Text (Text)

#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc                  (labelThread)
#endif

import DPut
import DebugTag
import Chat
import MUC

forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
forkUntilSignaled lbl action = do
    quitSignal <- newTVarIO False
    t <- forkIO $ do
        fix $ \loop -> join $ atomically
            $ orElse (do readTVar quitSignal >>= check
                         return $ return ())
                     (fmap (>> loop) $ action)
    labelThread t lbl
    return $ atomically (writeTVar quitSignal True)


chatevents rsvar = do
    rs <- readTVar rsvar
    if Map.null rs
      then retry
      else do
        ios <- forM rs $ \r -> do
            ps <- roomPending r
            trace ("roomPending " ++ show ps) $ return ()
            case Map.toList ps of
                (k,t):ts -> do
                    roomCommit r k t
                    return $ do
                        dput XJabber $ "committed " ++ show (length ts,k,t)
                _ -> retry
        return $ foldl1 (>>) ios

forkLocalChat :: MUC -> IO (IO ())
forkLocalChat muc = do
    (chan, rs) <- atomically $ do
        c <- dupTChan (mucChan muc)
        rs <- newTVar Map.empty
        return (c,rs)
    forkUntilSignaled "localchat" $ orElse (chatevents rs) $ do
        e <- readTChan chan
        case e of
            MUCCreate room jid nick r -> modifyTVar' rs $ Map.insert room r
        return $ case e of
            MUCCreate room jid nick _ ->
                dput XJabber $ unwords $ map T.unpack
                    [ "MUCCreate", room, jid, nick ]