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