edentv-4.9.2: EdenTV.hs
{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagram
to visualize the behaviour of Eden programs.
Copyright (C) 2005-2014 Philipps Universitaet Marburg
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-}
module Main (main) where
import Graphics.UI.Gtk hiding (deleteEvent, destroyEvent, eventButton)
import Graphics.UI.Gtk.Gdk.Events
import Graphics.UI.Gtk.Windows.MessageDialog
import Graphics.UI.Gtk.Builder
import Graphics.UI.Gtk.General.StockItems
import Graphics.Rendering.Cairo hiding (version)
import Control.Concurrent
import Control.Monad.Fix
import Control.Monad
import EdenTvType
import EdenTvBasic
import EdenTvInteract
import EdenTvViewer
import System.Environment
import System.Exit
import System.Directory
import System.FilePath.Posix
import System.Directory
import System.CPUTime
import System.IO
import Data.List
import Data.Text(pack, unpack)
import RTSEventsParser
import System.IO.Unsafe
import Debug.Trace
import Paths_edentv( -- version,
getDataFileName
) -- this file is generated by cabal
import qualified Paths_edentv
import Data.Version(showVersion) -- to extract version from there
-- unsafe CAF to detect the file name once and return it as a
-- constant immediately for every call later:
{-# NOINLINE uiFile #-}
uiFile = unsafePerformIO $ do
let filename = "edentv.ui" -- change only here if desired
gladefile <- getDataFileName filename
inDataDir <- doesFileExist gladefile
inLocalDir <- doesFileExist filename
if inDataDir
then return gladefile -- prefer file in data dir
else if inLocalDir
then return filename -- otherwise assume local
else error "No UI file found in local or shared dir"
-- Datadir, usually "share/edentv-<VERSION>" holds the glade file.
-- Load the glade file from install path or local, specify root and domain
-- (XML is allegedly cached internally, but check is always repeated)
-- using Gtk.Builder, which will throw exceptions on errors (could catch..)
edentvGladeFile :: [String] -> IO Builder
edentvGladeFile objs
= do b <- builderNew
if null objs
then builderAddFromFile b uiFile
else builderAddObjectsFromFile b uiFile objs
-- in case of xml problems: let it crash!
return b
version :: String
version = showVersion Paths_edentv.version
regpath = "/apps/unimar/edentv/lastPath"
-- some general GTK-Events:
deleteEvent :: Event -> IO Bool
deleteEvent _ = do return False
destroyEvent, quitEvent, closeEvent :: IO ()
destroyEvent = do mainQuit
quitEvent = do mainQuit
closeEvent = do return ()
data WindowsState = WS {
windowsMenus :: [Menu]
}
type WidgetCollection = (Menu, MenuItem, MenuItem, MenuItem, MVar WindowsState)
-- Wins, menuOpen, menuOpenWithoutMsgs, menuExit, state
-- openEvent: open a new Tracefile
openEvent :: Window -> WidgetCollection -> MVar EdenTvState -> Bool -> IO ()
openEvent parent ws edentvState ignoreMessages = do
--Select Tracefile to load
fileSelect <- fileChooserDialogNew (Just "Select Tracefile") (Just parent)
FileChooserActionOpen [("OK",ResponseOk),("Cancel",ResponseCancel)]
globalState <- readMVar edentvState
let oldPath = lastPath globalState
if null oldPath
then return True
else fileChooserSetCurrentFolder fileSelect oldPath
widgetShow fileSelect
response <- dialogRun fileSelect
case response of -- which Button was pressed?
ResponseOk -> do
Just fileName <- fileChooserGetFilename fileSelect
path <- fileChooserGetCurrentFolder fileSelect
case path of Just filePath -> swapMVar edentvState (globalState { lastPath = filePath })
Nothing -> return globalState
widgetDestroy fileSelect
-- display dialog with progress indicator
tryToOpen fileName ws ignoreMessages False edentvState
_ -> do
widgetDestroy fileSelect -- any other response
tryToOpen :: String -> WidgetCollection -> Bool -> Bool -> MVar EdenTvState -> IO ()
tryToOpen filename ws ignoreMessages showMessages edentvState = do
dlg <- dialogNew
windowSetTitle dlg "parsing file..."
button <- dialogAddButton dlg stockCancel ResponseCancel
upper <- dialogGetUpper dlg
pg <- progressBarNew
boxPackStartDefaults upper pg
widgetShowAll dlg
-- animate the progressbar
threadProgress <- forkIO (showProgress pg)
hID <- idleAdd (yield >> return True) priorityDefaultIdle
-- start concurrent process to read tracefile
threadTrace <- forkIO (openTracefile filename ws dlg ignoreMessages showMessages edentvState)
-- Cancel-event!
onClicked button (opCancel threadTrace dlg)
dialogRun dlg -- wating for end of parsing or user interrupt
killThread threadProgress
idleRemove hID
widgetDestroy dlg
where
showProgress :: ProgressBar -> IO ()
showProgress pb = do
progressBarPulse pb
threadDelay 200000
showProgress pb
opCancel :: ThreadId -> Dialog -> IO ()
opCancel thread dialog = do
killThread thread
dialogResponse dialog ResponseOk
hLines :: Show a => Handle -> [a] -> IO ()
hLines h (x:xs) = do
hPutStrLn h (show x)
hLines h xs
hLines _ _ = return ()
-- open a new Trace-Window and display the Trace
openTracefile :: String -> WidgetCollection -> Dialog -> Bool -> Bool -> MVar EdenTvState -> IO ()
openTracefile filename widgets@(winList,mainOpen, mainOpenWithoutMsgs, exitApp, winMenus)
dialog ignoreMessages showMessages edentvState
= do
putStrLn (filename ++ ":")
time <- getCPUTime
traces' <- (traceRTSFile filename ignoreMessages)
case traces' of
Failed msg -> do
dialogResponse dialog ResponseOk
errorMessage ("Tracefile seems not to be valid:\n" ++ msg)
Ok traces -> do
-- build window and render traces:
let --((m,p,t),mt,(maxStartupTimeInSeconds, _), (msgs,amsgs,hmsgs,pTree,rcvtimes),(minT,maxT,maxST,_,maxD),(nm,allP,nt)) = traces
nm = noOfMachines traces
np = length $ processlist traces
allP = noOfProcesses traces
nt = noOfThreads traces
(msgs,_,hmsgs,_,_) = messagelist traces
minT = min_t traces
maxT = max_t traces
maxST = max_t_diff traces
strRunT = formatFloat (maxT - minT)
allMsgs = sum (map (\ (_,_,_,d) -> d) hmsgs) + length msgs
time' <- getCPUTime
let timeString = ("\n Traces computed in " ++
show (fromIntegral (time' - time) / 1000000000000) ++ " seconds.")
putStrLn timeString
-- load XML-description from gladefile
gladeXML <- edentvGladeFile ["EdTVTrace", "accelgroup1","liststore1"]
-- get access to the widgets from gladefile
window <- builderGetObject gladeXML castToWindow "EdTVTrace"
pic <- builderGetObject gladeXML castToDrawingArea "drawingarea"
win <- widgetGetDrawWindow pic
viewport <- builderGetObject gladeXML castToViewport "viewport"
scrldWnd <- builderGetObject gladeXML castToScrolledWindow "scrolledwindow"
buttonLocalNull <- builderGetObject gladeXML castToToggleToolButton "localNull"
buttonMessages <- builderGetObject gladeXML castToToggleToolButton "messages"
buttonInfo <- builderGetObject gladeXML castToToolButton "infoButton"
buttonConfMsgs <- builderGetObject gladeXML castToToolButton "msgs-relations"
traceZoomInH <- builderGetObject gladeXML castToToolButton "zoomInH"
traceZoomInV <- builderGetObject gladeXML castToToolButton "zoomInV"
traceZoomIn <- builderGetObject gladeXML castToMenuItem "zoom_in"
traceZoomOutH <- builderGetObject gladeXML castToToolButton "zoomOutH"
traceZoomOutV <- builderGetObject gladeXML castToToolButton "zoomOutV"
traceZoomOut <- builderGetObject gladeXML castToMenuItem "zoom_out"
moveUp <- builderGetObject gladeXML castToToolButton "go_up"
moveDown <- builderGetObject gladeXML castToToolButton "go_down"
viewselect <- builderGetObject gladeXML castToComboBox "viewselect"
buttonToPng <- builderGetObject gladeXML castToToolButton "saveAsPng"
winm <- builderGetObject gladeXML castToMenu "windows_menuX"
menuClose <- builderGetObject gladeXML castToMenuItem "close"
menuQuit <- builderGetObject gladeXML castToMenuItem "tquit"
menuOpen <- builderGetObject gladeXML castToMenuItem "topen"
menuOpenWithoutMsgs <- builderGetObject gladeXML castToMenuItem "topenWithoutMsgs"
menuSave <- builderGetObject gladeXML castToMenuItem "save"
menuAllM <- builderGetObject gladeXML castToRadioMenuItem "showAllMachines"
menuAllP <- builderGetObject gladeXML castToRadioMenuItem "showAllProcesses"
menuAllGP <- builderGetObject gladeXML castToRadioMenuItem "showAllGProcesses"
menuAllT <- builderGetObject gladeXML castToRadioMenuItem "showAllThreads"
menuSort <- builderGetObject gladeXML castToMenuItem "sort"
menuShowRange <- builderGetObject gladeXML castToMenuItem "edit_range"
menuEditTicks <- builderGetObject gladeXML castToMenuItem "edit_ticks"
menuTotal <- builderGetObject gladeXML castToMenuItem "totalView"
menuMarker <- builderGetObject gladeXML castToCheckMenuItem "show_marker"
menuStartupMarker <- builderGetObject gladeXML castToCheckMenuItem "show_startup"
menuHideStartupPhase <- builderGetObject gladeXML castToCheckMenuItem "hide_startup_phase"
menuBlockMsgs <- builderGetObject gladeXML castToCheckMenuItem "show_blockmsgs"
menuDataMsgs <- builderGetObject gladeXML castToCheckMenuItem "show_data_messages"
menuSystemMsgs <- builderGetObject gladeXML castToCheckMenuItem "show_system_messages"
menuRefresh <- builderGetObject gladeXML castToMenuItem "refresh"
menuAbout <- builderGetObject gladeXML castToMenuItem "tabout"
-- add labels for tool-items so that a label is displayed in the toolbar overflow menu
addMenuLabelToToolItem gladeXML "toolitemViewSelect" "Select View"
addMenuLabelToToolItem gladeXML "toolitemSort" "Sort"
addMenuLabelToToolItem gladeXML "toolitemZoomH" "Zoom Horizontal"
addMenuLabelToToolItem gladeXML "toolitemZoomV" "Zoom Vertical"
-- the statusbar:
statusbar <- builderGetObject gladeXML castToStatusbar "traceStatusBar"
let statusString = " Runtime: " ++ strRunT ++ "s, " ++
show nm ++ " Machines, " ++
show allP ++ " Processes, " ++
show nt ++ " Threads, " ++
show (length msgs + (length hmsgs)) ++ " Conversations, " ++
show allMsgs ++ " Messages"
botID <- statusbarGetContextId statusbar statusString
statusbarPush statusbar botID statusString
-- initial settings
comboBoxSetActive viewselect 0 -- default to view machines
let listOfMachineIds = map getIdM (machinelist traces)
listOfProcessIds = map getIdP (processlist traces)
st <- newMVar (initMatrix nm np nt listOfMachineIds listOfProcessIds filename ignoreMessages)
-- filename in titlebar
let winTitle = "Trace " ++ (takeFileName filename)
windowSetTitle window winTitle
-- create entry for windows-menu in main window (and now all other open windows too)
ws <- takeMVar winMenus
-- update all menus which are found in ws to display new tracefile item
sequence_ $ map (\winList -> do
newListItem <- menuItemNewWithLabel winTitle
submenu <- menuNew
showItem <- menuItemNewWithLabel "Show"
refreshItem <- menuItemNewWithLabel "Refresh"
menuShellAppend winList newListItem
menuShellAppend submenu showItem
menuShellAppend submenu refreshItem
menuItemSetSubmenu newListItem submenu
widgetShow newListItem
onActivateLeaf showItem (windowPresent window)
onActivateLeaf refreshItem (widgetQueueDraw pic)
widgetShowAll newListItem
onDestroy window (widgetDestroy newListItem)
onDestroy window (do
oldWS <- takeMVar winMenus
let oldM = windowsMenus oldWS
--putStrLn "removing old menu from update list"
--putStrLn (show $ length oldM)
let removeSelf (x:xs)
| x == winm = xs
| otherwise = x : (removeSelf xs)
removeSelf [] = []
newM = removeSelf oldM
--putStrLn (show $ length newM)
putMVar winMenus (oldWS{windowsMenus=newM})
)) (windowsMenus ws)
-- get list of windows and build a windows menu from ground up
-- for this window
activeWins <- windowListToplevels
sequence_ $ map (\window -> do
title <- (windowGetTitle window)
if isPrefixOf "Trace" title -- only show if window is a tracefile window
then do
newListItem <- menuItemNewWithLabel title
submenu <- menuNew
showItem <- menuItemNewWithLabel "Show"
refreshItem <- menuItemNewWithLabel "Refresh"
menuShellAppend winm newListItem
menuShellAppend submenu showItem
menuShellAppend submenu refreshItem
menuItemSetSubmenu newListItem submenu
widgetShow newListItem
onActivateLeaf showItem (windowPresent window)
onActivateLeaf refreshItem (widgetQueueDraw pic)
widgetShowAll newListItem
onDestroy window (widgetDestroy newListItem)
return ()
else return ()) activeWins
-- register this windows menu for future updates
putMVar winMenus (ws{windowsMenus=(winm:(windowsMenus ws))})
-- option buttons:
-- zoom in/out, horizontal/vertical
-- when zooming out also refresh the drawing area to get rid of the old drawings
onToolButtonClicked traceZoomInH (zoom pic (*2) (id) viewport)
onToolButtonClicked traceZoomInV (zoom pic (id) (*2) viewport)
onToolButtonClicked traceZoomOutH (do zoom pic (`div` 2) (id) viewport; widgetQueueDraw pic)
onToolButtonClicked traceZoomOutV (do zoom pic (id) (`div` 2) viewport; widgetQueueDraw pic)
onActivateLeaf traceZoomIn (zoom pic (*2) (*2) viewport)
onActivateLeaf traceZoomOut (do zoom pic (`div` 2) (`div` 2) viewport; widgetQueueDraw pic)
-- mouse zoom event
onScroll pic (\ event -> do
let scrollDirection = eventDirection event
when (scrollDirection == ScrollUp || scrollDirection == ScrollDown) $ do
-- mouse position on the drawing area
let mousePosX = eventX event
let mousePosY = eventY event
let zoomFactor
| scrollDirection == ScrollUp = (*2)
| otherwise = (`div` 2)
zoomAt mousePosX mousePosY pic zoomFactor viewport
widgetQueueDraw pic
return (True))
-- toggle local/global zero => refresh picture
onToolButtonToggled buttonLocalNull (widgetQueueDraw pic)
-- close the "parsing file"-dialog
dialogResponse dialog ResponseOk
-- events from the menu
-- close window, not program
onActivateLeaf menuClose (widgetDestroy window)
-- close window AND program
onActivateLeaf menuQuit (do
widgetActivate exitApp
return ())
-- open new tracefile, use controls of main window
onActivateLeaf menuOpen (do
widgetActivate mainOpen
return ())
-- open new tracefile without msgs, use controls of main window
onActivateLeaf menuOpenWithoutMsgs (do
widgetActivate mainOpenWithoutMsgs
return ())
-- redraw
onActivateLeaf menuBlockMsgs (widgetQueueDraw pic)
onActivateLeaf menuDataMsgs (widgetQueueDraw pic)
onActivateLeaf menuSystemMsgs (widgetQueueDraw pic)
onActivateLeaf menuHideStartupPhase (widgetQueueDraw pic)
-- save image to file (menu entry)
onActivateLeaf menuSave (do
windowPresent window
v <- comboBoxGetActive viewselect
drawStartupMarker <- checkMenuItemGetActive menuStartupMarker
hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase
drawBlockMsgs <- checkMenuItemGetActive menuBlockMsgs
drawDataMsgs <- checkMenuItemGetActive menuDataMsgs
drawSystemMsgs <- checkMenuItemGetActive menuSystemMsgs
saveToFile drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs traces (nt,np,nm) v st edentvState pic)
-- sort current view
onActivateLeaf menuSort ( do
state <- takeMVar st
-- which view has to be sorted?
v <- comboBoxGetActive viewselect
case v of -- set the right list to default:
3 -> putMVar st (state { matrixGP = [1..(fromIntegral nm)] })
2 -> putMVar st (state { matrixT = [1..(fromIntegral nt)] })
1 -> putMVar st (state { matrixP = [1..(fromIntegral np)] })
0 -> putMVar st (state { matrixM = [1..(fromIntegral nm)] })
widgetQueueDraw pic) -- refresh picture
onActivateLeaf menuShowRange (
do -- show specific range
gladeXML <- edentvGladeFile ["range_win", "accelgroup1"]
rangeDlg <- builderGetObject gladeXML castToWindow "range_win"
spinBegin <- builderGetObject gladeXML castToSpinButton "range_begin"
spinEnd <- builderGetObject gladeXML castToSpinButton "range_end"
buttonShow <- builderGetObject gladeXML castToButton "show_intervall"
viewRange <- viewportGetHAdjustment viewport
viewLower <- adjustmentGetLower viewRange
viewUpper <- adjustmentGetUpper viewRange
viewInit <- adjustmentGetValue viewRange
viewStep <- adjustmentGetStepIncrement viewRange
--putStrLn ("posX init: " ++ (show viewInit))
state <- readMVar st
let useDiff = locTime state
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase
let minT'
| hideStartupPhase = maxStartup traces
| otherwise = minT
let getTimeFromPosition x
| useDiff = posToTime minT' (maxT+maxST) ulx lrx x
| otherwise = posToTime minT' maxT ulx lrx x
let timeBeginInit = getTimeFromPosition (viewInit+ulx)
timeBeginLower
| hideStartupPhase = 0
| otherwise = minT'
timeBeginUpper
| hideStartupPhase = maxT - minT'
| otherwise = maxT
timeEndInit = getTimeFromPosition (viewInit+(fromIntegral vw))
timeEndLower = timeBeginLower
timeEndUpper = timeBeginUpper
timeStep = getTimeFromPosition viewStep
beginAdjustment <- adjustmentNew timeBeginInit timeBeginLower timeBeginUpper timeStep 0 0
endAdjustment <- adjustmentNew timeEndInit timeEndLower timeEndUpper timeStep 0 0
spinButtonConfigure spinBegin beginAdjustment timeStep 5
spinButtonConfigure spinEnd endAdjustment timeStep 5
onClicked buttonShow (do
--putStrLn "Ok?"
timeX <- spinButtonGetValue spinBegin
timeX2 <- spinButtonGetValue spinEnd
--let scale_total = (maxT-minT)
let scale = (((fromIntegral vw) - ulx) / (timeX2 - timeX)) * (maxT - minT')
(w,h) <- widgetGetSize pic
widgetSetSizeRequest pic (minimum [round scale, 32000]) (h)
let newlrx = (realToFrac (round scale)) - 20
let getPositionFromTime x
| useDiff = timeToPos minT' (maxT+maxST) ulx newlrx x
| otherwise = timeToPos minT' maxT ulx newlrx x
let posX = (getPositionFromTime timeX) - ulx
-- At the moment the drawing area might no have changed
-- its size yet. So if we try to set the adjustment value now,
-- the adjustment might not be changed because the new value is not
-- between lowerValue and upperValue.
-- So instead we set an event, which is called when the drawing area
-- has changed its size, so that we can safely scroll to the right
-- position.
viewAdj <- viewportGetHAdjustment viewport
mfix $ \ handlerId -> afterAdjChanged viewAdj (do
adjustmentSetValue viewAdj posX
-- remove the event again
signalDisconnect handlerId)
return ()
)
windowSetTitle rangeDlg "Show Range"
windowSetTransientFor rangeDlg window
widgetShowAll rangeDlg
)
onActivateLeaf menuEditTicks (
do -- show ticks setup
gladeXML <- edentvGladeFile ["ticks_win", "accelgroup1"]
ticksDlg <- builderGetObject gladeXML castToWindow "ticks_win"
ticksSkip <- builderGetObject gladeXML castToSpinButton "ticks_skip"
ticksMark <- builderGetObject gladeXML castToSpinButton "ticks_mark"
buttonSet <- builderGetObject gladeXML castToButton "set_ticks"
buttonAuto <- builderGetObject gladeXML castToCheckButton "auto_ticks"
state <- readMVar st
let useDiff = locTime state
auto = autoTicks state
tSkip = tickSkip state
tMark = tickMark state
maxSkip
| useDiff = maxT + maxST
| otherwise = maxT
skipAdjustment <- adjustmentNew tSkip 0.00001 maxSkip 0.1 0 0
markAdjustment <- adjustmentNew (fromIntegral tMark) 1 32000 1 0 0
toggleButtonSetActive buttonAuto auto
spinButtonConfigure ticksSkip skipAdjustment 0.1 5
spinButtonConfigure ticksMark markAdjustment 1 0
onClicked buttonSet (do
--putStrLn "Ok?"
valSkip <- spinButtonGetValue ticksSkip
valMark <- spinButtonGetValue ticksMark
valAuto <- toggleButtonGetActive buttonAuto
state <- takeMVar st
putMVar st (state { autoTicks=valAuto, tickSkip=valSkip, tickMark=floor valMark })
widgetQueueDraw pic
)
windowSetTitle ticksDlg "Edit Ticks"
windowSetTransientFor ticksDlg window
widgetShowAll ticksDlg
)
onActivateLeaf menuTotal (do -- zoom picture to the size of this window
visibleRegion <- drawableGetVisibleRegion win
Rectangle _ _ w h <- regionGetClipbox visibleRegion -- get dimensions
widgetSetSizeRequest pic (minimum [w, 32000]) (minimum [h, 32000]))
onActivateLeaf menuRefresh (widgetQueueDraw pic) -- refresh picture (remove artefacts)
onActivateLeaf menuAbout showAboutDlg -- show program information
onActivateLeaf menuStartupMarker (widgetQueueDraw pic)
-- Actions/Events from Toolbar
onExpose pic (\_ -> do
v <- comboBoxGetActive viewselect
drawStartupMarker <- checkMenuItemGetActive menuStartupMarker
hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase
drawBlockMsgs <- checkMenuItemGetActive menuBlockMsgs
drawDataMsgs <- checkMenuItemGetActive menuDataMsgs
drawSystemMsgs <- checkMenuItemGetActive menuSystemMsgs
case v of
3 -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawGroupProcesses) pic traces st edentvState nm
2 -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawThreads) pic traces st edentvState nt
1 -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawProcesses) pic traces st edentvState np
_ -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawMachines) pic traces st edentvState nm
return False)
-- when the viewport slides over the image, the axes have to be redrawn:
hAdj <- viewportGetHAdjustment viewport
onValueChanged hAdj ( do
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
drawWindowInvalidateRect win
(Rectangle vx vy 100 vh) True)
vAdj <- viewportGetVAdjustment viewport
onValueChanged vAdj ( do
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
let bot = 100
drawWindowInvalidateRect win
(Rectangle vx (vy+vh-bot) vw bot) True)
onToolButtonClicked buttonToPng (do -- save image to file (toolbutton)
widgetActivate menuSave
return ())
onActivateLeaf menuAllM ( do -- switch to machine view
v <- comboBoxGetActive viewselect
setTo <- checkMenuItemGetActive menuAllM
if setTo && v /= 0
then comboBoxSetActive viewselect 0
else return ()
)
onActivateLeaf menuAllP ( do -- switch to process view
v <- comboBoxGetActive viewselect
setTo <- checkMenuItemGetActive menuAllP
if setTo && v /= 1
then comboBoxSetActive viewselect 1
else return ()
)
onActivateLeaf menuAllGP ( do -- switch to process view
v <- comboBoxGetActive viewselect
setTo <- checkMenuItemGetActive menuAllGP
if setTo && v /= 3
then comboBoxSetActive viewselect 3
else return ()
)
onActivateLeaf menuAllT ( do -- switch to thread view
v <- comboBoxGetActive viewselect
setTo <- checkMenuItemGetActive menuAllT
if setTo && v /= 2
then comboBoxSetActive viewselect 2
else return ()
)
on viewselect changed (do
state <- takeMVar st
v <- comboBoxGetActive viewselect -- get the view to switch to
-- update the menu items:
case v of
3 -> checkMenuItemSetActive menuAllGP True
2 -> checkMenuItemSetActive menuAllT True
1 -> checkMenuItemSetActive menuAllP True
0 -> checkMenuItemSetActive menuAllM True
-- save the view settings and refresh image:
putMVar st (state { selRow = [], selView = v })
widgetQueueDraw pic)
onMotionNotify pic False (\e -> do -- the mouse has moved above the image:
active <- checkMenuItemGetActive menuMarker
let mx = eventX e
my = eventY e
if active -- then marker has to be redrawn
then do
hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase
handleMouseMove st edentvState hideStartupPhase pic traces mx my
else return ()
state <- readMVar st
if (clicked state) then handleDragnDrop st pic traces mx my else return ()
return False)
onButtonPress pic (\e -> do -- a mousebutton was pressed
state <- takeMVar st
win <- widgetGetDrawWindow pic
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
let mx = eventX e
my = eventY e
activeClick = (mx > ulx && my > uly && mx < lrx && my < lry)
pixbuf <- pixbufGetFromDrawable win (Rectangle 0 0 50 vh)
putMVar st (state { clicked = activeClick, oldView = pixbuf })
v <- comboBoxGetActive viewselect
handleButtonPress pic v st e traces)
onButtonRelease pic (\e -> do -- a mousebutton was released
state <- takeMVar st
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
let mx = eventX e
my = eventY e
didClick = clicked state
putMVar st (state { clicked = False })
v <- comboBoxGetActive viewselect
if (mx > ulx && my > uly && mx < lrx && my < lry) && (didClick)
then performDragnDrop v st pic traces mx my
else return ()
widgetQueueDraw pic
return False
)
onToolButtonClicked buttonInfo ( do -- show traceinformation
gladeXML <- edentvGladeFile ["info_win", "accelgroup1"]
infoDlg <- builderGetObject gladeXML castToWindow "info_win"
windowSetTitle infoDlg ("Info - " ++ filename)
windowSetTransientFor infoDlg window
showTraceInfo traces filename (statusString {- ++ "\n("
++ show allMsgs ++ " Messages overall; "
++ show allP ++ " Processes overall)"-}) gladeXML
widgetShowAll infoDlg)
onToolButtonClicked buttonConfMsgs ( do -- show configure Messages Window
gladeXML <- edentvGladeFile ["confmsgs_win", "accelgroup1"]
confDlg <- builderGetObject gladeXML castToWindow "confmsgs_win"
v <- comboBoxGetActive viewselect
buildConfMsg st gladeXML pic v
windowSetTitle confDlg "Configure Messages"
windowSetTransientFor confDlg window
widgetShowAll confDlg
)
onToolButtonClicked buttonLocalNull (do -- toggle local/global zero
state <- takeMVar st
localNull <- toggleToolButtonGetActive buttonLocalNull
putMVar st (state { selRow = [], locTime = localNull })
widgetQueueDraw pic)
onToolButtonClicked buttonMessages (do -- show/hide Messages
messagesOn <- toggleToolButtonGetActive buttonMessages
state <- takeMVar st
if (EdenTvType.ignoreMessages state)
then do
-- the trace file was read without parsing messages,
-- so the file has to be read again
putMVar st state
if messagesOn
then do
-- ask the user if the file should be re-parsed
reparseDialog <- messageDialogNew
(Just window)
[DialogModal]
MessageQuestion
ButtonsOkCancel
("The current trace file has been opened without parsing the messages. " ++
"Should the file be read again and should the messages be displayed?")
response <- dialogRun reparseDialog
widgetDestroy reparseDialog
case response of
ResponseOk ->
-- load file and also show messages
tryToOpen (EdenTvType.filename state) widgets False True edentvState
_ -> return()
else return ()
-- also disable the button again, because no messages are displayed
-- in this window
toggleToolButtonSetActive buttonMessages False
else do
-- messages were parsed while reading the trace file,
-- so just show them
putMVar st (state { selRow = [], showMsg = messagesOn })
widgetQueueDraw pic)
-- change theposition of selected line
onToolButtonClicked moveUp ( do
v <- comboBoxGetActive viewselect
handleMoveUp pic v st)
onToolButtonClicked moveDown (do
v <- comboBoxGetActive viewselect
handleMoveDown pic v st)
-- Show Trace-Window
widgetShowAll window
widgetQueueDraw pic
-- traces drawn => all information consumed => file can be closed
--hClose fileHdl
-- show messages on first display?
if showMessages
then toggleToolButtonSetActive buttonMessages True
else return()
where
-- Zoom in/out horizontally by keeping the current position
--
zoomAt :: Double -> Double -> DrawingArea -> (Int -> Int) -> Viewport -> IO ()
zoomAt mousePosX mousePosYFlipped pic zoomFactor viewport = do
(w,h) <- widgetGetSize pic
adjustmentH <- viewportGetHAdjustment viewport
adjustmentV <- viewportGetVAdjustment viewport
-- point (0, 0) on the drawing area is in the lower left, but the
-- coordinate system of the mouse position starts in upper left
heightViewPort <- adjustmentGetPageSize adjustmentV
let mousePosY = heightViewPort - mousePosYFlipped
-- get the current position
(relativePosXViewPort, relativePosXTotal)
<- getRelativePositonAt mousePosX adjustmentH
(relativePosYViewPort, relativePosYTotal)
<- getRelativePositonAt mousePosY adjustmentV
-- restore the position once the new size is set
restorePosition (setPositionAt adjustmentH relativePosXViewPort relativePosXTotal)
(setPositionAt adjustmentV relativePosYViewPort relativePosYTotal)
adjustmentH
adjustmentV
widgetSetSizeRequest pic (minimum [zoomFactor w, 32000]) h
where
-- chart borders in pixels
pageBorderLeft = 55
pageBorderRight = 20
pageBorder = pageBorderLeft + pageBorderRight
-- Returns the relative position of the mouse pointer
-- - relative to the viewable extent
-- - relative to whole size (including the scrollable part)
--
getRelativePositonAt :: Double -> Adjustment -> IO (Double, Double)
getRelativePositonAt position adj = do
min <- adjustmentGetLower adj
max <- adjustmentGetUpper adj
val <- adjustmentGetValue adj
viewableSize <- adjustmentGetPageSize adj
let totalSize = max - min
return ((position - val - pageBorderLeft) / (viewableSize - pageBorder),
(position - min - pageBorderLeft) / (totalSize - pageBorder))
setPositionAt :: Adjustment -> Double -> Double -> IO ()
setPositionAt adj relativePosViewPort relativePosTotal = do
min <- adjustmentGetLower adj
max <- adjustmentGetUpper adj
viewableSize <- adjustmentGetPageSize adj
let totalSize = max - min
let zoomPoint = (totalSize - pageBorder) * relativePosTotal
let position = zoomPoint - ((viewableSize - pageBorder) * relativePosViewPort)
let newValue
| position < min = min
| position + viewableSize > max = max - viewableSize
| otherwise = position
adjustmentSetValue adj newValue
zoom :: DrawingArea -> (Int -> Int) -> (Int -> Int) -> Viewport -> IO ()
zoom pic fX fY viewport = do
(w,h) <- widgetGetSize pic
-- get the current position
adjustmentH <- viewportGetHAdjustment viewport
adjustmentV <- viewportGetVAdjustment viewport
relativePosX <- getRelativePositon adjustmentH
relativePosY <- getRelativePositon adjustmentV
-- restore the position once the new size is set
restorePosition (setPosition adjustmentH relativePosX)
(setPosition adjustmentV relativePosY)
adjustmentH
adjustmentV
-- the resolution is restricted to 32K*32K,
-- this is because DrawingArea immediately would allocate a backing store
-- of 32k * 32k * (3 Bytes/pixel) memory and because x values are
-- limited to short integer (-32768/+32767)
widgetSetSizeRequest pic (minimum [fX w, 32000]) (minimum [fY h, 32000])
where
-- Returns the relative position of the center point.
--
getRelativePositon :: Adjustment -> IO (Double)
getRelativePositon adj = do
min <- adjustmentGetLower adj
max <- adjustmentGetUpper adj
val <- adjustmentGetValue adj
pageSize <- adjustmentGetPageSize adj
let center = val + (pageSize / 2)
return ((center - min) / (max - min))
setPosition :: Adjustment -> Double -> IO ()
setPosition adj relativePos = do
min <- adjustmentGetLower adj
max <- adjustmentGetUpper adj
pageSize <- adjustmentGetPageSize adj
let center = min + (max - min) * relativePos
let newValue
| (center + (pageSize / 2)) >= max = max - pageSize
| otherwise = (center - (pageSize / 2))
adjustmentSetValue adj newValue
restorePosition :: (IO ()) -> (IO ()) -> Adjustment -> Adjustment -> IO ()
restorePosition setPositionH setPositionV adjustmentH adjustmentV = do
mfix $ \ handlerId -> afterAdjChanged adjustmentH (do
setPositionH
signalDisconnect handlerId)
mfix $ \ handlerId -> afterAdjChanged adjustmentV (do
setPositionV
signalDisconnect handlerId)
return ()
-- export to Picture:
-- Attention: parts of the window, that are off-screen, are not being exported!
--saveToFile :: DrawColor -> Events -> (Int,Int,Int) -> Int -> ViewerState -> DrawingArea -> IO ()
saveToFile drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs traces (nt,np,nm) v st edentvState pic = do
-- redraw window (refresh the image)
widgetQueueDraw pic
-- extract Image from Window:
win <- widgetGetDrawWindow pic
visibleRegion <- drawableGetVisibleRegion win
visible <- regionGetClipbox visibleRegion
let Rectangle visX visY visW visH = visible
mPixbuf <- pixbufGetFromDrawable win visible
-- ask for filename:
selectFilename <- fileChooserDialogNew (Just "Save Picture") Nothing
FileChooserActionSave [("_Save",ResponseOk),("Cancel",ResponseCancel)]
dialogSetDefaultResponse selectFilename ResponseOk
-- add filters for special filetypes:
filterAll <- fileFilterNew
filterAll `fileFilterAddPattern` "*.*"
filterAll `fileFilterSetName` "all Files"
filterImg <- fileFilterNew -- to select the filetype
fileFilterAddPixbufFormats filterImg -- add imagetypes
filterImg `fileFilterAddPattern` "*.pdf"
filterImg `fileFilterSetName` "all known images"
selectFilename `fileChooserAddFilter` filterAll -- add filters to dialog
selectFilename `fileChooserAddFilter` filterImg
filterPDF <- fileFilterNew
filterPDF `fileFilterAddPattern` ("*.pdf")
filterPDF `fileFilterSetName` "Portable Document Format (*.pdf)"
selectFilename `fileChooserAddFilter` filterPDF
addSpecialFilters selectFilename pixbufGetFormats
-- show and run the dialog:
widgetShow selectFilename
response <- dialogRun selectFilename
case response of
ResponseCancel -> widgetDestroy selectFilename -- don't save the image
ResponseOk -> do
Just filename <- fileChooserGetFilename selectFilename
let filetype = reverse (takeWhile (/= '.') (reverse filename)) -- extract the choosen filetype
if (elem filetype ["bmp","jpg","jpeg","png", "pdf"]) -- filetype recognized?
then do
widgetDestroy selectFilename
pathExists <- doesDirectoryExist filename
fileExists <- doesFileExist filename
doWrite <- if pathExists
then do errorMessage (filename ++ " is a Directory.")
return False
else if fileExists
then yesNoMessage (filename ++ " exists, overwrite?")
else return True
if doWrite
then case mPixbuf of
Nothing -> error "saveToFile: Window not visible"
Just p -> do
if (elem filetype ["bmp","jpg","jpeg","png"])
then pixbufSave p filename (pack $ if filetype == "jpg" then "jpeg" else filetype) ([] :: [(String, String)])
else do
case v of
3 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawGroupProcesses) pic traces st edentvState nt )
2 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawThreads) pic traces st edentvState nt )
1 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawProcesses) pic traces st edentvState nt )
_ -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawMachines) pic traces st edentvState nt )
else return ()
else do -- unknown filetype
widgetDestroy selectFilename
gladeXML <- edentvGladeFile ["dlg_err_save_filetype", "accelgroup1"]
dlg <- builderGetObject gladeXML castToDialog "dlg_err_save_filetype"
dlg `afterResponse` (\_ -> widgetDestroy dlg)
widgetShowAll dlg
-- allowed filetypes: png bmp wbmp gif ico ani jpeg pnm ras tiff xpm xbm tga
-- supported: png, bmp, jpeg
_ -> widgetDestroy selectFilename
return ()
where
addSpecialFilters :: (FileChooserClass a) => a -> [ImageFormat] -> IO ()
addSpecialFilters _ [] = return ()
addSpecialFilters dlg (f:fs) = do
filter <- fileFilterNew
filter `fileFilterAddPattern` ("*." ++ (unpack f))
case unpack f of
"pdf" -> do
filter `fileFilterSetName` "Portable Document Format(*.pdf)"
dlg `fileChooserAddFilter` filter
"png" -> do
filter `fileFilterSetName` "Portable Networks Graphics (*.png)"
dlg `fileChooserAddFilter` filter
"bmp" -> do
filter `fileFilterSetName` "Windows Bitmap (*.bmp)"
dlg `fileChooserAddFilter` filter
"jpeg" -> do
filter `fileFilterAddPattern` ("*.jpg")
filter `fileFilterSetName` "Joint Photographic Experts Group (*.jpeg)"
dlg `fileChooserAddFilter` filter
_ -> return ()
addSpecialFilters dlg fs
-- start GUI
main :: IO ()
main = do
putStrLn ("This is EdenTV v" ++ version ++ ". Happy tracing!")
initGUI -- for GTK+
-- load Glade-description
gladeXML <- edentvGladeFile ["EdTVMain", "accelgroup1"]
-- load Widgets from Glade-description
-- main window
windowMain <- builderGetObject gladeXML castToWindow "EdTVMain"
-- colorbuttons
iCB <- builderGetObject gladeXML castToColorButton "idle_colorbutton"
rCB <- builderGetObject gladeXML castToColorButton "running_colorbutton"
sCB <- builderGetObject gladeXML castToColorButton "suspended_colorbutton"
bCB <- builderGetObject gladeXML castToColorButton "blocked_colorbutton"
-- other toolbar entries
toolbarOpen <- builderGetObject gladeXML castToToolButton "toolbar_Open"
-- menu entries
menuFileOpen <- builderGetObject gladeXML castToMenuItem "menuFile_Open"
menuFileOpenWithoutMsgs <- builderGetObject gladeXML castToMenuItem "menuFile_OpenWithoutMsgs"
menuFileExit <- builderGetObject gladeXML castToMenuItem "menuFile_Quit"
cCol <- builderGetObject gladeXML castToRadioMenuItem "default_colors"
cBW <- builderGetObject gladeXML castToRadioMenuItem "default_colBW"
menuOptsSetColors <- builderGetObject gladeXML castToMenuItem "menuOptions_SetColors"
menuWindows <- builderGetObject gladeXML castToMenu "windows_menu"
refreshWins <- builderGetObject gladeXML castToMenuItem "refresh_all"
menuHelpAbout <- builderGetObject gladeXML castToMenuItem "menuHelp_About"
-- menuSetTitle menuWindows "active Documents"
-- initial state with default colors
edentvState <- newMVar (ES { lastPath = "", colors = getDefaultColors })
-- Eventhandling:
onDelete windowMain deleteEvent
onDestroy windowMain destroyEvent
onActivateLeaf menuFileExit quitEvent
onToolButtonClicked toolbarOpen (do {widgetActivate menuFileOpen; return ()}) -- open tracefile
winMenus <- newMVar WS {windowsMenus=[menuWindows]}
-- open tracefile
onActivateLeaf menuFileOpen
(openEvent windowMain (menuWindows,menuFileOpen,menuFileOpenWithoutMsgs,menuFileExit, winMenus) edentvState False)
-- open tracefile without parsing messages
onActivateLeaf menuFileOpenWithoutMsgs
(openEvent windowMain (menuWindows,menuFileOpen,menuFileOpenWithoutMsgs,menuFileExit, winMenus) edentvState True)
-- handling colors
let updateMainColorButtons colorMap = do
updateColorButton iCB (statusIdle colorMap)
updateColorButton rCB (statusRunning colorMap)
updateColorButton sCB (statusSuspended colorMap)
updateColorButton bCB (statusBlocked colorMap)
let setTemplateMenuInconsistent = do
checkMenuItemSetInconsistent cCol True
checkMenuItemSetInconsistent cBW True
onActivateLeaf menuOptsSetColors (showSetColorDialog edentvState menuWindows updateMainColorButtons
setTemplateMenuInconsistent)
onActivateLeaf cCol ( do
setDefaultColors cCol edentvState menuWindows updateMainColorButtons
checkMenuItemSetInconsistent cBW False)
onActivateLeaf cBW ( do
setDefaultBW cBW edentvState menuWindows updateMainColorButtons
checkMenuItemSetInconsistent cCol False)
onColorSet iCB (colorChanged iCB edentvState
(\ color colors -> colors {statusIdle = color}) menuWindows setTemplateMenuInconsistent)
onColorSet rCB (colorChanged rCB edentvState
(\ color colors -> colors {statusRunning = color}) menuWindows setTemplateMenuInconsistent)
onColorSet sCB (colorChanged sCB edentvState
(\ color colors -> colors {statusSuspended = color}) menuWindows setTemplateMenuInconsistent)
onColorSet bCB (colorChanged bCB edentvState
(\ color colors -> colors {statusBlocked = color}) menuWindows setTemplateMenuInconsistent)
-- a list of all opened windows
onActivateLeaf refreshWins (refreshAll menuWindows)
onActivateLeaf menuHelpAbout showAboutDlg -- not supported on CentOS!!!
-- set default colors on start-up
setDefaultColors cCol edentvState menuWindows updateMainColorButtons
checkMenuItemSetActive cCol True
-- load tracefile if filename is in commandline
args <- getArgs
if (null args)
then return ()
else case (head args) of
"--version" -> exitWith ExitSuccess
"--help" -> do
putStrLn " EdenTV just open main dialog of EdenTV"
putStrLn " EdenTV <filename> run EdenTV and open <filename>"
putStrLn " EdenTV --version print version and exit"
putStrLn " EdenTV --help print this help and exit"
exitWith ExitSuccess
hArgs -> do
cPath <- canonicalizePath hArgs
let path = (reverse (tail (dropWhile (\c -> notElem c ['\\','/']) (reverse cPath))))
swapMVar edentvState (ES { lastPath = path, colors = getDefaultColors })
tryToOpen hArgs (menuWindows, menuFileOpen, menuFileOpenWithoutMsgs, menuFileExit, winMenus) False False edentvState
-- for GTK+
widgetShowAll windowMain
mainGUI
where
-- Called when one of the 4 colors in the main windows was changed
--
colorChanged colorButton edentvState setter openTraceWindows setTemplateMenuInconsistent = do
globalState <- readMVar edentvState
let colorMap = colors globalState
newColor <- getColorFromColorButton colorButton
-- store new color in the state
let colorMap' = setter newColor colorMap
swapMVar edentvState (globalState {colors = colorMap' })
setTemplateMenuInconsistent
refreshAll openTraceWindows
setDefaultColors, setDefaultBW :: RadioMenuItem -> MVar EdenTvState -> Menu -> (Colors -> IO ()) -> IO ()
setDefaultColors cCol edentvState openTraceWindows updateMainColorButtons = do
isActive <- get cCol checkMenuItemActive
when isActive $ do
setNewColors edentvState (getDefaultColors) openTraceWindows updateMainColorButtons
checkMenuItemSetInconsistent cCol False
setDefaultBW cBW edentvState openTraceWindows updateMainColorButtons = do
isActive <- get cBW checkMenuItemActive
when isActive $ do
setNewColors edentvState (getDefaultColorsBW) openTraceWindows updateMainColorButtons
checkMenuItemSetInconsistent cBW False
-- This function takes care of displaying the dialog to customize all
-- colors (not just the four shown in the main window). If the dialog is
-- closed with `Ok`, the new colors are stored in the state and all open
-- trace windows are refreshed.
--
showSetColorDialog :: MVar EdenTvState -> Menu -> (Colors -> IO ()) -> (IO ()) -> IO ()
showSetColorDialog edentvState openTraceWindows updateMainColorButtons setTemplateMenuInconsistent = do
gladeXML <- edentvGladeFile ["dialogColors","accelgroup1"]
colorsDialog <- builderGetObject gladeXML castToDialog "dialogColors"
globalState <- readMVar edentvState
updateDialogFromState gladeXML (colors globalState)
dialogResponse <- dialogRun colorsDialog
case dialogResponse of
ResponseAccept -> do
colors' <- updateStateFromDialog gladeXML (colors globalState)
setNewColors edentvState colors' openTraceWindows updateMainColorButtons
setTemplateMenuInconsistent
_ -> return ()
widgetDestroy colorsDialog
return ()
where
updateDialogFromState :: Builder -> Colors -> IO ()
updateDialogFromState gladeXML colors = do
mapM_ (updateColorButtonById gladeXML colors) colorMapping
-- Sets the color of a color button using the current value in
-- the state.
--
updateColorButtonById :: Builder -> Colors -> ColorMapping -> IO ()
updateColorButtonById gladeXML colors (id, getter, _) = do
let color = getter colors
colorButton <- builderGetObject gladeXML castToColorButton id
updateColorButton colorButton color
-- Retrieves the changed colors from the dialog and stores them in
-- the state.
--
updateStateFromDialog :: Builder -> Colors -> IO (Colors)
updateStateFromDialog gladeXML colors = do
newColors <- mapM getColor colorMapping
let colors' = foldr applyColor colors $ zip colorMapping newColors
return (colors')
where
applyColor :: (ColorMapping, ColorRGBA) -> Colors -> Colors
applyColor ((_, _, setter), newColor) colors = setter newColor colors
getColor :: ColorMapping -> IO (ColorRGBA)
getColor (id, _, _) = getColorFromColorButtonById gladeXML id
getColorFromColorButtonById :: Builder -> String -> IO (ColorRGBA)
getColorFromColorButtonById gladeXML id = do
colorButton <- builderGetObject gladeXML castToColorButton id
getColorFromColorButton colorButton
-- Stores new colors in the state, updates the main windows color buttons and
-- refreshes all open trace windows.
--
setNewColors :: MVar EdenTvState -> Colors -> Menu -> (Colors -> IO ()) -> IO ()
setNewColors edentvState newColors openTraceWindows updateMainColorButtons = do
globalState <- takeMVar edentvState
putMVar edentvState (globalState {colors = newColors})
updateMainColorButtons newColors
refreshAll openTraceWindows
updateColorButton :: ColorButton -> ColorRGBA -> IO ()
updateColorButton colorButton color = do
colorButtonSetColor colorButton (rgbColor color)
colorButtonSetAlpha colorButton (alpha color)
getColorFromColorButton :: ColorButton -> IO (ColorRGBA)
getColorFromColorButton colorButton = do
rgbColor <- colorButtonGetColor colorButton
alpha <- colorButtonGetAlpha colorButton
return (RGBA {rgbColor = rgbColor, alpha = alpha})
addMenuLabelToToolItem :: Builder -> String -> String -> IO ()
addMenuLabelToToolItem gladeXML toolItemId labelCaption
= do toolItem <- builderGetObject gladeXML castToToolItem toolItemId
label <- imageMenuItemNewWithLabel labelCaption
let labelId = toolItemId ++ "Label"
toolItemSetProxyMenuItem toolItem labelId label
refreshAll :: Menu -> IO ()
refreshAll menu = do
(_:winList) <- containerGetChildren menu
refresh winList
where refresh [] = return ()
refresh (l:ls) = do
Just submenu <- menuItemGetSubmenu (castToMenuItem l)
(_:r:_) <- containerGetChildren (castToMenu submenu)
widgetActivate r
refresh ls
showAboutDlg = do
dlg <- aboutDialogNew
dlg `aboutDialogSetName` "EdenTV"
dlg `aboutDialogSetVersion` version
dlg `aboutDialogSetComments` "Trace Viewer for Eden Trace Files"
dlg `aboutDialogSetLicense` (Just gpl3)
dlg `aboutDialogSetWebsite` "http://www.mathematik.uni-marburg.de/~eden"
dlg `aboutDialogSetWebsiteLabel` "Take me to Eden"
dlg `aboutDialogSetAuthors` ["Bjoern Struckmeier, Bernhard Pickenbrock, ",
"Tobias Sauerwein, Mischa Dieterle, ",
"Thomas Horstmeyer, Jost Berthold",
"","Betreuung:","Prof. Dr. Rita Loogen"]
dlg `afterResponse` (\_ -> widgetDestroy dlg)
widgetShowAll dlg
gpl3 = unlines
["The Eden Trace Viewer (or simply EdenTV) is a tool that can generate"
,"diagrams to visualize the behaviour of Eden programs."
,"Copyright (C) 2005-2014 Philipps Universitaet Marburg"
,""
,"This program is free software; you can redistribute it and/or modify"
,"it under the terms of the GNU General Public License as published by"
,"the Free Software Foundation; either version 3 of the License, or"
,"(at your option) any later version."
,"This program is distributed in the hope that it will be useful,"
,"but WITHOUT ANY WARRANTY; without even the implied warranty of"
,"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the"
,"GNU General Public License for more details."
,"You should have received a copy of the GNU General Public License"
,"along with this program; if not, write to the Free Software Foundation,"
,"Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA"
]