Main.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module GUI.Main (runGUI) where

-- Imports for GTK
import qualified Graphics.UI.Gtk as Gtk
import System.Glib.GError (failOnGError)

-- Imports from Haskell library
import Text.Printf
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import Control.Concurrent
import qualified Control.Concurrent.Chan as Chan
import Control.Exception
import Data.Array
import Data.Maybe
import Data.Text (Text)

-- Imports for ThreadScope
import qualified GUI.App as App
import qualified GUI.MainWindow as MainWindow
import GUI.Types
import Events.HECs hiding (Event)
import GUI.DataFiles (ui)
import GUI.Dialogs
import Events.ReadEvents
import GUI.EventsView
import GUI.SummaryView
import GUI.StartupInfoView
import GUI.Histogram
import GUI.Timeline
import GUI.TraceView
import GUI.BookmarkView
import GUI.KeyView
import GUI.SaveAs
import qualified GUI.ConcurrencyControl as ConcurrencyControl
import qualified GUI.ProgressView as ProgressView
import qualified GUI.GtkExtras as GtkExtras

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

data UIEnv = UIEnv {

       mainWin       :: MainWindow.MainWindow,
       eventsView    :: EventsView,
       startupView   :: StartupInfoView,
       summaryView   :: SummaryView,
       histogramView :: HistogramView,
       timelineWin   :: TimelineView,
       traceView     :: TraceView,
       bookmarkView  :: BookmarkView,
       keyView       :: KeyView,

       eventQueue    :: Chan Event,
       concCtl       :: ConcurrencyControl.ConcurrencyControl
     }

data EventlogState
   = NoEventlogLoaded
   | EventlogLoaded {
       mfilename :: Maybe FilePath, --test traces have no filepath
       hecs      :: HECs,
       selection :: TimeSelection,
       cursorPos :: Int
     }

postEvent :: Chan Event -> Event -> IO ()
postEvent = Chan.writeChan

getEvent ::  Chan Event -> IO Event
getEvent = Chan.readChan

data Event
   = EventOpenDialog
   | EventExportDialog
   | EventLaunchWebsite
   | EventLaunchTutorial
   | EventAboutDialog
   | EventQuit

   | EventFileLoad   FilePath
   | EventTestLoad   String
   | EventFileReload
   | EventFileExport FilePath FileExportFormat

   | EventSetState HECs (Maybe FilePath) String Int Double

   | EventShowSidebar Bool
   | EventShowEvents  Bool

   | EventTimelineJumpStart
   | EventTimelineJumpEnd
   | EventTimelineJumpCursor
   | EventTimelineScrollLeft
   | EventTimelineScrollRight
   | EventTimelineZoomIn
   | EventTimelineZoomOut
   | EventTimelineZoomToFit
   | EventTimelineLabelsMode Bool
   | EventTimelineShowBW     Bool

   | EventCursorChangedIndex     Int
   | EventCursorChangedSelection TimeSelection

   | EventTracesChanged [Trace]

   | EventBookmarkAdd
   | EventBookmarkRemove Int
   | EventBookmarkEdit   Int Text

   | EventUserError String SomeException
                    -- can add more specific ones if necessary

