{- 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