threadscope-0.2.0: GUI/MainWindow.hs

{-# LANGUAGE CPP #-}
-- ThreadScope: a graphical viewer for Haskell event log information.
-- Maintainer: satnams@microsoft.com, s.singh@ieee.org

module GUI.MainWindow (
    MainWindow,
    mainWindowNew,
    MainWindowActions(..),

    setFileLoaded,
    setStatusMessage,
    sidebarSetVisibility,
    eventsSetVisibility,

  ) where

import Paths_threadscope

-- Imports for GTK
import Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk.Gdk.Events as Old hiding (eventModifier)
import System.Glib.GObject as Glib


-------------------------------------------------------------------------------

data MainWindow = MainWindow {
       mainWindow         :: Window,

       sidebarBox,
       eventsBox          :: Widget,

       statusBar          :: Statusbar,
       statusBarCxt       :: ContextId
     }

instance Glib.GObjectClass  MainWindow where
  toGObject = toGObject . mainWindow
  unsafeCastGObject = error "cannot downcast to MainView type"

instance Gtk.ObjectClass    MainWindow
instance Gtk.WidgetClass    MainWindow
instance Gtk.ContainerClass MainWindow
instance Gtk.BinClass       MainWindow
instance Gtk.WindowClass    MainWindow

data MainWindowActions = MainWindowActions {

       -- Menu actions
       mainWinOpen          :: IO (),
       mainWinExport        :: IO (),
       mainWinQuit          :: IO (),
       mainWinViewSidebar   :: Bool -> IO (),
       mainWinViewEvents    :: Bool -> IO (),
       mainWinViewBW        :: Bool -> IO (),
       mainWinViewReload    :: IO (),
       mainWinAbout         :: IO (),

       -- Toolbar actions
       --TODO: all toolbar actions should also be available from the menu
       mainWinJumpStart     :: IO (),
       mainWinJumpEnd       :: IO (),
       mainWinJumpCursor    :: IO (),
       mainWinJumpZoomIn    :: IO (),
       mainWinJumpZoomOut   :: IO (),
       mainWinJumpZoomFit   :: IO (),
       mainWinScrollLeft    :: IO (),
       mainWinScrollRight   :: IO (),
       mainWinDisplayLabels :: Bool -> IO ()
     }

-------------------------------------------------------------------------------

setFileLoaded :: MainWindow -> Maybe FilePath -> IO ()
setFileLoaded mainWin Nothing =
  set (mainWindow mainWin) [
      windowTitle := "ThreadScope"
    ]
setFileLoaded mainWin (Just file) =
  set (mainWindow mainWin) [
      windowTitle := file ++ " - ThreadScope"
    ]

setStatusMessage :: MainWindow -> String -> IO ()
setStatusMessage mainWin msg = do
  statusbarPop  (statusBar mainWin) (statusBarCxt mainWin)
  statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg)
  return ()

sidebarSetVisibility :: MainWindow -> Bool -> IO ()
sidebarSetVisibility mainWin visible =
  set (sidebarBox mainWin) [ widgetVisible := visible ]

eventsSetVisibility :: MainWindow -> Bool -> IO ()
eventsSetVisibility mainWin visible =
  set (eventsBox mainWin) [ widgetVisible := visible ]

-------------------------------------------------------------------------------

mainWindowNew :: Builder -> MainWindowActions -> IO MainWindow
mainWindowNew builder actions = do

  let getWidget cast name = builderGetObject builder cast name


  mainWindow         <- getWidget castToWindow "main_window"
  statusBar          <- getWidget castToStatusbar "statusbar"

  sidebarBox         <- getWidget castToWidget "sidebar"
  eventsBox          <- getWidget castToWidget "eventsbox"

  bwToggle           <- getWidget castToCheckMenuItem "black_and_white"
  sidebarToggle      <- getWidget castToCheckMenuItem "view_sidebar"
  eventsToggle       <- getWidget castToCheckMenuItem "view_events"
  openMenuItem       <- getWidget castToMenuItem "openMenuItem"
  exportMenuItem     <- getWidget castToMenuItem "exportMenuItem"
  reloadMenuItem     <- getWidget castToMenuItem "view_reload"
  quitMenuItem       <- getWidget castToMenuItem "quitMenuItem"
  aboutMenuItem      <- getWidget castToMenuItem "aboutMenuItem"

  timelineViewport   <- getWidget castToWidget "timeline_viewport"
