1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE OverloadedStrings #-}
4module GUI.Main (runGUI) where
5
6-- Imports for GTK
7import qualified Graphics.UI.Gtk as Gtk
8import System.Glib.GError (failOnGError)
9
10-- Imports from Haskell library
11import Text.Printf
12#ifndef mingw32_HOST_OS
13import System.Posix
14#endif
15import Control.Concurrent
16import qualified Control.Concurrent.Chan as Chan
17import Control.Exception
18import Data.Array
19import Data.Maybe
20import Data.Text (Text)
21
22-- Imports for ThreadScope
23import qualified GUI.App as App
24import qualified GUI.MainWindow as MainWindow
25import GUI.Types
26import Events.HECs hiding (Event)
27import GUI.DataFiles (ui)
28import GUI.Dialogs
29import Events.ReadEvents
30import GUI.EventsView
31import GUI.SummaryView
32import GUI.StartupInfoView
33import GUI.Histogram
34import GUI.Timeline
35import GUI.TraceView
36import GUI.BookmarkView
37import GUI.KeyView
38import GUI.SaveAs
39import qualified GUI.ConcurrencyControl as ConcurrencyControl
40import qualified GUI.ProgressView as ProgressView
41import qualified GUI.GtkExtras as GtkExtras
42
43-------------------------------------------------------------------------------
44
45data UIEnv = UIEnv {
46
47       mainWin       :: MainWindow.MainWindow,
48       eventsView    :: EventsView,
49       startupView   :: StartupInfoView,
50       summaryView   :: SummaryView,
51       histogramView :: HistogramView,
52       timelineWin   :: TimelineView,
53       traceView     :: TraceView,
54       bookmarkView  :: BookmarkView,
55       keyView       :: KeyView,
56
57       eventQueue    :: Chan Event,
58       concCtl       :: ConcurrencyControl.ConcurrencyControl
59     }
60
61data EventlogState
62   = NoEventlogLoaded
63   | EventlogLoaded {
64       mfilename :: Maybe FilePath, --test traces have no filepath
65       hecs      :: HECs,
66       selection :: TimeSelection,
67       cursorPos :: Int
68     }
69
70postEvent :: Chan Event -> Event -> IO ()
71postEvent = Chan.writeChan
72
73getEvent ::  Chan Event -> IO Event
74getEvent = Chan.readChan
75
76data Event
77   = EventOpenDialog
78   | EventExportDialog
79   | EventLaunchWebsite
80   | EventLaunchTutorial
81   | EventAboutDialog
82   | EventQuit
83
84   | EventFileLoad   FilePath
85   | EventTestLoad   String
86   | EventFileReload
87   | EventFileExport FilePath FileExportFormat
88
89   | EventSetState HECs (Maybe FilePath) String Int Double
90
91   | EventShowSidebar Bool
92   | EventShowEvents  Bool
93
94   | EventTimelineJumpStart
95   | EventTimelineJumpEnd
96   | EventTimelineJumpCursor
97   | EventTimelineScrollLeft
98   | EventTimelineScrollRight
99   | EventTimelineZoomIn
100   | EventTimelineZoomOut
101   | EventTimelineZoomToFit
102   | EventTimelineLabelsMode Bool
103   | EventTimelineShowBW     Bool
104
105   | EventCursorChangedIndex     Int
106   | EventCursorChangedSelection TimeSelection
107
108   | EventTracesChanged [Trace]
109
110   | EventBookmarkAdd
111   | EventBookmarkRemove Int
112   | EventBookmarkEdit   Int Text
113
114   | EventUserError String SomeException
115                    -- can add more specific ones if necessary
116
117constructUI :: IO UIEnv
118constructUI = failOnGError $ do
119
120  builder <- Gtk.builderNew
121  Gtk.builderAddFromString builder $ui
122
123  eventQueue <- Chan.newChan
124  let post = postEvent eventQueue
125
126  mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions {
127    mainWinOpen          = post EventOpenDialog,
128    mainWinExport        = post EventExportDialog,
129    mainWinQuit          = post EventQuit,
130    mainWinViewSidebar   = post . EventShowSidebar,
131    mainWinViewEvents    = post . EventShowEvents,
132    mainWinViewReload    = post EventFileReload,
133    mainWinWebsite       = post EventLaunchWebsite,
134    mainWinTutorial      = post EventLaunchTutorial,
135    mainWinAbout         = post EventAboutDialog,
136    mainWinJumpStart     = post EventTimelineJumpStart,
137    mainWinJumpEnd       = post EventTimelineJumpEnd,
138    mainWinJumpCursor    = post EventTimelineJumpCursor,
139    mainWinScrollLeft    = post EventTimelineScrollLeft,
140    mainWinScrollRight   = post EventTimelineScrollRight,
141    mainWinJumpZoomIn    = post EventTimelineZoomIn,
142    mainWinJumpZoomOut   = post EventTimelineZoomOut,
143    mainWinJumpZoomFit   = post EventTimelineZoomToFit,
144    mainWinDisplayLabels = post . EventTimelineLabelsMode,
145    mainWinViewBW        = post . EventTimelineShowBW
146  }
147
148  timelineWin <- timelineViewNew builder TimelineViewActions {
149    timelineViewSelectionChanged = post . EventCursorChangedSelection
150  }
151
152  eventsView <- eventsViewNew builder EventsViewActions {
153    eventsViewCursorChanged = post . EventCursorChangedIndex
154  }
155
156  startupView <- startupInfoViewNew builder
157  summaryView <- summaryViewNew builder
158
159  histogramView <- histogramViewNew builder
160
161  traceView <- traceViewNew builder TraceViewActions {
162    traceViewTracesChanged = post . EventTracesChanged
163  }
164
165  bookmarkView <- bookmarkViewNew builder BookmarkViewActions {
166    bookmarkViewAddBookmark    = post EventBookmarkAdd,
167    bookmarkViewRemoveBookmark = post . EventBookmarkRemove,
168    bookmarkViewGotoBookmark   = \ts -> do
169      post (EventCursorChangedSelection (PointSelection ts))
170      post EventTimelineJumpCursor,
171    bookmarkViewEditLabel      = \n v -> post (EventBookmarkEdit n v)
172  }
173
174  keyView <- keyViewNew builder
175
176  concCtl <- ConcurrencyControl.start
177
178  return UIEnv{..}
179
180-------------------------------------------------------------------------------
181
182data LoopDone = LoopDone
183
184eventLoop :: UIEnv -> EventlogState -> IO ()
185eventLoop uienv@UIEnv{..} eventlogState = do
186
187    event <- getEvent eventQueue
188    next  <- dispatch event eventlogState
189#if __GLASGOW_HASKELL__ <= 612
190               -- workaround for a wierd exception handling bug in ghc-6.12
191               `catch` \e -> throwIO (e :: SomeException)
192#endif
193    case next of
194      Left  LoopDone       -> return ()
195      Right eventlogState' -> eventLoop uienv eventlogState'
196
197  where
198    dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState)
199
200    dispatch EventQuit _ = return (Left LoopDone)
201
202    dispatch EventOpenDialog _ = do
203      openFileDialog mainWin $ \filename ->
204        post (EventFileLoad filename)
205      continue
206
207    dispatch (EventFileLoad filename) _ = do
208      async "loading the eventlog" $
209        loadEvents (Just filename) (registerEventsFromFile filename)
210      --TODO: set state to be empty during loading
211      continue
212
213    dispatch (EventTestLoad testname) _ = do
214      async "loading the test eventlog" $
215        loadEvents Nothing (registerEventsFromTrace testname)
216      --TODO: set state to be empty during loading
217      continue
218
219    dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do
220      async "reloading the eventlog" $
221        loadEvents (Just filename) (registerEventsFromFile filename)
222      --TODO: set state to be empty during loading
223      continue
224
225    dispatch EventFileReload EventlogLoaded{mfilename = Nothing} =
226      continue
227
228--    dispatch EventClearState _
229
230    dispatch (EventSetState hecs mfilename name nevents timespan) _ =
231
232     -- We have to draw this ASAP, before the user manages to move
233     -- the mouse away from the window, or the window is left
234     -- in a partially drawn state.
235     ConcurrencyControl.fullSpeed concCtl $ do
236
237      MainWindow.setFileLoaded mainWin (Just name)
238      MainWindow.setStatusMessage mainWin $
239        printf "%s (%d events, %.3fs)" name nevents timespan
240
241      let mevents = Just $ hecEventArray hecs
242      eventsViewSetEvents eventsView mevents
243      startupInfoViewSetEvents startupView mevents
244      summaryViewSetEvents summaryView mevents
245      histogramViewSetHECs histogramView (Just hecs)
246      traceViewSetHECs traceView hecs
247      traces' <- traceViewGetTraces traceView
248      timelineWindowSetHECs timelineWin (Just hecs)
249      timelineWindowSetTraces timelineWin traces'
250
251      -- We set user 'traceMarker' events as initial bookmarks.
252      let usrMarkers = extractUserMarkers hecs
253      bookmarkViewClear bookmarkView
254      sequence_ [ bookmarkViewAdd bookmarkView ts label
255                | (ts, label) <- usrMarkers ]
256      timelineWindowSetBookmarks timelineWin (map fst usrMarkers)
257
258      if nevents == 0
259        then continueWith NoEventlogLoaded
260        else continueWith EventlogLoaded
261          { mfilename = mfilename
262          , hecs      = hecs
263          , selection = PointSelection 0
264          , cursorPos = 0
265          }
266
267    dispatch EventExportDialog
268             EventlogLoaded {mfilename} = do
269      exportFileDialog mainWin (fromMaybe "" mfilename) $ \filename' format ->
270        post (EventFileExport filename' format)
271      continue
272
273    dispatch (EventFileExport filename format)
274             EventlogLoaded {hecs} = do
275      viewParams <- timelineGetViewParameters timelineWin
276      let viewParams' = viewParams {
277                          detail     = 1,
278                          bwMode     = False,
279                          labelsMode = False
280                        }
281      let yScaleArea = timelineGetYScaleArea timelineWin
282      case format of
283        FormatPDF ->
284          saveAsPDF filename hecs viewParams' yScaleArea
285        FormatPNG ->
286          saveAsPNG filename hecs viewParams' yScaleArea
287      continue
288
289    dispatch EventLaunchWebsite _ = do
290      GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope"
291      continue
292
293    dispatch EventLaunchTutorial _ = do
294      GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope_Tour"
295      continue
296
297    dispatch EventAboutDialog _ = do
298      aboutDialog mainWin
299      continue
300
301    dispatch (EventShowSidebar visible) _ = do
302      MainWindow.sidebarSetVisibility mainWin visible
303      continue
304
305    dispatch (EventShowEvents visible) _ = do
306      MainWindow.eventsSetVisibility mainWin visible
307      continue
308
309    dispatch EventTimelineJumpStart _ = do
310      timelineScrollToBeginning timelineWin
311      eventsViewScrollToLine eventsView 0
312      continue
313
314    dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do
315      timelineScrollToEnd timelineWin
316      let (_,end) = bounds (hecEventArray hecs)
317      eventsViewScrollToLine eventsView end
318      continue
319
320    dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do
321      timelineCentreOnCursor timelineWin --TODO: pass selection here
322      eventsViewScrollToLine eventsView cursorPos
323      continue
324
325    dispatch EventTimelineScrollLeft  _ = do
326      timelineScrollLeft  timelineWin
327      continue
328
329    dispatch EventTimelineScrollRight _ = do
330      timelineScrollRight timelineWin
331      continue
332    dispatch EventTimelineZoomIn      _ = do
333      timelineZoomIn    timelineWin
334      continue
335    dispatch EventTimelineZoomOut     _ = do
336      timelineZoomOut   timelineWin
337      continue
338    dispatch EventTimelineZoomToFit   _ = do
339      timelineZoomToFit timelineWin
340      continue
341
342    dispatch (EventTimelineLabelsMode labelsMode) _ = do
343      timelineSetLabelsMode timelineWin labelsMode
344      continue
345
346    dispatch (EventTimelineShowBW showBW) _ = do
347      timelineSetBWMode timelineWin showBW
348      continue
349
350    dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do
351      let cursorTs'  = eventIndexToTimestamp hecs cursorPos'
352          selection' = PointSelection cursorTs'
353      timelineSetSelection timelineWin selection'
354      eventsViewSetCursor eventsView  cursorPos' Nothing
355      continueWith eventlogState {
356        selection = selection',
357        cursorPos = cursorPos'
358      }
359
360    dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))
361             EventlogLoaded{hecs} = do
362      let cursorPos' = timestampToEventIndex hecs cursorTs'
363      timelineSetSelection timelineWin selection'
364      eventsViewSetCursor eventsView cursorPos' Nothing
365      histogramViewSetInterval histogramView Nothing
366      summaryViewSetInterval summaryView Nothing
367      continueWith eventlogState {
368        selection = selection',
369        cursorPos = cursorPos'
370      }
371
372    dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))
373             EventlogLoaded{hecs} = do
374      let cursorPos' = timestampToEventIndex hecs start
375          mrange = Just (cursorPos', timestampToEventIndex hecs end)
376      timelineSetSelection timelineWin selection'
377      eventsViewSetCursor eventsView cursorPos' mrange
378      histogramViewSetInterval histogramView (Just (start, end))
379      summaryViewSetInterval summaryView (Just (start, end))
380      continueWith eventlogState {
381        selection = selection',
382        cursorPos = cursorPos'
383      }
384
385    dispatch (EventTracesChanged traces) _ = do
386      timelineWindowSetTraces timelineWin traces
387      continue
388
389    dispatch EventBookmarkAdd EventlogLoaded{selection} = do
390      case selection of
391        PointSelection a   -> bookmarkViewAdd bookmarkView a ""
392        RangeSelection a b -> do bookmarkViewAdd bookmarkView a ""
393                                 bookmarkViewAdd bookmarkView b ""
394      --TODO: should have a way to add/set a single bookmark for the timeline
395      -- rather than this hack where we ask the bookmark view for the whole lot.
396      ts <- bookmarkViewGet bookmarkView
397      timelineWindowSetBookmarks timelineWin (map fst ts)
398      continue
399
400    dispatch (EventBookmarkRemove n) _ = do
401      bookmarkViewRemove bookmarkView n
402      --TODO: should have a way to add/set a single bookmark for the timeline
403      -- rather than this hack where we ask the bookmark view for the whole lot.
404      ts <- bookmarkViewGet bookmarkView
405      timelineWindowSetBookmarks timelineWin (map fst ts)
406      continue
407
408    dispatch (EventBookmarkEdit n v) _ = do
409      bookmarkViewSetLabel bookmarkView n v
410      continue
411
412    dispatch (EventUserError doing exception) _ = do
413      let headline    = "There was a problem " ++ doing ++ "."
414          explanation = show exception
415      errorMessageDialog mainWin headline explanation
416      continue
417
418    dispatch _ NoEventlogLoaded = continue
419
420    loadEvents mfilename registerEvents = do
421      ConcurrencyControl.fullSpeed concCtl $
422        ProgressView.withProgress mainWin $ \progress -> do
423          (hecs, name, nevents, timespan) <- registerEvents progress
424          -- This is a desperate hack to avoid the "segfault on reload" bug
425          -- http://trac.haskell.org/ThreadScope/ticket/1
426          -- It should be enough to let other threads finish and so avoid
427          -- re-entering gtk C code (see ticket for the dirty details).
428          --
429          -- Unfortunately it halts drawing of the loaded events if the user
430          -- manages to move the mouse away from the window during the delay.
431          --   threadDelay 100000 -- 1/10th of a second
432          post (EventSetState hecs mfilename name nevents timespan)
433      return ()
434
435    async doing action =
436      forkIO (action `catch` \e -> post (EventUserError doing e))
437
438    post = postEvent eventQueue
439    continue = continueWith eventlogState
440    continueWith = return . Right
441
442-------------------------------------------------------------------------------
443
444runGUI :: Maybe (Either FilePath String) -> IO ()
445runGUI initialTrace = do
446  Gtk.initGUI
447
448  App.initApp
449
450  uiEnv <- constructUI
451
452  let post = postEvent (eventQueue uiEnv)
453
454  case initialTrace of
455   Nothing                -> return ()
456   Just (Left  filename)  -> post (EventFileLoad filename)
457   Just (Right traceName) -> post (EventTestLoad traceName)
458
459  doneVar <- newEmptyMVar
460
461  forkIO $ do
462    res <- try $ eventLoop uiEnv NoEventlogLoaded
463    Gtk.mainQuit
464    putMVar doneVar (res :: Either SomeException ())
465
466#ifndef mingw32_HOST_OS
467  installHandler sigINT (Catch $ post EventQuit) Nothing
468#endif
469
470  -- Enter Gtk+ main event loop.
471  Gtk.mainGUI
472
473  -- Wait for child event loop to terminate
474  -- This lets us wait for any exceptions.
475  either throwIO return =<< takeMVar doneVar
476