edentv-4.9.1: EdenTvInteract.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-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
-}
{-# OPTIONS_GHC -cpp #-}
module EdenTvInteract where
import EdenTvType
import EdenTvBasic
import Graphics.UI.Gtk hiding (get, eventButton)
import Graphics.UI.Gtk.Gdk.Events
import qualified Graphics.UI.Gtk.Gdk.GC as G
import Graphics.UI.Gtk.Builder
import Graphics.UI.Gtk.ModelView.TreeView
import Graphics.UI.Gtk.ModelView.ListStore
import Graphics.Rendering.Cairo
import Data.Tree hiding (drawTree)
import Data.Char
import Control.Concurrent.MVar
import Data.List
import Debug.Trace
-- get dimensions of drawinarea:
-- visible Rect and the upper left and lower right corners to draw in
type Dim = (Double,Double,Double,Double)
type DimV = (Int,Int,Int,Int)
getCorners :: DrawingArea -> IO (DimV,Dim)
getCorners pic = do
win <- widgetGetDrawWindow pic
(w,h) <- widgetGetSize pic
vR <- drawableGetVisibleRegion win
Rectangle vx vy vw vh <- regionGetClipbox vR
return ((vx, vy, vw, vh), (border + 50, border + 20,
(realToFrac w) - 20, (realToFrac h) - 20))
buildConfMsg :: MVar ViewerState -> Builder -> DrawingArea -> Int -> IO ()
buildConfMsg st glade pic v = do
-- get access to the widgets:
confM <- builderGetObject glade castToTreeView "confM"
confP <- builderGetObject glade castToTreeView "confP"
noteb <- builderGetObject glade castToNotebook "notebook1X"
-- Machine checkBoxes
mId <- treeViewColumnNew
treeViewColumnSetTitle mId "machine id"
treeViewAppendColumn confM mId
rendererMId <- cellRendererTextNew
cellLayoutPackStart mId rendererMId True
mSnt <- treeViewColumnNew
treeViewColumnSetTitle mSnt "show outgoing"
treeViewAppendColumn confM mSnt
rendererMSnt <- cellRendererToggleNew
cellLayoutPackStart mSnt rendererMSnt True
mRcv <- treeViewColumnNew
treeViewColumnSetTitle mRcv "show incoming"
treeViewAppendColumn confM mRcv
rendererMRcv <- cellRendererToggleNew
cellLayoutPackStart mRcv rendererMRcv True
state <- readMVar st
dataM <- listStoreNew (confMachines state)
-- activate right tab view
case v of
1 -> notebookSetCurrentPage noteb 1
3 -> notebookSetCurrentPage noteb 1
0 -> notebookSetCurrentPage noteb 0
_ -> notebookSetCurrentPage noteb 0
-- update the model when the toggle buttons are activated
on rendererMRcv cellToggled $ \pathStr -> do
let (i:_) = stringToTreePath pathStr
(mid,(inb,outb)) <- listStoreGetValue dataM i
listStoreSetValue dataM i (mid,(not inb,outb))
on rendererMSnt cellToggled $ \pathStr -> do
let (i:_) = stringToTreePath pathStr
(mid,(inb,outb)) <- listStoreGetValue dataM i
listStoreSetValue dataM i (mid,(inb,not outb))
cellLayoutSetAttributes mId rendererMId dataM $ \(id,_) -> [ cellText := (show id) ]
cellLayoutSetAttributes mRcv rendererMRcv dataM $ \(_,(inb,_)) -> [ cellToggleActive := inb ]
cellLayoutSetAttributes mSnt rendererMSnt dataM $ \(_,(_,outb)) -> [ cellToggleActive := outb ]
treeViewSetModel confM dataM
treeViewColumnsAutosize confM
buttonStoreM <- builderGetObject glade castToButton "store_m"
buttonAllInM <- builderGetObject glade castToButton "all_in_m"
buttonAllOutM <- builderGetObject glade castToButton "all_out_m"
buttonNoneInM <- builderGetObject glade castToButton "none_in_m"
buttonNoneOutM <- builderGetObject glade castToButton "none_out_m"
onClicked buttonStoreM (do oldState <- takeMVar st
val <- listStoreToList dataM
--putStrLn ("saving: " ++ (show val))
putMVar st (oldState {confMachines = val})
widgetQueueDraw pic)
onClicked buttonAllInM (do vals <- listStoreToList dataM
let newVals = setAllIn True vals
listStoreClear dataM
sequence_ $ map (\x -> listStoreAppend dataM x) newVals)
onClicked buttonAllOutM (do vals <- listStoreToList dataM
let newVals = setAllOut True vals
listStoreClear dataM
sequence_ $ map (\x -> listStoreAppend dataM x) newVals)
onClicked buttonNoneInM (do vals <- listStoreToList dataM
let newVals = setAllIn False vals
listStoreClear dataM
sequence_ $ map (\x -> listStoreAppend dataM x) newVals)
onClicked buttonNoneOutM (do vals <- listStoreToList dataM
let newVals = setAllOut False vals
listStoreClear dataM
sequence_ $ map (\x -> listStoreAppend dataM x) newVals)
-- Process checkBoxes
pId <- treeViewColumnNew
treeViewColumnSetTitle pId "process id"
treeViewAppendColumn confP pId
rendererPId <- cellRendererTextNew
cellLayoutPackStart pId rendererPId True
pSnt <- treeViewColumnNew
treeViewColumnSetTitle pSnt "show outgoing"
treeViewAppendColumn confP pSnt
rendererPSnt <- cellRendererToggleNew
cellLayoutPackStart pSnt rendererPSnt True
pRcv <- treeViewColumnNew
treeViewColumnSetTitle pRcv "show incoming"
treeViewAppendColumn confP pRcv
rendererPRcv <- cellRendererToggleNew
cellLayoutPackStart pRcv rendererPRcv True
state <- readMVar st
dataP <- listStoreNew (confProcesses state)
-- update the model when the toggle buttons are activated
on rendererPRcv cellToggled $ \pathStr -> do
let (i:_) = stringToTreePath pathStr
(mid,(inb,outb)) <- listStoreGetValue dataP i
listStoreSetValue dataP i (mid,(not inb,outb))
on rendererPSnt cellToggled $ \pathStr -> do
let (i:_) = stringToTreePath pathStr
(mid,(inb,outb)) <- listStoreGetValue dataP i
listStoreSetValue dataP i (mid,(inb,not outb))
cellLayoutSetAttributes pId rendererPId dataP $ \(id,_) -> [ cellText := (show id) ]
cellLayoutSetAttributes pRcv rendererPRcv dataP $ \(_,(inb,_)) -> [ cellToggleActive := inb ]
cellLayoutSetAttributes pSnt rendererPSnt dataP $ \(_,(_,outb)) -> [ cellToggleActive := outb ]
treeViewSetModel confP dataP
treeViewColumnsAutosize confP
buttonStoreP <- builderGetObject glade castToButton "store_p"
buttonAllInP <- builderGetObject glade castToButton "all_in_p"
buttonAllOutP <- builderGetObject glade castToButton "all_out_p"
buttonNoneInP <- builderGetObject glade castToButton "none_in_p"
buttonNoneOutP <- builderGetObject glade castToButton "none_out_p"
onClicked buttonStoreP (do oldState <- takeMVar st
val <- listStoreToList dataP
--putStrLn ("saving: " ++ (show val))
putMVar st (oldState {confProcesses = val})
widgetQueueDraw pic)
onClicked buttonAllInP (do vals <- listStoreToList dataP
let newVals = setAllIn True vals
listStoreClear dataP
sequence_ $ map (\x -> listStoreAppend dataP x) newVals)
onClicked buttonAllOutP (do vals <- listStoreToList dataP
let newVals = setAllOut True vals
listStoreClear dataP
sequence_ $ map (\x -> listStoreAppend dataP x) newVals)
onClicked buttonNoneInP (do vals <- listStoreToList dataP
let newVals = setAllIn False vals
listStoreClear dataP
sequence_ $ map (\x -> listStoreAppend dataP x) newVals)
onClicked buttonNoneOutP (do vals <- listStoreToList dataP
let newVals = setAllOut False vals
listStoreClear dataP
sequence_ $ map (\x -> listStoreAppend dataP x) newVals)
return ()
where setAll :: (Bool, Bool) -> [(a,(Bool,Bool))] -> [(a,(Bool,Bool))]
setAll to ((x,_):xs) = (x,to) : (setAll to xs)
setAll _ [] = []
setAllIn :: Bool -> [(a,(Bool,Bool))] -> [(a,(Bool,Bool))]
setAllIn to ((x,(_,out)):xs) = (x,(to,out)) : (setAllIn to xs)
setAllIn _ [] = []
setAllOut :: Bool -> [(a,(Bool,Bool))] -> [(a,(Bool,Bool))]
setAllOut to ((x,(i,_)):xs) = (x,(i,to)) : (setAllOut to xs)
setAllOut _ [] = []
data MachineInfo = MachineInfo { machId :: String, runtime :: String, numProcesses :: String, numSent :: String, numRcvd :: String}
data ProcessInfo = ProcessInfo { machIdP :: String, procId :: String, runtimeP :: String, numThreads :: String, numSentP :: String, numRcvdP :: String}
data ThreadInfo = ThreadInfo { machIdT :: String, procIdT :: String, thrdId :: String, runtimeT :: String}
showTraceInfo :: Events -> String -> String -> Builder -> IO ()
showTraceInfo events filename statusString glade = do
--events was: ((ms,ps,ts),mt,mxst,(msgs,_,heads,pt,_),(minT,maxT,_,_,_),_)
let (_, _, _, pt,_) = messagelist events
-- get access to the widgets:
infoA <- builderGetObject glade castToLabel "infoA"
infoM <- builderGetObject glade castToTreeView "infoM"
infoP <- builderGetObject glade castToTreeView "infoP"
infoT <- builderGetObject glade castToTreeView "infoT"
-- Global information:
labelSetText infoA ("Tracefile: " ++ filename ++ "\n" ++
map (commaToNewline) statusString ++ "\n\nProcesstree:\n" ++ drawTree pt)
-- Machine information:
-- #if __GLASGOW_HASKELL__ < 606
--skelM <- emptyListSkel
mId <- treeViewColumnNew
treeViewColumnSetTitle mId "machine id"
treeViewAppendColumn infoM mId
rendererMId <- cellRendererTextNew
cellLayoutPackStart mId rendererMId True
mTime <- treeViewColumnNew
treeViewColumnSetTitle mTime "runtime (s)"
treeViewAppendColumn infoM mTime
rendererMTime <- cellRendererTextNew
cellLayoutPackStart mTime rendererMTime True
mPrcs <- treeViewColumnNew
treeViewColumnSetTitle mPrcs "processes"
treeViewAppendColumn infoM mPrcs
rendererMPrcs <- cellRendererTextNew
cellLayoutPackStart mPrcs rendererMPrcs True
--mTrds <- treeViewColumnNew
--treeViewColumnSetTitle mTrds "threads"
--treeViewAppendColumn infoM mTrds
mSent <- treeViewColumnNew
treeViewColumnSetTitle mSent "sent messages"
treeViewAppendColumn infoM mSent
rendererMSent <- cellRendererTextNew
cellLayoutPackStart mSent rendererMSent True
mRcvd <- treeViewColumnNew
treeViewColumnSetTitle mRcvd "received messages"
treeViewAppendColumn infoM mRcvd
rendererMRcvd <- cellRendererTextNew
cellLayoutPackStart mRcvd rendererMRcvd True
dataM <- listStoreNew []
-- newListStore skelM
-- insert machine data
inspectMachine (machinelist events) dataM
cellLayoutSetAttributes mId rendererMId dataM $ \row -> [ cellText := machId row ]
cellLayoutSetAttributes mTime rendererMTime dataM $ \row -> [ cellText := runtime row ]
cellLayoutSetAttributes mPrcs rendererMPrcs dataM $ \row -> [ cellText := numProcesses row ]
cellLayoutSetAttributes mSent rendererMSent dataM $ \row -> [ cellText := numSent row ]
cellLayoutSetAttributes mRcvd rendererMRcvd dataM $ \row -> [ cellText := numRcvd row ]
treeViewSetModel infoM dataM
treeViewColumnsAutosize infoM
-- Process information:
--skelP <- emptyListSkel
pMid <- treeViewColumnNew
treeViewColumnSetTitle pMid "on machine"
treeViewAppendColumn infoP pMid
rendererPMid <- cellRendererTextNew
cellLayoutPackStart pMid rendererPMid True
pId <- treeViewColumnNew
treeViewColumnSetTitle pId "process id"
treeViewAppendColumn infoP pId
rendererPId <- cellRendererTextNew
cellLayoutPackStart pId rendererPId True
pTime <- treeViewColumnNew
treeViewColumnSetTitle pTime "runtime (s)"
treeViewAppendColumn infoP pTime
rendererPTime <- cellRendererTextNew
cellLayoutPackStart pTime rendererPTime True
pTrds <- treeViewColumnNew
treeViewColumnSetTitle pTrds "threads"
treeViewAppendColumn infoP pTrds
rendererPTrds <- cellRendererTextNew
cellLayoutPackStart pTrds rendererPTrds True
pSent <- treeViewColumnNew
treeViewColumnSetTitle pSent "sent messages"
treeViewAppendColumn infoP pSent
rendererPSent <- cellRendererTextNew
cellLayoutPackStart pSent rendererPSent True
pRcvd <- treeViewColumnNew
treeViewColumnSetTitle pRcvd "received messages"
treeViewAppendColumn infoP pRcvd
rendererPRcvd <- cellRendererTextNew
cellLayoutPackStart pRcvd rendererPRcvd True
dataP <- listStoreNew []
inspectProcess (reverse $ processlist events) dataP
cellLayoutSetAttributes pMid rendererPMid dataP $ \row -> [ cellText := machIdP row ]
cellLayoutSetAttributes pId rendererPId dataP $ \row -> [ cellText := procId row ]
cellLayoutSetAttributes pTime rendererPTime dataP $ \row -> [ cellText := runtimeP row ]
cellLayoutSetAttributes pTrds rendererPTrds dataP $ \row -> [ cellText := numThreads row ]
cellLayoutSetAttributes pSent rendererPSent dataP $ \row -> [ cellText := numSentP row ]
cellLayoutSetAttributes pRcvd rendererPRcvd dataP $ \row -> [ cellText := numRcvdP row ]
treeViewSetModel infoP dataP
treeViewColumnsAutosize infoP
-- Thread information:
--skelT <- emptyListSkel
tMid <- treeViewColumnNew
treeViewColumnSetTitle tMid "on machine"
treeViewAppendColumn infoT tMid
rendererTMid <- cellRendererTextNew
cellLayoutPackStart tMid rendererTMid True
tPid <- treeViewColumnNew
treeViewColumnSetTitle tPid "in process"
treeViewAppendColumn infoT tPid
rendererTPid <- cellRendererTextNew
cellLayoutPackStart tPid rendererTPid True
tId <- treeViewColumnNew
treeViewColumnSetTitle tId "thread id"
treeViewAppendColumn infoT tId
rendererTId <- cellRendererTextNew
cellLayoutPackStart tId rendererTId True
tTime <- treeViewColumnNew
treeViewColumnSetTitle tTime "runtime (s)"
treeViewAppendColumn infoT tTime
rendererTTime <- cellRendererTextNew
cellLayoutPackStart tTime rendererTTime True
dataT <- listStoreNew []
cellLayoutSetAttributes tMid rendererTMid dataT $ \row -> [ cellText := machIdT row ]
cellLayoutSetAttributes tPid rendererTPid dataT $ \row -> [ cellText := procIdT row ]
cellLayoutSetAttributes tId rendererTId dataT $ \row -> [ cellText := thrdId row ]
cellLayoutSetAttributes tTime rendererTTime dataT $ \row -> [ cellText := runtimeT row ]
inspectThread (threadlist events) dataT
treeViewSetModel infoT dataT
treeViewColumnsAutosize infoT
where mt = starttimeByMachine events
inspectMachine (m:ms) store = do
let i = getIdM m
listStorePrepend store (MachineInfo {machId=("Machine " ++ show i),
runtime=(formatFloat (getEventTime (head $ eventlistM m) - (getStartTime i mt))),
numProcesses=(show $ totalProcesses m),
numSent=(show $ sentMessagesM m),
numRcvd=(show $ receivedMessagesM m)})
inspectMachine ms store
inspectMachine _ _ = return ()
inspectProcess :: [Process] -> ListStore ProcessInfo -> IO ()
--inspectProcess (((m,i),_,_,stat,evts):ps) store = do
inspectProcess (p:ps) store = do
let evts = eventlistP p
-- because of the processIDs being reused, there may be more then one
-- StartProcess-/KillProcess-Events in evts. One fkt. to find them all:
filterProcesses evts (totalThreads p, sentMessagesP p, receivedMessagesP p) (getEventTime (head evts)) 0 ""
where filterProcesses :: [ProcessEvent] -> (Int,Int,Int) -> Seconds -> Int -> String -> IO ()
filterProcesses (e:es) st@(t,s,r) killTime n l = case e of
KillProcess time (t',s',r') -> filterProcesses es (t',s',r') time (n+1) l
LabelProcess _ label -> filterProcesses es st killTime n label
NewProcess time -> do
listStoreAppend store (ProcessInfo {machIdP=(show $ pId2mId $ getIdP p),
procId=("Process " ++ show (pId $ getIdP p) ++ "/" ++ show n),
runtimeP=(formatFloat (killTime - time)),
numThreads= (show t),
numSentP= (show s),
numRcvdP= (show r)})
filterProcesses es st killTime n l
_ -> filterProcesses es st killTime n l
filterProcesses _ _ _ _ _ = inspectProcess ps store
inspectProcess _ _ = return ()
inspectThread (((pid,i),evts):ts) store = do
listStorePrepend store (ThreadInfo{ machIdT=(show $ pId2mId pid),
procIdT=if isSystemProcess pid then "System" else (show $ pId pid),
thrdId=("Thread " ++ show i),
runtimeT=(formatFloat (getEventTime (head evts) - (getEventTime (last evts))))})
inspectThread ts store
inspectThread _ _ = return ()
commaToNewline c
| c == ',' = '\n'
| otherwise = c
handleDragnDrop :: MVar ViewerState -> DrawingArea -> Events -> Double -> Double -> IO ()
handleDragnDrop st pic _ mx my = do
state <- readMVar st
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
--widgetQueueDrawArea pic (floor mx - 100) vy 200 vh
if mx > ulx && my > uly && mx < lrx && my < lry -- if my > uly && my < lry
then do win <- widgetGetDrawWindow pic
let oldpixbuf = oldView state :: Maybe Pixbuf
gc <- G.gcNew win
--redraw old portion of screen
case oldpixbuf of
Just pb -> drawPixbuf win gc pb 0 0 0 0 (-1) (-1) RgbDitherNormal 0 0
Nothing -> return ()
--drawWindowProcessUpdates win False
renderWithDrawable win $ do
--colorWhite
--rectangle (fromIntegral vx) lry (50) (uly-lry)
--fill
colorRedA
moveTo ((fromIntegral vx)+20) (my)
lineTo ((fromIntegral vx)+30) (my)
stroke
else return ()
performDragnDrop v st pic _ mx my = do
state <- takeMVar st
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
let matrix = case v of
2 -> matrixT state
1 -> matrixP state
_ -> matrixM state
ySkip = (lry - uly) / (fromIntegral (length matrix))
index = fromIntegral (floor (1 + ((my - uly) / ySkip)))
oldIndex = head $ sort $ selRow state
if null (selRow state)
then putMVar st state
else do
if index == oldIndex
then do
if deleteSel state
then do
(w,h) <- widgetGetSize pic
win <- widgetGetDrawWindow pic
let pLines = selRow state
skip' = round ySkip
putMVar st (state { selRow = [], deleteSel = False, noDND = False })
let pRects = map (\pLine -> Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)) pLines
sequence_ (map (\r -> drawWindowInvalidateRect win r False) pRects)
else putMVar st (state { deleteSel = False, noDND = False })
else if noDND state
then putMVar st (state { deleteSel = False, noDND = False })
else do
case v of
3 -> do
let arr = matrixGP state
ns = selRow state
(m,a) = handleMove (floor index) ns arr
putMVar st (state {selRow = m, matrixGP = a, deleteSel = False})
2 -> do
let arr = matrixT state
ns = selRow state
(m,a) = handleMove (floor index) ns arr
putMVar st (state {selRow = m, matrixT = a, deleteSel = False})
1 -> do
let arr = matrixP state
ns = selRow state
(m,a) = handleMove (floor index) ns arr
putMVar st (state {selRow = m, matrixP = a, deleteSel = False})
_ -> do
let arr = matrixM state
ns = selRow state
(m,a) = handleMove (floor index) ns arr
putMVar st (state {selRow = m, matrixM = a, deleteSel = False})
return ()
handleMouseMove :: MVar ViewerState -> MVar EdenTvState -> Bool -> DrawingArea -> Events -> Double -> Double -> IO ()
handleMouseMove st edentvState hideStartupPhase pic events mx my = do
-- events was (_,_,(maxStartupTimeInSeconds, _),_,(minT,maxT,maxST,_,_),_)
((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic
widgetQueueDrawArea pic (floor mx - 100) vy 200 vh
if mx > (fromIntegral vx + ulx) && my > uly && my < lry
then do
state <- readMVar st
let useDiff = locTime state
globalState <- readMVar edentvState
let colorsMap = colors globalState
-- if the startup-phase is not shown, adapt minT
let minT'
| hideStartupPhase = maxStartup events --in seconds
| otherwise = min_t events
let time
| useDiff = posToTime minT' (max_t events + max_t_diff events) ulx lrx mx
| otherwise = posToTime minT' (max_t events) ulx lrx mx
text = formatFloat time
win <- widgetGetDrawWindow pic
drawWindowProcessUpdates win False
renderWithDrawable win $ do
ext <- textExtents text
let dx = (\ (TextExtents _ _ w _ _ _) -> w) ext
lb = fromIntegral vx + ulx + 5
rb = fromIntegral (vx + vw) - (border + 2) - dx
x0 = mx - (dx/2) -- centered at mouse position
x1 = max x0 lb -- not over left border
xm = min x1 rb -- not over right border
getColor markerLine colorsMap
moveTo mx (fromIntegral vy + uly)
lineTo mx (fromIntegral (vy + vh - 5))
stroke
moveTo xm (fromIntegral vy + 15)
getColor markerLabel colorsMap
showText text
else return ()
removeElem :: (Eq a) => a -> [a] -> [a]
removeElem o (x:xs)
| o == x = xs
| otherwise = x : removeElem o xs
removeElem _ [] = []
handleButtonPress :: DrawingArea -> Int -> MVar ViewerState -> Event -> Events -> IO Bool
handleButtonPress pic v st e events = do
--events was ((m,p,t),mt,(mxs,mxst),_,(minT,maxT,maxST,_,maxD),_)
(_,(ulx,uly,lrx,lry)) <- getCorners pic
oldState <- readMVar st
let m = machinelist events
p = processlist events
t = threadlist events
minT = min_t events
maxT = max_t events
maxST = max_t_diff events
matrix = case v of
3 -> matrixGP oldState
2 -> matrixT oldState
1 -> matrixP oldState
_ -> matrixM oldState
ySkip = (lry - uly) / (fromIntegral (length matrix))
(mx,my) = (eventX e, eventY e)
line = if v /= 3
then fromIntegral (floor (1 + ((my - uly) / ySkip)))
else let y = my - uly
in findRow 0 y gpMachineOffsets
where findRow i y ((numP,numSkip):xs)
| y < (numP*procSkip + numSkip*10) = i
| otherwise = findRow (i+1) y xs
findRow i _ [] = i
numProcs :: [(MachineID, Int)]
numProcs = map (\m -> (getIdM m, totalProcesses m)) m
numM = fromIntegral $ length m
procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP oldState)))
sortedMachines = [(numM+1) - (posToMachine pos (matrixGP oldState)) | pos <- [1..numM]]
where 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
gpMachineOffsets = 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 _ [] = []
line' = elemIndex line matrix -- get position of selLine in matrix
elemIndex :: Eq a => a -> [a] -> Int
elemIndex = ei 0 -- start search at index 0
where ei :: Eq a => Int -> a -> [a] -> Int
ei i e (c:cs)
| e == c = i -- elem found at index i
| otherwise = ei (i+1) e cs -- not found yet
ei _ _ [] = -1 -- elem not found
--putStrLn $ "sort: " ++ (show (matrixGP oldState))
--putStrLn $ "sortedMachines: " ++ (show sortedMachines)
--putStrLn $ "machineOffsets: " ++ (show machineOffsets)
--putStrLn $ "line: " ++ (show line)
--putStrLn $ show $ map getIdP $ (filter (\proc -> getMIdFromP proc == getIdM (m!!line')) p)
--putStrLn $ "procSkip = " ++ show procSkip
--putStrLn $ "y = " ++ show (my - uly)
--putStrLn $ "line = " ++ show line
--putStrLn $ "gpMachineOffsets = " ++ show gpMachineOffsets
--putStrLn $ "multiplied gpMachineOffsets: " ++ show ((\(numP, numSkip) -> numP*procSkip + numSkip*10) (gpMachineOffsets !! (floor line - 1)))
--putStrLn $ "index: " ++ show (floor $ ((my - uly) - ((\(numP, numSkip) -> numP*procSkip + numSkip*10) (gpMachineOffsets !! (floor line - 1)))) / procSkip)
case eventButton e of
LeftButton -> if mx > ulx && my > uly && mx < lrx && my < lry
then do
state <- takeMVar st
(w,h) <- widgetGetSize pic
win <- widgetGetDrawWindow pic
let pLines = selRow oldState
skip' = round ySkip
--pRects = map (\pLine -> (pLine, Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2))) pLines
--rect0 = Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)
rect1 = Rectangle 0 (floor ((line-1)*ySkip + uly)-1) w (skip'+2)
if line `elem` pLines
then do if Shift `elem` (Graphics.UI.Gtk.Gdk.Events.eventModifier e)
then putMVar st (state { selRow = removeElem line pLines, noDND = True })
else do
putMVar st (state { deleteSel = True })
--putMVar st (state { selRow = [] })
--let pRects = map (\pLine -> Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)) pLines
--sequence_ (map (\r -> drawWindowInvalidateRect win r False) pRects)
drawWindowInvalidateRect win rect1 False
else do if Shift `elem` (Graphics.UI.Gtk.Gdk.Events.eventModifier e)
then putMVar st (state { selRow = (line:pLines), noDND = True })
else do
putMVar st (state { selRow = [line] })
let pRects = map (\pLine -> Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)) pLines
sequence_ (map (\r -> drawWindowInvalidateRect win r False) pRects)
--drawWindowInvalidateRect win rect0 False
drawWindowInvalidateRect win rect1 False
return True
else return True
MiddleButton -> return True
RightButton -> if mx > ulx && my > uly && my < lry
then do
let gpProcess = (filter (\proc -> getMIdFromP proc == selMachine) p)
!!
(floor $ ((my - uly) - ((\(numP, numSkip) -> numP*procSkip + numSkip*10) (gpMachineOffsets !! (floor line - 1)))) / procSkip)
tData = (\ (_,evts) -> evts) (t!!line')
pData = if v /= 3 then eventlistP (p!!line')
else eventlistP gpProcess
mData = eventlistM (m!!line')
(selMachine,selName) = case v of
3 -> (getIdM (m!!line'), 'P': show (getIdP gpProcess))
2 -> case t!!line' of ((pid,t),_) -> (pId2mId pid,'T': show pid ++ ':': show t)
1 -> let p' = getIdP (p!!line') in (pId2mId p','P': show p')
0 -> let m' = getIdM (m!!line') in (m','M': show m')
diffTime = (getStartTime selMachine $ startupOffsets events)
scaledTime :: Double -> String
scaledTime t = if locTime oldState
then formatFloat (t + diffTime)
else formatFloat (t - minT)
selTime = if locTime oldState
then (posToTime minT (maxT+maxST) ulx lrx mx) - diffTime
else (posToTime minT maxT ulx lrx mx) + minT
labelText = case (if v == 3 then 1 else v) of
2 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) tData) of
[NewThread s o] -> "New thread " ++ selName ++
"\nTime: " ++ (scaledTime s) ++
"\noutport: " ++ show o
[KillThread s] -> "Kill thread " ++ selName ++
"\nTime: " ++ (scaledTime s)
[RunThread s] -> "Run thread " ++ selName ++
"\nTime: " ++ (scaledTime s)
[SuspendThread s] -> "Suspend thread " ++ selName ++
"\nTime: " ++ (scaledTime s)
[BlockThread s i r] -> "Block thread " ++ selName ++
"\nTime: " ++ (scaledTime s) ++
"\nInport: " ++ show i ++
"\nReason: " ++ show r
[GCThread s g a c l]-> "Garbage collection " ++ selName ++
"\nTime: " ++ (scaledTime s) ++
"\nGeneration: " ++ show g ++
"\nAllocated: " ++ show a ++
"\nCollected: " ++ show c ++
"\nLive data: " ++ show l
_ -> "No event to show"
1 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) pData) of
[NewProcess s] -> "New process " ++ selName ++
"\nTime: " ++ (scaledTime s)
[KillProcess s _] -> "Kill process " ++ selName ++
"\nTime: " ++ (scaledTime s)
[IdleProcess s] -> "Idle process " ++ selName ++
"\nTime: " ++ (scaledTime s)
[RunningProcess s] -> "Running process " ++ selName ++
"\nTime: " ++ (scaledTime s)
[SuspendedProcess s] -> "Suspended process " ++ selName ++
"\nTime: " ++ (scaledTime s)
[BlockedProcess s] -> "Blocked process " ++ selName ++
"\nTime: " ++ (scaledTime s)
[GCProcess s g a c l]-> "Garbage collection " ++ selName ++
"\nTime: " ++ (scaledTime s) ++
"\nGeneration: " ++ show g ++
"\nAllocated: " ++ show a ++
"\nCollected: " ++ show c ++
"\nLive data: " ++ show l
_ -> "No event to show"
0 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) mData) of
[StartMachine s] -> "Start machine " ++ selName ++
"\nTime: " ++ (scaledTime s)
[EndMachine s] -> "End machine " ++ selName ++
"\nTime: " ++ (scaledTime s)
[GCMachine s g a c l]-> "Garbage collection " ++ selName ++
"\nTime: " ++ (scaledTime s) ++
"\nGeneration: " ++ show g ++
"\nAllocated: " ++ show a ++
"\nCollected: " ++ show c ++
"\nLive data: " ++ show l
[IdleMachine s] -> "Idle machine " ++ selName ++
"\nTime: " ++ (scaledTime s)
[RunningMachine s] -> "Running machine " ++ selName ++
"\nTime: " ++ (scaledTime s)
[SuspendedMachine s] -> "Suspended machine " ++ selName ++
"\nTime: " ++ (scaledTime s)
[BlockedMachine s] -> "Blocked machine " ++ selName ++
"\nTime: " ++ (scaledTime s)
_ -> "No event to show"
infoDlg <- dialogNew
windowSetTitle infoDlg "Event-info"
windowSetPosition infoDlg WinPosCenterOnParent
dialogAddButton infoDlg stockOk ResponseOk
upper <- dialogGetUpper infoDlg
infoText <- labelNew (Just labelText)
boxPackStartDefaults upper infoText
widgetShowAll infoDlg
dialogRun infoDlg
widgetDestroy infoDlg
return True
else return True
handleMove :: Int -> [Double] -> [Double] -> ([Double],[Double])
handleMove index moveRows allRows = result
where orderedMoveRows = map (\row -> 1 + (position (floor row) allRows) ) $ sort moveRows
len = length allRows
lenMoved = length moveRows
lenOther = length orderedOtherRows
orderedOtherRows = sortBy sortOther $ filterOther 1 allRows
sortOther :: Double -> Double -> Ordering
sortOther a b
| (allRows!!((floor a)-1)) < (allRows!!((floor b)-1)) = LT
| otherwise = GT
moveUp = head moveRows > (fromIntegral index)
placesBefore = if (index `mod` len) == 0
then 0
else (index - 1) `mod` len
placesAfter = if (index `mod` len) == 0
then (len - 1) `mod` len
else (len - placesBefore - lenMoved) `mod` len
filterOther i (x:xs)
| i `elem` orderedMoveRows = filterOther (i+1) xs
| otherwise = i : (filterOther (i+1) xs)
filterOther _ [] = []
process :: Int -> [Double] -> [Double]
process i (x:xs)
| (fromIntegral i) `elem` orderedMoveRows = (fromIntegral movPos ) : (process (i+1) xs)
| otherwise = (fromIntegral movPos') : (process (i+1) xs)
where movedRowOffset = position i orderedMoveRows
movPos = pos (index + movedRowOffset)
alteredRowOffset = position i orderedOtherRows
movPos' = if alteredRowOffset < placesBefore
then pos (1+alteredRowOffset)
else pos ( index + lenMoved + alteredRowOffset - placesBefore)
process _ [] = []
pos :: Int -> Int
pos x = ((x-1) `mod` len) + 1
position i (x:xs)
| (fromIntegral i) == x = 0
| otherwise = 1 + (position i xs)
position _ [] = 0
selection = map (fromIntegral . pos) [index..(index+lenMoved-1)]
result = (selection, process 1 allRows)
handleMoveUp :: DrawingArea -> Int -> MVar ViewerState -> IO ()
handleMoveUp pic i st = do
state <- takeMVar st
((x,_,w,_),(ulx,uly,lrx,lry)) <- getCorners pic
let ns = selRow state
if not $ null ns
then let n = head ns in case i of
3 -> do let arr = matrixGP state
rows = fromIntegral (length (arr))
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))-1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixGP = a})
widgetQueueDraw pic
2 -> do let arr = matrixT state
rows = fromIntegral (length (arr))
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))-1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixT = a})
widgetQueueDraw pic
1 -> do let arr = matrixP state
rows = fromIntegral (length (arr))
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))-1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixP = a})
widgetQueueDraw pic
_ -> do let arr = matrixM state
rows = fromIntegral (length (arr))
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))-1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixM = a})
widgetQueueDraw pic
else putMVar st state
shiftDown,shiftUp :: (Eq a, Num a) => a -> [a] -> [a]
shiftDown max (x:xs)
| x == max = 1 : shiftDown max xs
| otherwise = x + 1 : shiftDown max xs
shiftDown _ _ = []
shiftUp max (x:xs)
| x == 1 = max : shiftUp max xs
| otherwise = x - 1 : shiftUp max xs
shiftUp _ _ = []
handleMoveDown :: DrawingArea -> Int -> MVar ViewerState -> IO ()
handleMoveDown pic i st = do
state <- takeMVar st
(w,h) <- widgetGetSize pic
((x,_,w,_),(ulx,uly,lrx,lry)) <- getCorners pic
let ns = selRow state -- TODO hack
if not $ null ns
then case i of
3 -> do let arr = (matrixGP state)
rows = fromIntegral (length arr)
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))+1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixGP = a})
widgetQueueDraw pic
2 -> do let arr = (matrixT state)
rows = fromIntegral (length arr)
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))+1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixT = a})
widgetQueueDraw pic
1 -> do let arr = (matrixP state)
rows = fromIntegral (length arr)
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))+1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixP = a})
widgetQueueDraw pic
_ -> do let arr = (matrixM state)
rows = fromIntegral (length arr)
ySkip = (lry - uly) / rows
sortedRows = sort ns
ind = (floor (head sortedRows))+1
(m,a) = handleMove ind ns arr
putMVar st (state {selRow = m, matrixM = a})
widgetQueueDraw pic
else putMVar st state