--  timelineDrawingArea      <- getWidget castToDrawingArea "timeline_drawingarea"
--  timelineLabelDrawingArea <- getWidget castToDrawingArea "timeline_labels_drawingarea"
--  timelineHScrollbar  <- getWidget castToHScrollbar "timeline_hscroll"
--  timelineVScrollbar  <- getWidget castToVScrollbar "timeline_vscroll"
--  timelineAdj         <- rangeGetAdjustment timelineHScrollbar
--  timelineVAdj        <- rangeGetAdjustment timelineVScrollbar

  zoomInButton       <- getWidget castToToolButton "cpus_zoomin"
  zoomOutButton      <- getWidget castToToolButton "cpus_zoomout"
  zoomFitButton      <- getWidget castToToolButton "cpus_zoomfit"

  showLabelsToggle   <- getWidget castToToggleToolButton "cpus_showlabels"
  firstButton        <- getWidget castToToolButton "cpus_first"
  lastButton         <- getWidget castToToolButton "cpus_last"
  centreButton       <- getWidget castToToolButton "cpus_centre"

  --TODO: these two are currently unbound, but they should be!
  --  eventsTextEntry    <- getWidget castToEntry      "events_entry"
  --  eventsFindButton   <- getWidget castToToolButton "events_find"

  ------------------------------------------------------------------------

  widgetSetAppPaintable mainWindow True --TODO: Really?

  logoPath <- getDataFileName "threadscope.png"
  windowSetIconFromFile mainWindow logoPath

  ------------------------------------------------------------------------
  -- Status bar functionality

  statusBarCxt <- statusbarGetContextId statusBar "file"
  statusbarPush statusBar statusBarCxt "No eventlog loaded."

  ------------------------------------------------------------------------
  -- Bind all the events
  
  -- Menus
  on openMenuItem      menuItemActivate $ mainWinOpen actions
  on exportMenuItem    menuItemActivate $ mainWinExport actions

  on quitMenuItem menuItemActivate $ mainWinQuit actions
  on mainWindow   objectDestroy    $ mainWinQuit actions

  on sidebarToggle  checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle
                                       >>= mainWinViewSidebar actions
  on eventsToggle   checkMenuItemToggled $ checkMenuItemGetActive eventsToggle
                                       >>= mainWinViewEvents  actions
  on bwToggle       checkMenuItemToggled $ checkMenuItemGetActive bwToggle
                                       >>= mainWinViewBW      actions
  on reloadMenuItem menuItemActivate     $ mainWinViewReload actions

  on aboutMenuItem  menuItemActivate     $ mainWinAbout actions

  -- Toolbar  
  onToolButtonClicked firstButton  $ mainWinJumpStart  actions
  onToolButtonClicked lastButton   $ mainWinJumpEnd    actions
  onToolButtonClicked centreButton $ mainWinJumpCursor actions

  onToolButtonClicked zoomInButton  $ mainWinJumpZoomIn  actions
  onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions
  onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions
   
  onToolButtonToggled showLabelsToggle $
    toggleToolButtonGetActive showLabelsToggle >>= mainWinDisplayLabels actions

  -- Key bindings
  --TODO: move these to the timeline module
  onKeyPress timelineViewport $ \Key { Old.eventKeyName = key, eventKeyChar = mch } ->
    case (key, mch) of
      ("Right", _)   -> mainWinScrollRight actions >> return True
      ("Left",  _)   -> mainWinScrollLeft  actions >> return True
      (_ , Just '+') -> mainWinJumpZoomIn  actions >> return True
      (_ , Just '-') -> mainWinJumpZoomOut actions >> return True
      _              -> return False

  ------------------------------------------------------------------------
  -- Show all windows
  widgetShowAll mainWindow

  return MainWindow {..}