Logger.hs

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

import Control.Arrow
import Control.Monad
import Hails.MVC.Model.ReactiveModel (Event)
import Control.Monad.Reader (liftIO)
import Data.Maybe
import Hails.MVC.GenericCombinedEnvironment
import Graphics.UI.Gtk
-- import Graphics.UI.Gtk.GenericView
import Hails.MVC.View.GtkView
import Hails.MVC.View
import System.Log as Log
import System.Log.Formatter
import System.Log.Handler
import System.Log.Logger

import Hails.MVC.Model.ProtectedModel.LoggedModel

installHandlersUnique :: (GtkGUI a, LoggedBasicModel b,
                          Event c, MenuItemClass d)
                      => CEnv a b c
                      -> ViewElementAccessorIO (GtkView a) d
                      -> IO ()
installHandlersUnique cenv mF = void $ do
  rl <- getRootLogger
  let lhs = [] :: [ ListStoreLogHandler ]
  let rl' = setHandlers lhs rl
  saveGlobalLogger rl'
  installHandlers cenv mF

installHandlers :: (GtkGUI a, LoggedBasicModel b,
                    Event c, MenuItemClass d)
                => CEnv a b c
                -> ViewElementAccessorIO (GtkView a) d
                -> IO ()
installHandlers cenv mF = void $ do
  let (vw, pm) = (view &&& model) cenv

  lsLogHandler <- listStoreLogHandlerNew
  log' <- getLog pm
  -- let nl = setHandlers [lsLogHandler] log'
  let nl = addHandler lsLogHandler log'
  saveGlobalLogger nl

  w  <- createLogWindow $ lslhStore lsLogHandler
  mn <- mF vw
  mn `on` menuItemActivate $ liftIO (widgetShowAll w)

createLogWindow :: ListStore String -> IO Window
createLogWindow ls = do
  w <- windowNew
  set w [ windowTitle := "Log" ]
  windowSetDefaultSize w 400 300
  s <- scrolledWindowNew Nothing Nothing
  containerAdd w s
  tv <- treeViewNewWithModel ls
  treeViewSetHeadersVisible tv False
  addTextColumn tv ls Just
  containerAdd s tv
  w `on` deleteEvent $ liftIO $ widgetHide w >> return True
  return w -- , ls)

addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)
                => TreeView -> model row -> (row -> Maybe String) -> IO()
addTextColumn tv st f = do
  col <- treeViewColumnNew
  renderer <- cellRendererTextNew
  cellLayoutPackStart col renderer True
  cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.f
  _ <- treeViewAppendColumn tv col
  return ()

data ListStoreLogHandler = ListStoreLogHandler
 { lslhStore     :: ListStore String
 , lslhLevel     :: Log.Priority
 , lslhFormatter :: LogFormatter ListStoreLogHandler
 }

instance LogHandler ListStoreLogHandler where
 getLevel         = lslhLevel
 setLevel x l     = x { lslhLevel = l }
 getFormatter     = lslhFormatter
 setFormatter x f = x { lslhFormatter = f }
 emit x l _       = void (listStoreAppend (lslhStore x) (snd l))
 close _          = return ()

listStoreLogHandlerNew :: IO ListStoreLogHandler
listStoreLogHandlerNew = do
  ls <- listStoreNew []
  return ListStoreLogHandler
           { lslhStore     = ls
           , lslhLevel     = DEBUG
           , lslhFormatter = nullFormatter
           }