{-# LANGUAGE CPP #-}
-- ThreadScope: a graphical viewer for Haskell event log information.
-- Maintainer: satnams@microsoft.com, s.singh@ieee.org
module GUI.Main (runGUI) where
-- Imports for GTK
import Graphics.UI.Gtk as Gtk
import System.Glib.GError (failOnGError)
-- Imports from Haskell library
import Text.Printf
import Control.Monad
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import Control.Concurrent
import qualified Control.Concurrent.Chan as Chan
import Control.Exception
import Prelude hiding (catch)
import Data.Array
import Data.Maybe
import Paths_threadscope
-- Imports for ThreadScope
import GUI.MainWindow as MainWindow
import GUI.Types
import Events.HECs hiding (Event)
import GUI.Dialogs
import Events.ReadEvents
import GUI.EventsView
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
-------------------------------------------------------------------------------
data UIEnv = UIEnv {
mainWin :: MainWindow,
eventsView :: EventsView,
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,
cursorTs :: Timestamp,
cursorPos :: Int
}
postEvent :: Chan Event -> Event -> IO ()
postEvent = Chan.writeChan
getEvent :: Chan Event -> IO Event
getEvent = Chan.readChan
data Event
= EventOpenDialog
| EventExportDialog
| EventAboutDialog
| EventQuit
| EventFileLoad FilePath
| EventTestLoad String
| EventFileReload
| EventFileExport FilePath FileExportFormat
-- | EventStateClear
| EventSetState HECs (Maybe FilePath) String Int Double
| EventShowSidebar Bool
| EventShowEvents Bool
| EventTimelineJumpStart
| EventTimelineJumpEnd
| EventTimelineJumpCursor
| EventTimelineScrollLeft
| EventTimelineScrollRight
| EventTimelineZoomIn
| EventTimelineZoomOut
| EventTimelineZoomToFit
| EventTimelineShowLabels Bool
| EventTimelineShowBW Bool
| EventCursorChangedIndex Int
| EventCursorChangedTimestamp Timestamp
| EventTracesChanged [Trace]
| EventBookmarkAdd
| EventBookmarkRemove Int
| EventBookmarkEdit Int String
| EventUserError String SomeException
-- can add more specific ones if necessary
constructUI :: IO UIEnv
constructUI = failOnGError $ do
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "threadscope.ui"
eventQueue <- Chan.newChan
let post = postEvent eventQueue
mainWin <- mainWindowNew builder MainWindowActions {
mainWinOpen = post EventOpenDialog,
mainWinExport = post EventExportDialog,
mainWinQuit = post EventQuit,
mainWinViewSidebar = post . EventShowSidebar,
mainWinViewEvents = post . EventShowEvents,
mainWinViewReload = post EventFileReload,
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 . EventTimelineShowLabels,
mainWinViewBW = post . EventTimelineShowBW
}
timelineWin <- timelineViewNew builder TimelineViewActions {
timelineViewCursorChanged = post . EventCursorChangedTimestamp
}
eventsView <- eventsViewNew builder EventsViewActions {
timelineViewCursorChanged = post . EventCursorChangedIndex
}
traceView <- traceViewNew builder TraceViewActions {
traceViewTracesChanged = post . EventTracesChanged
}
bookmarkView <- bookmarkViewNew builder BookmarkViewActions {
bookmarkViewAddBookmark = post EventBookmarkAdd,
bookmarkViewRemoveBookmark = post . EventBookmarkRemove,
bookmarkViewGotoBookmark = \ts -> post (EventCursorChangedTimestamp 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) _ = do
MainWindow.setFileLoaded mainWin (Just name)
MainWindow.setStatusMessage mainWin $
printf "%s (%d events, %.3fs)" name nevents timespan
eventsViewSetEvents eventsView (Just (hecEventArray hecs))
traceViewSetHECs traceView hecs
traces' <- traceViewGetTraces traceView
timelineWindowSetHECs timelineWin (Just hecs)
timelineWindowSetTraces timelineWin traces'
-- We set user 'traceEvent' messages as initial bookmarks.
-- This is somewhat of an experiment. If users use lots of trace events
-- then it will not be appropriate and we'll want a separate 'traceMark'.
let usrMsgs = extractUserMessages hecs
sequence_ [ bookmarkViewAdd bookmarkView ts label
| (ts, label) <- usrMsgs ]
timelineWindowSetBookmarks timelineWin (map fst usrMsgs)
continueWith EventlogLoaded {
mfilename = mfilename,
hecs = hecs,
cursorTs = 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
}
case format of
FormatPDF -> saveAsPDF filename hecs viewParams'
FormatPNG -> saveAsPNG filename hecs viewParams'
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 cursorTs 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 (EventTimelineShowLabels showLabels) _ = do
timelineSetShowLabels timelineWin showLabels
continue
dispatch (EventTimelineShowBW showBW) _ = do
timelineSetBWMode timelineWin showBW
continue
dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do
let cursorTs' = eventIndexToTimestamp hecs cursorPos'
timelineSetCursor timelineWin cursorTs'
eventsViewSetCursor eventsView cursorPos'
continueWith eventlogState {
cursorTs = cursorTs',
cursorPos = cursorPos'
}
dispatch (EventCursorChangedTimestamp cursorTs') EventlogLoaded{hecs} = do
let cursorPos' = timestampToEventIndex hecs cursorTs'
timelineSetCursor timelineWin cursorTs'
eventsViewSetCursor eventsView cursorPos'
continueWith eventlogState {
cursorTs = cursorTs',
cursorPos = cursorPos'
}
dispatch (EventTracesChanged traces) _ = do
timelineWindowSetTraces timelineWin traces
continue
dispatch EventBookmarkAdd EventlogLoaded{cursorTs} = do
bookmarkViewAdd bookmarkView cursorTs ""
--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
post (EventSetState hecs mfilename name nevents timespan)
return ()
async doing action =
forkIO (action `catch` \e -> post (EventUserError doing e))
post = postEvent eventQueue
continue = continueWith eventlogState
continueWith = return . Right
-------------------------------------------------------------------------------
runGUI :: Maybe (Either FilePath String) -> IO ()
runGUI initialTrace = do
Gtk.initGUI
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