apelsin-1.2.1: src/FindPlayers.hs

module FindPlayers (newFindPlayers, playerUpdateOne) where
import Graphics.UI.Gtk

import Data.IORef
import Data.Ord
import Control.Concurrent
import Network.Tremulous.Protocol
import Network.Tremulous.Util
import qualified Network.Tremulous.StrictMaybe as SM

import Types
import GtkUtils
import GtkExts
import TremFormatting
import FilterBar
import InfoBox
import Constants
import Config


newFindPlayers :: Bundle -> SetCurrent -> IO (VBox, PolledHook)
newFindPlayers bundle@Bundle{..} setServer = do
	Config {..} <- readMVar mconfig
	(GenFilterSort raw filtered _ view) <- playerLikeList bundle setServer

	(infobox, statNow, statTot)	<- newInfobox "players"
	(filterbar, current)		<- newFilterBar parent filtered statNow filterPlayers

	treeModelFilterSetVisibleFunc filtered $ \iter -> do
		(item, GameServer{..}) <- treeModelGetRow raw iter
		s <- readIORef current
		return $ smartFilter s
				[ cleanedCase item
				, protoToAbbr protocol
				, SM.maybe "" cleanedCase gamemod
				]

	let updateFilter PollResult{..} = do
		listStoreClear raw
		mapM_ (listStoreAppend raw) (makePlayerNameList polled)
		labelSetText statTot . show =<< treeModelIterNChildren raw Nothing
		labelSetText statNow . show =<< treeModelIterNChildren filtered Nothing

	scroll <- scrollIt view PolicyAutomatic PolicyAlways

	box <- vBoxNew False 0
	boxPackStart box filterbar PackNatural spacing
	boxPackStart box scroll PackGrow 0
	boxPackStart box infobox PackNatural 0

	return (box, updateFilter)

playerLikeList :: Bundle -> SetCurrent -> IO (GenFilterSort ListStore (TI, GameServer))
playerLikeList bundle@Bundle{..} setCurrent= do
	Config {..} <- readMVar mconfig
	gen@(GenFilterSort _ _ sorted view) <- newGenFilterSort playerStore

	addColumnFS gen "_Name" True (Just (comparing fst))
		(rememberColumn bundle 0)
		fastCellTextRenderer
		[cellTextEllipsize := EllipsizeEnd]
		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . fst)

	addColumnFS gen "_Server" True (Just (comparing (hostname . snd)))
		(rememberColumn bundle 1)
		fastCellTextRenderer
		[cellTextEllipsize := EllipsizeEnd]
		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . hostname . snd)

	treeSortableSetSortColumnId sorted playersSortColumn playersOrder

	on view cursorChanged $ do
		(path, _) <- treeViewGetCursor view
		setCurrent False . snd =<< getElementPath gen path

	on view rowActivated $ \path _ ->
		setCurrent True . snd =<< getElementPath gen path

	return gen


playerUpdateOne :: PlayerStore -> GameServer -> IO ()
playerUpdateOne raw gs = do
	lst <- listStoreToList raw
	let oldplayers = [ i | (i, (_, gs')) <- zip [0::Int ..] lst, address gs == address gs']
	let newplayers = map (\a -> (name a, gs)) (players gs)
	foldPlayers newplayers oldplayers
	where
	foldPlayers (n:ns) (i:os) = listStoreSetValue raw i n >> foldPlayers ns os
	foldPlayers []     (i:os) = listStoreRemove raw i     >> foldPlayers [] os
	foldPlayers (n:ns) []     = listStoreAppend raw n     >> foldPlayers ns []
	foldPlayers []     []     = return ()


rememberColumn :: Bundle -> Int -> TreeViewColumn -> IO ()
rememberColumn Bundle{..} n col = do
	order <- treeViewColumnGetSortOrder col
	current <- takeMVar mconfig
	let new = current {playersSortColumn = n, playersOrder = order}
	putMVar mconfig new
	configToFile parent new