{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs. Copyright (C) 2005-2012 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 EdenTvViewer where import EdenTvType import EdenTvBasic import EdenTvInteract import Control.Monad.State import Control.Concurrent.MVar import Data.List (foldl') import qualified Data.Map.Strict as MS import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.Gdk.Pixbuf import Graphics.Rendering.Cairo 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' = if hideStartupPhase then setMinTimeToStartUpTime traces else traces minTime = min_t traces' maxTime = max_t traces' maxSTime = max_t_diff 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 events = events {min_t = maxStartup events} 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 events pic state colorsMap = do --events was ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_) 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 ms = machinelist events ps = processlist events minTime = min_t events mxst = startupOffsets events (msgs,amsgs,hmsgs,_,rcvtimes) = messagelist events -- 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 (p:pss) | (getMIdFromP p) == m' = rowPosP m' (i+1) pss | otherwise = i:(rowPosP (getMIdFromP p) (i+1) pss) rowPosM :: Num a => a -> [Machine] -> [a] rowPosM _ [] = [] rowPosM i (_:mss) = i:(rowPosM (i+1) mss) numProcs :: MS.Map MachineID Int --was: [(MachineID, Int)] numProcs = foldl' (\c m -> MS.insert (getIdM m) (totalProcesses m) c) MS.empty ms --was: 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 = MS.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 (pId2mId sender) activeMachs Just (rin,_) = lookup (pId2mId 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.getIdP) $ filter ((== mId).getMIdFromP) 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 = MS.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 = MS.lookup m numProcs drawMsg [] l = setLineWidth l drawMsg (m@(MSG (spid,o,rpid,i) st rt t s):ms) thickness = do let sm = pId2mId spid sp = pId spid rm = pId2mId rpid rp = pId rpid when ((and (map (0<=) [sm,sp,rm,rp])) && (messageActive spid rpid)) (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 = MS.lookup m numProcs compSize = 2 * (maxMsgSize events) relSize s = 0.15 + (s / compSize) drawHead (((spid,_,rpid,_),(ts1,tr1,ts2,tr2),size,_):hs) = let sm = pId2mId spid sp = pId spid rm = pId2mId rpid rp = pId rpid in if ((min sp rp) < 0) || (not (messageActive spid rpid)) 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 events= do --events was ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_) win <- widgetGetDrawWindow pic (_,(ulx,uly,lrx,lry)) <- getCorners pic let ms = machinelist events xSkip = (lrx - ulx) ySkip = (lry - uly) / nRows rows = selRow state numProcs :: MS.Map MachineID Int --was: [(MachineID, Int)] numProcs = foldl' (\c m -> MS.insert (getIdM m) (totalProcesses m) c) MS.empty ms --was: 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 = MS.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 = MS.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 events color pic state getDiffTime scaledTime = do --events was ((_,_,threads),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) win <- widgetGetDrawWindow pic (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic let threads = threadlist events numT = (fromIntegral (length threads))::Double ySkip = (lry - uly) / numT xSkip = (lrx - ulx) sort = matrixT state names = map (\((pid,t),_) -> ('T':(show pid) ++ ':': (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 maxTime = max_t events maxSTime = max_t_diff events 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 minTime = min_t events drawLocalThreads, drawGlobalThreads :: [Thread] -> [Double] -> Render () drawLocalThreads (((pid,_),evts):ts) (s:ss) = do let diff = getDiffTime (pId2mId pid) (startupOffsets events) 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 events) drawProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) drawProcesses hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do --events was ((_,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) win <- widgetGetDrawWindow pic (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic let processes = processlist events numP = (fromIntegral (length processes))::Double ySkip = (lry - uly) / numP xSkip = (lrx - ulx) sort = matrixP state names = map (\p' -> let pid = getIdP p' in ('P':(show pid))) 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 maxTime = max_t events maxSTime = max_t_diff events 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 minTime = min_t events drawLocalProcesses, drawGlobalProcesses :: [Process] -> [Double] -> Render () drawLocalProcesses (p:ps) (s:ss) = do let diff = getDiffTime (getMIdFromP p) (startupOffsets events) minTime drawEvents (eventlistP p) 1 s diff drawLocalProcesses ps ss drawLocalProcesses _ _ = return () drawGlobalProcesses (p:ps) (s:ss) = do drawEvents (eventlistP p) 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) _ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0) barO = line - 0.8 barG = line - 0.1 barP = line - 0.5 barH = 0.7 barI = 0.4 ldScale = (-barH) / (maxLD events) drawGroupProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) drawGroupProcesses hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do --events was ((machines,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) let machines = machinelist events processes = processlist events win <- widgetGetDrawWindow pic let groupedProcesses = map (\m -> let mId = getIdM m in filter (\p -> getMIdFromP p == 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 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 [p] (s:ss) skip colors = do let pid = getIdP p drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) colors drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5) colors drawPNames (p:ps) (s:ss) skip colors = do let pid = getIdP p drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) colors drawPNames ps ss skip colors 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 maxTime = max_t events maxSTime = max_t_diff events 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 minTime = min_t events drawLocalProcesses :: [Process] -> [Double] -> Double -> Render () drawLocalProcesses (p:ps) (s:ss) skip = do let diff = getDiffTime (getMIdFromP p) (startupOffsets events) minTime drawEvents (eventlistP p) 1 s diff skip drawLocalProcesses ps ss skip drawLocalProcesses _ _ _ = return () drawGlobalProcesses (p:ps) (s:ss) skip = do drawEvents (eventlistP p) 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) _ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0) barO = line - 1 -- - 0.7 barG = line - 0.1 barP = line - 0.5 barH = 1 barI = 0.4 ldScale = (-barH) / (maxLD events) drawMachines :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) drawMachines hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do --events was ((machines,_,_),mTimes,(mxs,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) win <- widgetGetDrawWindow pic (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic let machines = machinelist events maxTime = max_t events maxSTime = max_t_diff events numM = (fromIntegral (length machines))::Double ySkip = (lry - uly) / numM xSkip = (lrx - ulx) sort = matrixM state names = map (\m -> ('M':(show $ getIdM 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 minTime = min_t events -- startup sync activated drawLocalMachines, drawGlobalMachines :: [Machine] -> [Double] -> Render () drawLocalMachines (m:ms) (s:ss) = do let diffTime = getDiffTime (getIdM m) (startupOffsets events) minTime drawEvents (eventlistM m) 1 s diffTime drawLocalMachines ms ss drawLocalMachines _ _ = return () -- startup sync deactivated drawGlobalMachines (m:ms) (s:ss) = do drawEvents (eventlistM m) 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) _ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0) barO = line + 0.2 barG = line + 0.9 barP = line + 0.5 drawEvents _ _ _ _ = return () barH = 0.7 barI = 0.4 ldScale = (-barH) / (maxLD events) 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 events pic state colorsMap = do win <- widgetGetDrawWindow pic (_,(ulx,uly,lrx,lry)) <- getCorners pic drawMarker win pixelsPerSecond ulx uly (lry - uly) where --events was (_, _, (maxStartupTimeInSeconds,_),_ , (minTime, maxTime, maxSTime,_ ,_ ), _) 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 (maxStartup events) 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