edentv-4.1.0.0: EdenTvViewer.hs
{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs.
Copyright (C) 2005-2010 Phillips 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 EdenTvViewer where
import EdenTvType
import EdenTvBasic
import EdenTvInteract
import Graphics.UI.Gtk hiding (get)
import Graphics.UI.Gtk.Gdk.Pixbuf
import Graphics.UI.Gtk.Glade
import Graphics.Rendering.Cairo
import Control.Monad.State
import Control.Concurrent.MVar
import Numeric
--import DeepSeq
import Debug.Trace
-- short terms:
type DrawColor = (Render (), Render (), Render (), Render ())
-- idle running suspended blocked
type ColorButtons = (ColorButton,ColorButton,ColorButton,ColorButton)
-- at first the matrices are sorted and nothing is selected
initMatrix :: Int -> Int -> Int -> [MachineID] -> [ProcessID] -> String -> Bool -> ViewerState
initMatrix m p t lm lp filename ignoreMessages = VS {
selRow = [],
selView = 0, -- machines are the default view
locTime = False, -- local Time off
showMsg = False, -- messages off
matrixM = [1..(fromIntegral m)],
matrixP = [1..(fromIntegral p)],
matrixT = [1..(fromIntegral t)],
matrixGP = [1..(fromIntegral m)],
ommitRedraw = False,
clicked = False,
deleteSel = False,
noDND = False,
oldView = Nothing,
confMachines = [ (mId, (True,True)) | mId <- reverse lm],
confProcesses = [ (pId, (True,True)) | pId <- reverse lp],
autoTicks = True,
tickSkip = 0,
tickMark = 1,
filename = filename,
ignoreMessages = ignoreMessages}
-- draw a piece of text right-justified
showTextR :: String -> Render ()
showTextR str = do
info <- textExtents str
let width = (\ (TextExtents _ _ w _ _ _) -> w) info
relMoveTo (-width) 0
showText str
drawAnyPic :: Bool -> Bool -> Bool -> Bool -> Bool -> Double -> Double -> (Render () -> IO ()) -> (Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())) -> DrawingArea ->
Events -> MVar ViewerState -> MVar EdenTvState -> Int -> IO ()
drawAnyPic drawBlkMsg drawStartup hideStartupPhase drawDataMsgs drawSystemMsgs transX transY target drawfunc pic traces st edentvState rows = do
target $ do translate transX transY; save
state <- readMVar st
globalState <- readMVar edentvState
let colorsMap = colors globalState
-- if the startup-phase should not be displayed, the mininum startup
-- time is used as minTime
let traces'@(_, _, _, _, (minTime, maxTime, maxSTime, _, _), _)
= if hideStartupPhase
then setMinTimeToStartUpTime traces
else traces
let ommit = ommitRedraw state
when (not ommit) $ do
prepareBackground transX transY target pic colorsMap
-- Returns the time difference for a machine in relation to the
-- local startup time. Only used if startup synchronisation is
-- enabled
--
let getDiffTime :: Int -> [(MachineID, Double)] -> Double -> Double
getDiffTime machineId startTimes minTime
| hideStartupPhase = -((getStartTime machineId startTimes))
| otherwise = -((getStartTime machineId startTimes) + minTime)
-- Returns the relative position in percent for a given point of time
-- in relation to the total duration. The value is used to calculate the
-- absolute position in pixels (which is done automatically by the drawing
-- area).
--
let scaledTime :: Double -> Double
scaledTime time
| not $ locTime state = (time - minTime) / (maxTime - minTime)
| otherwise = (time - minTime) / ((maxTime+maxSTime) - minTime)
-- draw machines/processes/threads
drawAxes <- drawfunc hideStartupPhase transX transY target traces' colorsMap pic state getDiffTime scaledTime
pixelsPerSecond <- getPixelsPerSecond pic state minTime maxTime maxSTime
if selView state < 3
then addSelection transX transY target (fromIntegral rows) pic state
else addSelectionGroupedProcesses transX transY target (fromIntegral rows) pic state [] traces'
drawMessages drawBlkMsg drawDataMsgs drawSystemMsgs hideStartupPhase pixelsPerSecond transX transY target traces' pic state colorsMap
when (drawStartup && (not hideStartupPhase)) $ drawStartupMarker pixelsPerSecond transX transY target traces' pic state colorsMap
target showPage -- only for pdf export -- ortherwise useless
-- finally draw axes on top of everything
target drawAxes
setMinTimeToStartUpTime :: Events -> Events
setMinTimeToStartUpTime (lists, mTimes, maxStartups@(maxStartupTimeInSeconds, _), msgs, (_,maxTime,maxSTime,maxSize,maxLD), counts)
= (lists, mTimes, maxStartups, msgs, (maxStartupTimeInSeconds,maxTime,maxSTime,maxSize,maxLD), counts)
getPixelsPerSecond :: DrawingArea -> ViewerState -> Double -> Double -> Double -> IO Double
getPixelsPerSecond pic state minTime maxTime maxSTime = do
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let pixelsPerSecond
| locTime state = (lrx - ulx) / ((maxTime+maxSTime) - minTime)
| otherwise = (lrx - ulx) / (maxTime - minTime)
return pixelsPerSecond
drawMessages :: Bool -> Bool -> Bool -> Bool -> Double -> Double -> Double -> (Render () -> IO ()) -> Events -> DrawingArea -> ViewerState -> Colors -> IO ()
drawMessages drawBlkMsg drawDataMsgs drawSystemMsgs hideStartupPhase pixelsPerSecond visX visY target ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_) pic state colorsMap = do
if ((v < 2) || (v == 3)) && showMsg state
then do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let ySkip :: Double
ySkip = case v of
1 -> (lry - uly) / (fromIntegral (length (matrixP state)))
0 -> (lry - uly) / (fromIntegral (length (matrixM state)))
3 -> (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP state)))
-- do not draw trapezoid if each message of a message bulk is
-- drawn individually
when (drawDataMsgs && (not drawBlkMsg)) $ drawHeads win pixelsPerSecond ySkip ulx uly
drawRcvLengths win pixelsPerSecond ySkip ulx uly
drawMsgs win pixelsPerSecond ySkip ulx uly
else return ()
where v = selView state
useDiff = locTime state
sort = case v of
1 -> 0:(reverse (matrixP state))
0 -> reverse (matrixM state)
3 -> reverse (matrixGP state)
iv = 0
-- Returns the pixel position on the drawing area for a given
-- point of time.
--
getPositionInPx :: Int -> Double -> [(MachineID, Double)] -> Double -> Double
getPositionInPx machineId time startTimes xScale
| useDiff && hideStartupPhase = (time + (getStartTime machineId startTimes) - minTime) * xScale
| useDiff = (time + (getStartTime machineId startTimes)) * xScale
| otherwise = (time - minTime) * xScale
(rowPos,rowOff) = case v of
1 -> ((iv:(rowPosP 0 iv (reverse ps))), [iv..])
0 -> ((iv:(rowPosM iv (reverse ms))), (repeat iv))
where rowPosP :: Num a => MachineID -> a -> [Process] -> [a]
rowPosP _ _ [] = []
rowPosP m' i (((m,p),_,_,_,_):pss)
| m == m' = rowPosP m (i+1) pss
| otherwise = i:(rowPosP m (i+1) pss)
rowPosM :: Num a => a -> [Machine] -> [a]
rowPosM _ [] = []
rowPosM i (_:mss) = i:(rowPosM (i+1) mss)
numProcs :: [(MachineID, Int)]
numProcs = map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) ms
numM = fromIntegral $ length ms
sortedMachines = [(numM+1) - (posToMachine pos (matrixGP state)) | pos <- [1..numM]]
posToMachine :: Double -> [Double] -> Double
posToMachine pos sort = posAcc 1 pos sort
where posAcc i pos (s:ss)
| pos == s = i
| otherwise = posAcc (i+1) pos ss
posAcc _ _ [] = 0
machineOffsets = buildOffsets (0,0) sortedMachines
where buildOffsets :: (Double, Double) -> [Double] -> [(Double,Double)]
buildOffsets (numP, numSkip) (mId:mIds) = (numP, numSkip) : (buildOffsets ((fromIntegral curP)+numP, numSkip+1) mIds)
where Just curP = lookup (floor mId) numProcs
buildOffsets _ [] = []
messageActive :: ProcessID -> ProcessID -> Bool
messageActive sender receiver = case v of
3 -> let activeProcs = confProcesses state
Just (_,sout) = lookup sender activeProcs
Just (rin,_) = lookup receiver activeProcs
in sout && rin
1 -> let activeProcs = confProcesses state
Just (_,sout) = lookup sender activeProcs
Just (rin,_) = lookup receiver activeProcs
in sout && rin
0 -> let activeMachs = confMachines state
Just (_,sout) = lookup (fst sender) activeMachs
Just (rin,_) = lookup (fst receiver) activeMachs
in sout && rin
_ -> True
drawRcvLengths :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawRcvLengths win xScale yScale ulx uly =
target $ do
translate visX visY
translate ulx (uly- 0.2*yScale)
getColor messagesReceive colorsMap
drawRcvLength rcvtimes
where
pidsOnMachine :: MachineID -> [Int]
pidsOnMachine mId = map (\((_,pid),_,_,_,_) -> pid) $ filter (\((pmid,pid),_,_,_,_) -> pmid == mId) ps
row :: Int -> Int -> Double
row m p
| v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale)
| otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10)
where machine = floor $ sort!!(m-1)
(numP,numSkip) = machineOffsets!!(machine-1)
Just curP = lookup m numProcs
drawRcvLength [] = return ()
drawRcvLength (((mID,ptimes),st,et):ts) =
if and (map (0<=) [mID])
then do
drawRcvLength' mID ptimes st
drawRcvLength ts
else drawRcvLength ts
drawRcvLength' mID ((pID,ptime):ptimes) oldSec = do
rectangleLimited hideStartupPhase (getPositionInPx mID oldSec mxst xScale) (row mID pID) ((getPositionInPx mID ptime mxst xScale)-(getPositionInPx mID oldSec mxst xScale)) (yScale/10)
drawRcvLength' mID ptimes ptime
drawRcvLength' _ [] _ = fill
arrow :: Double -> Double -> Double -> Double -> Render ()
arrow fromX fromY toX toY = do
moveTo fromX fromY
lineTo toX toY
arc toX toY 1.5 0 (2 * pi)
stroke
drawMsgs :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawMsgs win xScale yScale ulx uly =
target $ do
translate visX visY
thickness <- getLineWidth
translate ulx (uly - 0.3*yScale)
drawMsg msgs thickness
-- if requested, draw additional messages
if drawBlkMsg then drawMsg amsgs (thickness/2) else return ()
where
row :: Int -> Int -> Double
row m p
| v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale)
| otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10)
where machine = floor $ sort!!(m-1)
(numP,numSkip) = machineOffsets!!(machine-1)
Just curP = lookup m numProcs
drawMsg [] l = setLineWidth l
drawMsg (m@(MSG ((sm,sp),o,(rm,rp),i) st rt t s):ms) thickness = do
when ((and (map (0<=) [sm,sp,rm,rp])) && (messageActive (sm,sp) (rm,rp)))
(do
if t == DataMes || t == Head || t == LocalDataMes || t == LocalHead-- not a system message (`DataMes` or `Head`)
then
when drawDataMsgs $ do
let colorType = case t of
DataMes -> messagesData
Head -> messagesHead
LocalDataMes -> messagesDataLocal
LocalHead -> messagesHeadLocal
getColor colorType colorsMap
drawMsgArrow thickness sm sp rm rp st rt
-- if t == DataMes
-- then do
-- -- draw data messages with half thickness
-- getColor messagesData colorsMap
-- drawMsgArrow (thickness / 2) sm sp rm rp st rt
-- else do
-- getColor messagesHead colorsMap
-- drawMsgArrow thickness sm sp rm rp st rt
else
-- if requested, draw system msgs with a gray color
-- otherwise skip the system msgs
when drawSystemMsgs $ do
getColor messagesSystem colorsMap
drawMsgArrow thickness sm sp rm rp st rt
)
drawMsg ms thickness
drawMsgArrow width sm sp rm rp st rt
= do
setLineWidth width
arrow (getPositionInPx sm st mxst xScale) ((row sm sp)-0.3*yScale) (getPositionInPx rm rt mxst xScale) (row rm rp)
arrow :: Double -> Double -> Double -> Double -> Render ()
arrow fromX fromY toX toY = do
moveTo fromX fromY
lineTo toX toY
arc toX toY 1.5 0 (2 * pi)
stroke
-- draws a transparent, grey trapezoid for bulk messages
drawHeads :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawHeads win xScale yScale ulx uly =
target $ do
translate visX visY
lWidth <- getLineWidth
setLineWidth (lWidth / 2)
translate ulx (uly - 0.3*yScale)
drawHead hmsgs
setLineWidth lWidth
where
row :: Int -> Int -> Double
row m p
| v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale)
| otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10)
where machine = floor $ sort!!(m-1)
(numP,numSkip) = machineOffsets!!(machine-1)
Just curP = lookup m numProcs
compSize = 2 * maxSize
relSize s = 0.15 + (s / compSize)
drawHead ((((sm,sp),_,(rm,rp),_),(ts1,tr1,ts2,tr2),size,_):hs) =
if ((min sp rp) < 0) || (not (messageActive (sm,sp) (rm,rp)))
then drawHead hs -- can't draw this!
else do getColorAlpha messagesBlock colorsMap (relSize size)
trapezoid (getPositionInPx sm ts1 mxst xScale) (getPositionInPx sm ts2 mxst xScale) ((row sm sp)-0.3*yScale)
(getPositionInPx rm tr1 mxst xScale) (getPositionInPx rm tr2 mxst xScale) (row rm rp)
drawHead hs
drawHead [] = return ()
trapezoid :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
trapezoid x11 x12 y1 x21 x22 y2 = do
moveTo x11 y1
lineTo x12 y1
lineTo x22 y2
lineTo x21 y2
fill
-- Draws a transparent blue box on top of a selected row
--
addSelection ::Double -> Double -> (Render () -> IO ()) -> Double -> DrawingArea -> ViewerState -> IO ()
addSelection visX visY target nRows pic state = do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let xSkip = (lrx - ulx)
ySkip = (lry - uly) / nRows
rows = selRow state
if (not $ null rows)
then sequence_ $ map (\row -> target $ do
translate visX visY
translate ulx uly
--scale xSkip ySkip
translate 0 (ySkip * (row - 1))
setSourceRGBA 0.0 0.0 1.0 0.3
rectangle 0.0 0.0 xSkip ySkip
fill) rows
else return ()
return ()
addSelectionGroupedProcesses :: Double -> Double -> (Render () -> IO ()) -> Double -> DrawingArea -> ViewerState -> [Double] -> Events -> IO ()
addSelectionGroupedProcesses visX visY target nRows pic state lineHeights ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_)= do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let xSkip = (lrx - ulx)
ySkip = (lry - uly) / nRows
rows = selRow state
numProcs :: [(MachineID, Int)]
numProcs = map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) ms
numM = fromIntegral $ length ms
procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP state)))
sortedMachines = [(numM+1) - (posToMachine pos (matrixGP state)) | pos <- [1..numM]]
posToMachine :: Double -> [Double] -> Double
posToMachine pos sort = posAcc 1 pos sort
where posAcc i pos (s:ss)
| pos == s = i
| otherwise = posAcc (i+1) pos ss
posAcc _ _ [] = 0
machineOffsets = buildOffsets (0,0) sortedMachines
where buildOffsets :: (Double, Double) -> [Double] -> [(Double,Double)]
buildOffsets (numP, numSkip) (mId:mIds) = (numP, numSkip) : (buildOffsets ((fromIntegral curP)+numP, numSkip+1) mIds)
where Just curP = lookup (floor mId) numProcs
buildOffsets _ [] = []
if (not $ null rows)
then sequence_ $ map (\row -> target $ do
translate visX visY
translate ulx uly
--scale xSkip ySkip
let mach = (floor numM + 1) - (floor (posToMachine row (matrixGP state)))
(numP,numGap) = (machineOffsets!!((floor row) - 1))
Just lenP = lookup mach numProcs
translate 0 (numP*procSkip+numGap*10 - 5)
setSourceRGBA 0.0 0.0 1.0 0.3
rectangle 0.0 0.0 xSkip ((fromIntegral lenP)*procSkip + 5)
fill) rows
else return ()
return ()
-- draws y-axis
--
drawNames :: Double -> Double -> [Double] -> [String] -> Colors -> Render ()
-- x-Offset lry y-Offsets names
drawNames x lry (s:ss) (n:ns) colorsMap = do
moveTo x (s-3)
getColor chartAxesLabel colorsMap
showTextR (n)
moveTo (x+2) s
getColor chartAxes colorsMap
lineTo (x+5) s
drawNames x lry ss ns colorsMap
drawNames x lry _ _ colorsMap = do
moveTo (x+5) (- 5)
getColor chartAxes colorsMap
lineTo (x+5) (lry + 5)
drawName x lry y name colorsMap = do
moveTo x (y-3)
getColor chartAxesLabel colorsMap
showTextR name
drawNameTick x lry y colorsMap = do
moveTo (x+2) y
getColor chartAxes colorsMap
lineTo (x+5) y
drawNameLine x lry colorsMap = do
moveTo (x+5) (- 5)
getColor chartAxes colorsMap
lineTo (x+5) (lry + 5)
drawTimes :: Bool -- True, if ticks/labels should be placed automatically
-> Seconds -- draw tick every `manualSkip` seconds
-> Int -- draw time every `manualMarks` ticks
-> (Seconds, Seconds, Seconds)
-> Bool -- startup sync. enabled
-> DimV -- visible area
-> Dim -- area to draw in
-> Colors
-> Render ()
drawTimes useAuto manualSkip manualMarks (minT,maxT,maxST) useDiff (vx,vy,vw,vh) (ulx,uly,lrx,lry) colors = do
let y = fromIntegral (vy + vh - 20)
xDelta = fromIntegral vw / 15
tDelta
| useDiff = xDelta * ((maxT+maxST) - minT) / (lrx - ulx)
| otherwise = xDelta * (maxT - minT) / (lrx - ulx)
tSkip = if not useAuto then manualSkip else smoothSkip tDelta
xSkip
| useDiff = tSkip * (lrx - ulx) / ((maxT+maxST) - minT)
| otherwise = tSkip * (lrx - ulx) / (maxT - minT)
-- draw the x-axis
moveTo (ulx-5) y
getColor chartAxes colors
lineTo lrx y
stroke
-- draw axis labels and ticks
drawTime 0 xSkip y
where
drawTime :: Double -> Double -> Double -> Render ()
drawTime i x y = if mx < lrx
then do
-- draw tick
moveTo mx y
getColor chartAxes colors
lineTo mx my
stroke
-- draw label
moveTo mx (y + 12)
getColor chartAxesLabel colors
if useAuto
then showText timeString
else if (floor i) `mod` manualMarks == 0
then showText timeString
else return ()
drawTime (i+1) x y
else stroke
where mx = ulx + (i * x)
my = if useAuto
then y + 5
else if ((floor i) `mod` manualMarks == 0) && manualMarks > 1
then y + 6
else y + 5
fullTime
| useDiff = (showFFloat (Just 6) (posToTime minT (maxT+maxST) ulx lrx mx) "")
| otherwise = (showFFloat (Just 6) (posToTime minT maxT ulx lrx mx) "")
-- drop trailing zeros (1.600000 -> 1.6)
(sndStr,fstStr) = splitAt 5 (reverse fullTime)
timeString = (reverse fstStr) ++ (reverse (dropWhile (== '0') sndStr))
smoothSkip :: Seconds -> Double
smoothSkip s
| cmp > 7 = 10^^(exponent+1)
| cmp > 5 = 7.5 * 10^^exponent
| cmp > 2 = 5 * 10^^exponent
| cmp > 1 = 2 * 10^^exponent
| otherwise = 10^^exponent
where exponent = floor (logBase 10 s)
cmp = s * 10^^(-exponent)
drawThreads :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawThreads hideStartupPhase visX visY target ((_,_,threads),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do
win <- widgetGetDrawWindow pic
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let numT = (fromIntegral (length threads))::Double
ySkip = (lry - uly) / numT
xSkip = (lrx - ulx)
sort = matrixT state
names = map (\(((m,p),t),_) -> ('T':(show m) ++ ':':(show p) ++ ':': (show t))) threads
target $ do
translate visX visY
save
translate ulx uly
scale xSkip ySkip
if locTime state
then drawLocalThreads threads sort
else drawGlobalThreads threads sort
restore
let drawAxes = do
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color
stroke
return drawAxes
where
drawLocalThreads, drawGlobalThreads :: [Thread] -> [Double] -> Render ()
drawLocalThreads ((((m,_),_),evts):ts) (s:ss) = do
let diff = getDiffTime m mxst minTime
drawEvents evts 1 s diff
drawLocalThreads ts ss
drawLocalThreads _ _ = return ()
drawGlobalThreads ((_,evts):ts) (s:ss) = do
drawEvents evts 1 s 0.0
drawGlobalThreads ts ss
drawGlobalThreads _ _ = return ()
drawEvents :: [ThreadEvent] -> Double -> Double -> Double -> Render ()
drawEvents (e:es) oldSec line diff = case e of
(KillThread sec) -> drawEvents es (scaledTime (sec - diff)) line diff
(GCThread sec _ _ _ l) -> do
let (newSec,evtColor) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff
evt -> do
let (newSec,evtColor) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec barO (oldSec - newSec) barH
fill
drawEvents es newSec line diff
where getTimeAndColor = case e of
RunThread sec -> (scaledTime (sec - diff), getColor statusRunning color)
SuspendThread sec -> (scaledTime (sec - diff), getColor statusSuspended color)
BlockThread sec _ _ -> (scaledTime (sec - diff), getColor statusBlocked color)
DeblockThread sec -> (scaledTime (sec - diff), getColor statusSuspended color)
GCThread sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color)
NewThread sec _ -> (scaledTime (sec - diff), getColor statusSuspended color)
barO = line - 0.8
barG = line - 0.1
drawEvents _ _ _ _ = return ()
barH = 0.7
ldScale = (-barH) / maxLD
drawProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawProcesses hideStartupPhase visX visY target ((_,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do
win <- widgetGetDrawWindow pic
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let numP = (fromIntegral (length processes))::Double
ySkip = (lry - uly) / numP
xSkip = (lrx - ulx)
sort = matrixP state
names = map (\((m,p),_,_,_,_) -> ('P':(show m) ++ ':':(show p))) processes
target $ do
translate visX visY
save
translate ulx uly
scale xSkip ySkip
if locTime state
then drawLocalProcesses processes sort
else drawGlobalProcesses processes sort
restore
let drawAxes = do
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color
stroke
return drawAxes
where
drawLocalProcesses, drawGlobalProcesses :: [Process] -> [Double] -> Render ()
drawLocalProcesses (((m,_),_,_,_,evts):ps) (s:ss) = do
let diff = getDiffTime m mxst minTime
drawEvents evts 1 s diff
drawLocalProcesses ps ss
drawLocalProcesses _ _ = return ()
drawGlobalProcesses ((_,_,_,_,evts):ps) (s:ss) = do
drawEvents evts 1 s 0.0
drawGlobalProcesses ps ss
drawGlobalProcesses _ _ = return ()
drawEvents :: [ProcessEvent] -> Double -> Double -> Double -> Render ()
drawEvents [] _ _ _ = return ()
drawEvents (e:es) oldSec line diff = case e of
KillProcess sec _ -> drawEvents es (scaledTime (sec - diff)) line diff
LabelProcess _ _ -> drawEvents es oldSec line diff -- don't care
GCProcess sec _ _ _ l -> do
let (newSec,evtColor,_,_) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff
_ -> do
let (newSec,evtColor,u,d) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec u (oldSec - newSec) d
fill
drawEvents es newSec line diff
where getTimeAndColor = case e of
RunningProcess sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH)
SuspendedProcess sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH)
BlockedProcess sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH)
GCProcess sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH)
NewProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
IdleProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
barO = line - 0.8
barG = line - 0.1
barP = line - 0.5
barH = 0.7
barI = 0.4
ldScale = (-barH) / maxLD
drawGroupProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawGroupProcesses hideStartupPhase visX visY target ((machines,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do
win <- widgetGetDrawWindow pic
let groupedProcesses = map (\(mid,_,_,_,_) -> filter (\((pmid,pid),_,_,_,_) -> pmid == mid) processes) machines
--let sortOrder :: [(Double,
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let numP = (fromIntegral (length processes))::Double
numM = (fromIntegral (length machines))::Double
machGap = 10
ySkip = ((lry - uly - ((numM-1)*machGap) ) / numP)
xSkip = (lrx - ulx)
sort = matrixGP state
names = map (\((m,p),_,_,_,_) -> ('P':(show m) ++ ':':(show p))) processes
sortGroup = map (pos 1 sort) [1..numM]
where pos :: Double -> [Double] -> Double -> Double
pos i (y:ys) x
| x == y = i
| otherwise = pos (i+1) ys x
pos _ [] _ = undefined
sortedGroupedProcess = map (\i -> groupedProcesses !! ((floor i)-1)) sortGroup
drawLocalGroupedProcesses :: [[Process]] -> Double -> Render ()
drawLocalGroupedProcesses (p:ps) i = do
let skip = (machGap / ySkip)
drawLocalProcesses p [1..] i
drawLocalGroupedProcesses ps (i + (fromIntegral $ length p) + skip)
drawLocalGroupedProcesses [] _ = return ()
drawGlobalGroupedProcesses :: [[Process]] -> Double -> Render ()
drawGlobalGroupedProcesses (p:ps) i = do
let skip = (machGap / ySkip)
drawGlobalProcesses p [1..] i
drawGlobalGroupedProcesses ps (i + (fromIntegral $ length p) + skip)
drawGlobalGroupedProcesses [] _ = return ()
drawGroupNames :: [[Process]] -> Double -> Render ()
drawGroupNames (p:ps) i = do
let skip = (machGap)
drawPNames p [1..] i color
stroke
drawGroupNames ps (i+ (((fromIntegral $ length p))*ySkip) + skip)
drawGroupNames [] _ = do
drawNameLine (fromIntegral vx + ulx - 5) (lry-uly) color
stroke
drawPNames [((m,pid),_,_,_,evts)] (s:ss) skip = do
drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show m) ++ ":" ++ (show pid))
drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5)
drawPNames (((m,pid),_,_,_,evts):ps) (s:ss) skip = do
drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show m) ++ ":" ++ (show pid))
drawPNames ps ss skip
target $ do
translate visX visY
save
translate ulx uly
scale xSkip ySkip
--liftIO $ putStrLn $ "sort" ++ (show sort)
--liftIO $ putStrLn $ "sortGroup" ++ (show sort)
if locTime state
then drawLocalGroupedProcesses sortedGroupedProcess 0
else drawGlobalGroupedProcesses sortedGroupedProcess 0
restore
let drawAxes = do
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawGroupNames sortedGroupedProcess 0
stroke
return drawAxes
where
drawLocalProcesses :: [Process] -> [Double] -> Double -> Render ()
drawLocalProcesses (((m,_),_,_,_,evts):ps) (s:ss) skip = do
let diff = getDiffTime m mxst minTime
drawEvents evts 1 s diff skip
drawLocalProcesses ps ss skip
drawLocalProcesses _ _ _ = return ()
drawGlobalProcesses ((_,_,_,_,evts):ps) (s:ss) skip = do
drawEvents evts 1 s 0.0 skip
drawGlobalProcesses ps ss skip
drawGlobalProcesses _ _ _ = return ()
drawEvents :: [ProcessEvent] -> Double -> Double -> Double -> Double -> Render ()
drawEvents [] _ _ _ _ = return ()
drawEvents (e:es) oldSec line diff skip = case e of
KillProcess sec _ -> drawEvents es (scaledTime (sec - diff)) line diff skip
LabelProcess _ _ -> drawEvents es oldSec line diff skip -- don't care
GCProcess sec _ _ _ l -> do
let (newSec,evtColor,_,_) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff skip
_ -> do
let (newSec,evtColor,u,d) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec (skip+u) (oldSec - newSec) d
fill
drawEvents es newSec line diff skip
where getTimeAndColor = case e of
RunningProcess sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH)
SuspendedProcess sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH)
BlockedProcess sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH)
GCProcess sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH)
NewProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
IdleProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
barO = line - 1 -- - 0.7
barG = line - 0.1
barP = line - 0.5
barH = 1
barI = 0.4
ldScale = (-barH) / maxLD
drawMachines :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawMachines hideStartupPhase visX visY target ((machines,_,_),mTimes,(mxs,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do
win <- widgetGetDrawWindow pic
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let numM = (fromIntegral (length machines))::Double
ySkip = (lry - uly) / numM
xSkip = (lrx - ulx)
sort = matrixM state
names = map (\(m,_,_,_,_) -> ('M':(show m))) machines
target $ do
translate visX visY
translate ulx (uly - ySkip)
scale xSkip ySkip
if locTime state
then drawLocalMachines machines sort
else drawGlobalMachines machines sort
let drawAxes = do
translate visX visY
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color
stroke
return drawAxes
where
-- startup sync activated
drawLocalMachines, drawGlobalMachines :: [Machine] -> [Double] -> Render ()
drawLocalMachines ((i,_,_,_,evts):ms) (s:ss) = do
let diffTime = getDiffTime i mxst minTime
drawEvents evts 1 s diffTime
drawLocalMachines ms ss
drawLocalMachines _ _ = return ()
-- startup sync deactivated
drawGlobalMachines ((i,_,_,_,evts):ms) (s:ss) = do
drawEvents evts 1 s 0.0
drawGlobalMachines ms ss
drawGlobalMachines _ _ = return ()
drawEvents :: [MachineEvent] -> Double -> Double -> Double -> Render ()
drawEvents (e:es) oldSec line diff = case e of
(EndMachine sec) ->
drawEvents es (scaledTime (sec - diff)) line diff
(GCMachine sec _ _ _ l) -> do
let (newSec,evtColor,_,_) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff
_ -> do
let (newSec,evtColor,u,d) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec u (oldSec - newSec) d
fill
drawEvents es newSec line diff
where getTimeAndColor = case e of
RunningMachine sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH)
SuspendedMachine sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH)
BlockedMachine sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH)
GCMachine sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH)
StartMachine sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
IdleMachine sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
barO = line + 0.2
barG = line + 0.9
barP = line + 0.5
drawEvents _ _ _ _ = return ()
barH = 0.7
barI = 0.4
ldScale = (-barH) / maxLD
prepareBackground :: Double -> Double -> (Render () -> IO ()) -> DrawingArea -> Colors -> IO ()
prepareBackground visX visY target area colors = do
win <- widgetGetDrawWindow area
(w,h) <- widgetGetSize area
(_,(ulx,uly,lrx,lry)) <- getCorners area
let width = realToFrac w
height = realToFrac h
width' = width - 2 * border
height' = height - 2 * border
target $ do
translate visX visY
-- setLineWidth 1
-- Background
colorGray
rectangle 0 0 width height
fill
colorBlack
-- Shadow of paper
save
translate shadow shadow
rectangle border border width' height'
fill
restore
-- Paper
rectangle border border width' height'
stroke
getColor chartBackground colors
rectangle border border width' height'
fill
{-- Axis
colorBlack
moveTo (ulx - 10) lry
lineTo (lrx + 5) lry
stroke-}
return ()
where
-- create a dialog with a message (for errors and questions)
genericDialog :: String -> Bool -> IO Dialog
genericDialog msg err = do
dlg <- dialogNew
dialogSetHasSeparator dlg False
windowSetIconName dlg $ if err
then "gtk-dialog-error"
else "gtk-dialog-question"
upper <- dialogGetUpper dlg
label <- labelNew (Just msg)
labelSetJustify label JustifyCenter
miscSetPadding label 20 20
containerAdd upper label
return dlg
-- errorMessage:
-- opens a window and displays the given string as errormessage
errorMessage :: String -> IO ()
errorMessage e = do
dlg <- genericDialog e True
dialogAddButton dlg stockOk ResponseOk
afterResponse dlg (\_ -> widgetDestroy dlg)
widgetShowAll dlg
yesNoMessage :: String -> IO Bool
yesNoMessage e = do
dlg <- genericDialog e False
dialogAddButton dlg stockYes ResponseYes
dialogAddButton dlg stockNo ResponseNo
afterResponse dlg (\_ -> widgetDestroy dlg)
widgetShowAll dlg
response <- dialogRun dlg
case response of
ResponseYes -> return True
_ -> return False
drawStartupMarker :: Double -> Double -> Double -> (Render () -> IO ()) -> Events -> DrawingArea -> ViewerState -> Colors -> IO ()
drawStartupMarker pixelsPerSecond visX visY target (_, _, (maxStartupTimeInSeconds,_),_ , (minTime, maxTime, maxSTime,_ ,_ ), _) pic state colorsMap
= do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
drawMarker win pixelsPerSecond ulx uly (lry - uly)
where
drawMarker :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawMarker win pixelsPerSecond ulx uly height = target $ do
translate visX visY
thickness <- getLineWidth
setLineWidth (thickness / 2)
translate ulx uly
getColor markerStartup colorsMap
let startupPositionInPx = getPosition maxStartupTimeInSeconds
arrow startupPositionInPx (0) startupPositionInPx (height)
setLineWidth thickness
where
getPosition :: Double -> Double
getPosition seconds = seconds * pixelsPerSecond
arrow :: Double -> Double -> Double -> Double -> Render ()
arrow fromX fromY toX toY = do
moveTo fromX fromY
lineTo toX toY
arc toX toY 1.5 0 (2 * pi)
stroke
-- When hiding the startup-phase, the blue box of a machine might start before
-- the y-axis. This function makes sure that only the part right of the
-- y-axis is drawn.
rectangleLimited :: Bool -> Double -> Double -> Double -> Double -> Render()
rectangleLimited checkOverflow x y width height
| checkOverflow && (x < 0) = do
let newWidth = width + x
when (newWidth > 0) $ rectangle 0 y newWidth height
| otherwise = rectangle x y width height