NameAndVersionTitleBar.hs

-- |
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
module Hails.Graphics.UI.Gtk.Simplify.NameAndVersionTitleBar where

import Control.Arrow
import Control.Monad
import Control.Monad.Reader (liftIO)
import Data.ExtraVersion
-- import Graphics.UI.Gtk.GenericView
import Graphics.UI.Gtk
import Hails.MVC.View
import Hails.MVC.View.GtkView
import Hails.MVC.GenericCombinedEnvironment
import Hails.MVC.Model.ReactiveModel (Event)
import Hails.MVC.Model.ProtectedModel.VersionedModel
import Hails.MVC.Model.ProtectedModel.NamedModel

installHandlers :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)
                => CEnv a b c
                -> ViewElementAccessorIO (GtkView a) Window
                -> IO ()
installHandlers cenv wF = void $ do
  let vw = view cenv
  w <- wF vw
  w `on` mapEvent $ liftIO (onViewAsync vw (condition cenv wF)) >> return False

condition :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)
          => CEnv a b c
          -> ViewElementAccessorIO (GtkView a) Window
          -> IO ()
condition cenv wF = do
  let (vw, pm) = (view &&& model) cenv
  w  <- wF vw
  pn <- getName pm
  vn <- fmap versionToString $ getVersion pm
  t  <- windowGetTitle w
  let titleMust = pn ++ " " ++ vn
  when (t /= titleMust) $ windowSetTitle w titleMust