constructUI :: IO UIEnv
constructUI = failOnGError $ do

  builder <- Gtk.builderNew
  Gtk.builderAddFromString builder $ui

  eventQueue <- Chan.newChan
  let post = postEvent eventQueue

  mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions {
    mainWinOpen          = post EventOpenDialog,
    mainWinExport        = post EventExportDialog,
    mainWinQuit          = post EventQuit,
    mainWinViewSidebar   = post . EventShowSidebar,
    mainWinViewEvents    = post . EventShowEvents,
    mainWinViewReload    = post EventFileReload,
    mainWinWebsite       = post EventLaunchWebsite,
    mainWinTutorial      = post EventLaunchTutorial,
    mainWinAbout         = post EventAboutDialog,
    mainWinJumpStart     = post EventTimelineJumpStart,
    mainWinJumpEnd       = post EventTimelineJumpEnd,
    mainWinJumpCursor    = post EventTimelineJumpCursor,
    mainWinScrollLeft    = post EventTimelineScrollLeft,
    mainWinScrollRight   = post EventTimelineScrollRight,
    mainWinJumpZoomIn    = post EventTimelineZoomIn,
    mainWinJumpZoomOut   = post EventTimelineZoomOut,
    mainWinJumpZoomFit   = post EventTimelineZoomToFit,
    mainWinDisplayLabels = post . EventTimelineLabelsMode,
    mainWinViewBW        = post . EventTimelineShowBW
  }

  timelineWin <- timelineViewNew builder TimelineViewActions {
    timelineViewSelectionChanged = post . EventCursorChangedSelection
  }

  eventsView <- eventsViewNew builder EventsViewActions {
    eventsViewCursorChanged = post . EventCursorChangedIndex
  }

  startupView <- startupInfoViewNew builder
  summaryView <- summaryViewNew builder

  histogramView <- histogramViewNew builder

  traceView <- traceViewNew builder TraceViewActions {
    traceViewTracesChanged = post . EventTracesChanged
  }

  bookmarkView <- bookmarkViewNew builder BookmarkViewActions {
    bookmarkViewAddBookmark    = post EventBookmarkAdd,
    bookmarkViewRemoveBookmark = post . EventBookmarkRemove,
    bookmarkViewGotoBookmark   = \ts -> do
      post (EventCursorChangedSelection (PointSelection ts))
      post EventTimelineJumpCursor,
    bookmarkViewEditLabel      = \n v -> post (EventBookmarkEdit n v)
  }

  keyView <- keyViewNew builder

  concCtl <- ConcurrencyControl.start

  return UIEnv{..}

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

data LoopDone = LoopDone

eventLoop :: UIEnv -> EventlogState -> IO ()
eventLoop uienv@UIEnv{..} eventlogState = do

    event <- getEvent eventQueue
    next  <- dispatch event eventlogState
#if __GLASGOW_HASKELL__ <= 612
               -- workaround for a wierd exception handling bug in ghc-6.12
               `catch` \e -> throwIO (e :: SomeException)
#endif
    case next of
      Left  LoopDone       -> return ()
      Right eventlogState' -> eventLoop uienv eventlogState'

  where
    dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState)

    dispatch EventQuit _ = return (Left LoopDone)

    dispatch EventOpenDialog _ = do
      openFileDialog mainWin $ \filename ->
        post (EventFileLoad filename)
      continue

    dispatch (EventFileLoad filename) _ = do
      async "loading the eventlog" $
        loadEvents (Just filename) (registerEventsFromFile filename)
      --TODO: set state to be empty during loading
      continue

    dispatch (EventTestLoad testname) _ = do
      async "loading the test eventlog" $
        loadEvents Nothing (registerEventsFromTrace testname)
      --TODO: set state to be empty during loading
      continue

    dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do
      async "reloading the eventlog" $
        loadEvents (Just filename) (registerEventsFromFile filename)
      --TODO: set state to be empty during loading
      continue

    dispatch EventFileReload EventlogLoaded{mfilename = Nothing} =
      continue

--    dispatch EventClearState _

    dispatch (EventSetState hecs mfilename name nevents timespan) _ =

     -- We have to draw this ASAP, before the user manages to move
     -- the mouse away from the window, or the window is left
     -- in a partially drawn state.
     ConcurrencyControl.fullSpeed concCtl $ do

      MainWindow.setFileLoaded mainWin (Just name)
      MainWindow.setStatusMessage mainWin $
        printf "%s (%d events, %.3fs)" name nevents timespan

      let mevents = Just $ hecEventArray hecs
      eventsViewSetEvents eventsView mevents
      startupInfoViewSetEvents startupView mevents
      summaryViewSetEvents summaryView mevents
      histogramViewSetHECs histogramView (Just hecs)
      traceViewSetHECs traceView hecs
      traces' <- traceViewGetTraces traceView
      timelineWindowSetHECs timelineWin (Just hecs)
      timelineWindowSetTraces timelineWin traces'

      -- We set user 'traceMarker' events as initial bookmarks.
      let usrMarkers = extractUserMarkers hecs
      bookmarkViewClear bookmarkView
      sequence_ [ bookmarkViewAdd bookmarkView ts label
                | (ts, label) <- usrMarkers ]
      timelineWindowSetBookmarks timelineWin (map fst usrMarkers)

      if nevents == 0
        then continueWith NoEventlogLoaded
        else continueWith EventlogLoaded
          { mfilename = mfilename
          , hecs      = hecs
          , selection = PointSelection 0
          , cursorPos = 0
          }

    dispatch EventExportDialog
             EventlogLoaded {mfilename} = do
      exportFileDialog mainWin (fromMaybe "" mfilename) $ \filename' format ->
        post (EventFileExport filename' format)
      continue

    dispatch (EventFileExport filename format)
             EventlogLoaded {hecs} = do
      viewParams <- timelineGetViewParameters timelineWin
      let viewParams' = viewParams {
                          detail     = 1,
                          bwMode     = False,
                          labelsMode = False
                        }
      let yScaleArea = timelineGetYScaleArea timelineWin
      case format of
        FormatPDF ->
          saveAsPDF filename hecs viewParams' yScaleArea
        FormatPNG ->
          saveAsPNG filename hecs viewParams' yScaleArea
      continue

    dispatch EventLaunchWebsite _ = do
      GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope"
      continue

    dispatch EventLaunchTutorial _ = do
      GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope_Tour"
      continue

    dispatch EventAboutDialog _ = do
      aboutDialog mainWin
      continue

    dispatch (EventShowSidebar visible) _ = do
      MainWindow.sidebarSetVisibility mainWin visible
      continue

    dispatch (EventShowEvents visible) _ = do
      MainWindow.eventsSetVisibility mainWin visible
      continue

    dispatch EventTimelineJumpStart _ = do
      timelineScrollToBeginning timelineWin
      eventsViewScrollToLine eventsView 0
      continue

    dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do
      timelineScrollToEnd timelineWin
      let (_,end) = bounds (hecEventArray hecs)
      eventsViewScrollToLine eventsView end
      continue

    dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do
      timelineCentreOnCursor timelineWin --TODO: pass selection here
      eventsViewScrollToLine eventsView cursorPos
      continue

    dispatch EventTimelineScrollLeft  _ = do
      timelineScrollLeft  timelineWin
      continue

    dispatch EventTimelineScrollRight _ = do
      timelineScrollRight timelineWin
      continue
    dispatch EventTimelineZoomIn      _ = do
      timelineZoomIn    timelineWin
      continue
    dispatch EventTimelineZoomOut     _ = do
      timelineZoomOut   timelineWin
      continue
    dispatch EventTimelineZoomToFit   _ = do
      timelineZoomToFit timelineWin
      continue

    dispatch (EventTimelineLabelsMode labelsMode) _ = do
      timelineSetLabelsMode timelineWin labelsMode
      continue

    dispatch (EventTimelineShowBW showBW) _ = do
      timelineSetBWMode timelineWin showBW
      continue

    dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do
      let cursorTs'  = eventIndexToTimestamp hecs cursorPos'
          selection' = PointSelection cursorTs'
      mselection <- timelineSetSelection timelineWin selection'
      setSelection cursorPos' Nothing mselection

    dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))
             EventlogLoaded{hecs} = do
      let cursorPos' = timestampToEventIndex hecs cursorTs'
      mselection <- timelineSetSelection timelineWin selection'
      setSelection cursorPos' Nothing mselection

    dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))
             EventlogLoaded{hecs} = do
      let cursorPos' = timestampToEventIndex hecs start
          mrange = Just (cursorPos', timestampToEventIndex hecs end)
      mselection <- timelineSetSelection timelineWin selection'
      setSelection cursorPos' mrange mselection

    dispatch (EventTracesChanged traces) _ = do
      timelineWindowSetTraces timelineWin traces
      continue

    dispatch EventBookmarkAdd EventlogLoaded{selection} = do
      case selection of
        PointSelection a   -> bookmarkViewAdd bookmarkView a ""
        RangeSelection a b -> do bookmarkViewAdd bookmarkView a ""
                                 bookmarkViewAdd bookmarkView b ""
      --TODO: should have a way to add/set a single bookmark for the timeline
      -- rather than this hack where we ask the bookmark view for the whole lot.
      ts <- bookmarkViewGet bookmarkView
      timelineWindowSetBookmarks timelineWin (map fst ts)
      continue

    dispatch (EventBookmarkRemove n) _ = do
      bookmarkViewRemove bookmarkView n
      --TODO: should have a way to add/set a single bookmark for the timeline
      -- rather than this hack where we ask the bookmark view for the whole lot.
      ts <- bookmarkViewGet bookmarkView
      timelineWindowSetBookmarks timelineWin (map fst ts)
      continue

    dispatch (EventBookmarkEdit n v) _ = do
      bookmarkViewSetLabel bookmarkView n v
      continue

    dispatch (EventUserError doing exception) _ = do
      let headline    = "There was a problem " ++ doing ++ "."
          explanation = show exception
      errorMessageDialog mainWin headline explanation
      continue

    dispatch _ NoEventlogLoaded = continue

    loadEvents mfilename registerEvents = do
      ConcurrencyControl.fullSpeed concCtl $
        ProgressView.withProgress mainWin $ \progress -> do
          (hecs, name, nevents, timespan) <- registerEvents progress
          -- This is a desperate hack to avoid the "segfault on reload" bug
          -- http://trac.haskell.org/ThreadScope/ticket/1
          -- It should be enough to let other threads finish and so avoid
          -- re-entering gtk C code (see ticket for the dirty details).
          --
          -- Unfortunately it halts drawing of the loaded events if the user
          -- manages to move the mouse away from the window during the delay.
          --   threadDelay 100000 -- 1/10th of a second
          post (EventSetState hecs mfilename name nevents timespan)
      return ()

    async doing action =
      forkIO (action `catch` \e -> post (EventUserError doing e))

    setSelection cursorPos' _ (Just selection'@(PointSelection _)) = do
      eventsViewSetCursor eventsView cursorPos' Nothing
      histogramViewSetInterval histogramView Nothing
      summaryViewSetInterval summaryView Nothing
      continueWith eventlogState {
        selection = selection',
        cursorPos = cursorPos'
      }
    setSelection cursorPos' mrange (Just selection'@(RangeSelection start end)) = do
      eventsViewSetCursor eventsView cursorPos' mrange
      histogramViewSetInterval histogramView (Just (start, end))
      summaryViewSetInterval summaryView (Just (start, end))
      continueWith eventlogState {
        selection = selection',
        cursorPos = cursorPos'
      }
    setSelection _ _ Nothing = continue

    post = postEvent eventQueue
    continue = continueWith eventlogState
    continueWith = return . Right

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

runGUI :: Maybe (Either FilePath String) -> IO ()
runGUI initialTrace = do
  Gtk.initGUI

  App.initApp

  uiEnv <- constructUI

  let post = postEvent (eventQueue uiEnv)

  case initialTrace of
   Nothing                -> return ()
   Just (Left  filename)  -> post (EventFileLoad filename)
   Just (Right traceName) -> post (EventTestLoad traceName)

  doneVar <- newEmptyMVar

  forkIO $ do
    res <- try $ eventLoop uiEnv NoEventlogLoaded
    Gtk.mainQuit
    putMVar doneVar (res :: Either SomeException ())

#ifndef mingw32_HOST_OS
  installHandler sigINT (Catch $ post EventQuit) Nothing
#endif

  -- Enter Gtk+ main event loop.
  Gtk.mainGUI

  -- Wait for child event loop to terminate
  -- This lets us wait for any exceptions.
  either throwIO return =<< takeMVar doneVar