hp2any-manager (empty) → 0.4.1
raw patch · 7 files changed
+1011/−0 lines, 7 filesdep +OpenGLdep +arraydep +basesetup-changed
Dependencies added: OpenGL, array, base, bytestring, cairo, containers, filepath, glade, glib, gtk, gtkglext, hp2any-core, hp2any-graph, time
Files
- CHANGES +17/−0
- LICENSE +28/−0
- README +27/−0
- Setup.hs +2/−0
- hp2any-manager.cabal +32/−0
- src/Manager.hs +698/−0
- src/manager.glade +207/−0
+ CHANGES view
@@ -0,0 +1,17 @@+0.4.1 - 090811+* removed text rendering functions+* modified loadWidget to return query function (needs extensions)++0.4.0 - 090804+* added zooming and panning+* added coordinate (time and cost) display++0.3.0 - 090802+* added cost centre lists with hover indication+* added graph mode switching++0.2.0 - 090721+* improved loading: progress bar and ability to cancel++0.1.0 - 090717+* first release featuring bulk loading and visual rearrangement
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2009, Patai Gergely+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,27 @@+The hp2any history manager+==========================++The history manager is a simple application that can display heap+profiles of Haskell programs. Graphs are arranged like in a tiling+window manager. The main window is divided into columns, and each+column can hold several graphs. New columns can be added with the ++button on the right hand side, while each column can be closed with+its respective Close button at the top.++Heap profiles can be loaded by clicking the Open button at the bottom+of the column we want them to appear in. The open dialog has+multi-selection enabled. If more than one .hp file is selected, all of+them will be loaded in the same column.++Each graph has a header with some buttons. The first button brings up+a menu with some viewing options, the second and third can be used to+move the graph to neighbouring columns, and the last one closes the+file. Graphs can be zoomed in and out using the mouse wheel, and+navigated using the scroll bar below them. The view is automatically+zoomed to fit the highest point of the graph section shown. The actual+coordinates are shown on a tooltip.++Besides the graph, every profile window shows a list of cost+centres. The list can be reordered according to the total cost by+clicking on the header of the second column. As the mouse moves over+the graph, the corresponding item is highlighted in the list.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hp2any-manager.cabal view
@@ -0,0 +1,32 @@+Name: hp2any-manager+Version: 0.4.1+Cabal-Version: >= 1.2+Synopsis: A utility to visialise and compare heap profiles.+Category: profiling, development, utils+Description:++ This is a program that can display several heap profiles at the same+ time in the style of a tiling window manager.++Author: Patai Gergely+Maintainer: Patai Gergely (patai@iit.bme.hu)+Copyright: (c) 2009, Patai Gergely+License: BSD3+License-File: LICENSE+Stability: experimental+Build-Type: Simple+Data-Files:+ src/manager.glade++Extra-Source-Files:+ CHANGES+ README++Executable hp2any-manager+ Executable: hp2any-manager+ HS-Source-Dirs: src+ Main-IS: Manager.hs+ Build-Depends: base >= 4 && < 5, containers, array, filepath, time,+ glib, gtk, gtkglext, glade, cairo, OpenGL,+ bytestring, hp2any-core, hp2any-graph+ GHC-Options: -Wall -O2
+ src/Manager.hs view
@@ -0,0 +1,698 @@+{-# LANGUAGE ExistentialQuantification, ImpredicativeTypes #-}+{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-}++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Fix+import qualified Data.ByteString.Char8 as S+import Data.Array.MArray+import Data.IORef+import qualified Data.IntMap as IM+import Data.Maybe+import Data.List+import Data.Time.Clock+--import Graphics.Rendering.Cairo as C+import Graphics.Rendering.OpenGL as GL hiding (get,samples)+import Graphics.Rendering.OpenGL.GL.DisplayLists+import Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.Gdk.Events+import Graphics.UI.Gtk.Glade+import Graphics.UI.Gtk.OpenGL+import Profiling.Heap.OpenGL+import Profiling.Heap.Read+import Profiling.Heap.Types+import Profiling.Heap.Stats+import System.FilePath+import System.Glib.Types+import System.IO.Unsafe+import Text.Printf++import Paths_hp2any_manager (getDataFileName)++-- * OpenGL specific auxiliary functions++translate2 :: GLfloat -> GLfloat -> IO ()+translate2 x y = GL.translate $ Vector3 x y 0++scale2 :: GLfloat -> GLfloat -> IO ()+scale2 x y = GL.scale x y 1++-- * GTK specific auxiliary functions++{-| Flush the GTK event queue by running the necessary amount of main+loop iterations. -}++refresh :: IO ()+refresh = do+ count <- eventsPending+ replicateM_ count mainIteration+ when (count > 0) refresh++{-| Load the subtree of the UI description belonging to the widget of+the given name and return the function to extract widgets from it. -}++loadWidget :: String -> IO (forall w . WidgetClass w => (GObject -> w) -> String -> IO w)+loadWidget name = do+ fileName <- getDataFileName "src/manager.glade"+ xml <- fromMaybe (error ("Error loading widget " ++ name)) <$>+ xmlNewWithRootAndDomain fileName (Just name) Nothing+ return ((\cast name -> xmlGetWidget xml cast name) ::+ forall w . WidgetClass w => (GObject -> w) -> String -> IO w)++{-| Insert the widget before the last child of the given box. If+there's no last child, the insertion still happens. -}++addPenultimate :: (BoxClass box, WidgetClass widget) => widget -> box -> IO ()+addPenultimate child box = do+ children <- containerGetChildren box+ boxPackStart box child PackGrow 0++ unless (null children) $ do+ let lastChild = last children+ boxReorderChild box lastChild (-1)+ boxSetChildPacking box lastChild PackNatural 0 PackEnd++ widgetShowAll child++{-++-- Text rendering functions temporarily disabled...++{-| Create a surface with the given string rendered on it with a font+that hopefully matches the rest of the interface. When the surface is+not needed any more, it has to be explicitly disposed of by passing to+'surfaceFinish'. -}++renderString :: String -> IO Surface+renderString s = do+ -- Setting font+ ctx <- cairoCreateContext Nothing+ fontDesc <- contextGetFontDescription ctx+ fontDescriptionSetFamily fontDesc "Sans"+ contextSetFontDescription ctx fontDesc++ -- Setting resolution+ screenGetDefault >>= \s -> case s of+ Nothing -> return ()+ Just scr -> cairoContextSetResolution ctx =<< Gtk.get scr screenResolution++ -- Creating layout+ txt <- layoutText ctx s+ Rectangle _ _ w h <- snd <$> layoutGetPixelExtents txt++ -- Creating surface+ surface <- createImageSurface FormatARGB32 w h++ -- Rendering to surface+ renderWith surface $ showLayout txt++ return surface++renderSurface :: Surface -> GLWindow -> Int -> Int -> IO ()+renderSurface surface glWin x y = do+ buf <- pixbufFromImageSurface surface+ w <- imageSurfaceGetWidth surface+ h <- imageSurfaceGetHeight surface+ gc <- gcNew glWin+ drawPixbuf glWin gc buf 0 0 x y w h RgbDitherNone 0 0++-}++-- * Widget constructors++{-| Create a filter to be used in a file picking dialog from a list of+textual description-wildcard pairs. -}++makeFileFilters :: [(String,String)] -> IO [FileFilter]+makeFileFilters fs = forM fs $ \(name,pat) -> do+ f <- fileFilterNew+ fileFilterSetName f name+ fileFilterAddPattern f pat+ return f++{-| Create a multi-selection file chooser dialog specific to .hp+files. -}++makeProfileChooserDialog :: IO FileChooserDialog+makeProfileChooserDialog = do+ dialog <- fileChooserDialogNew (Just "Load profile") Nothing FileChooserActionOpen+ [(stockOpen,ResponseOk),(stockCancel,ResponseCancel)]+ mapM_ (fileChooserAddFilter dialog) =<< makeFileFilters [("Heap profiles","*.hp"),("All files","*")]+ fileChooserSetSelectMultiple dialog True++ return dialog++{-| The type of the action that sets the progress percentage. -}++type SetProgress = Double -> IO ()++{-| Create a progress bar window along with three auxiliary functions,+which can set the text of the progress bar, the percentage of the+progress and the action to be taken when the cancel button is pressed.+The window is always closed by the cancel button, regardless of the+action specified. -}++makeProgressWindow :: IO (Window, String -> IO (), SetProgress, IO () -> IO ())+makeProgressWindow = do+ getWidget <- loadWidget "progressWindow"++ progressWindow <- getWidget castToWindow "progressWindow"+ cancelButton <- getWidget castToButton "cancelProgressButton"+ progressBar <- getWidget castToProgressBar "progressBar"++ cancelActRef <- newIORef (return ())++ onClicked cancelButton $ do+ widgetDestroy progressWindow+ join (readIORef cancelActRef)++ return ( progressWindow+ , progressBarSetText progressBar+ , \n -> progressBarSetFraction progressBar n >> refresh+ , writeIORef cancelActRef+ )++{-| Create a new column to load graphs into. -}++makeColumn :: IO VBox+makeColumn = do+ column <- vBoxNew False 2+ closeButton <- buttonNewFromStock stockClose+ addButton <- buttonNewFromStock stockOpen+ boxPackStart column closeButton PackNatural 0+ boxPackEnd column addButton PackGrow 0++ -- Closing the column+ onClicked closeButton $ widgetDestroy column++ -- Adding a graph to the bottom of the column+ onClicked addButton $ do+ openDialog <- makeProfileChooserDialog+ widgetShow openDialog+ response <- dialogRun openDialog+ widgetHide openDialog++ when (response == ResponseOk) $ do+ loadHpFiles column =<< fileChooserGetFilenames openDialog++ widgetDestroy openDialog++ return column++{-| Create a scrollable and sortable list of colour-coded cost centres+to be shown next to the graph. -}++makeCostCentreList prof = do+ let modelData = zipWith modelSample (sort (integral prof)) (IM.assocs (ccNames prof))+ modelSample (ccid,cost) (_,ccname) = (ccid,ccname,cost)+ modelSize = length modelData++ getName (ccid,ccname,_) = colSquare ++ " " ++ escapeMarkup (S.unpack ccname)+ where Color3 r g b = colours !! (ccid+1)+ colSquare = printf "<span background=\"#%02x%02x%02x\"> </span>"+ (fromIntegral r :: Int) (fromIntegral g :: Int) (fromIntegral b :: Int)+ getCost (_,_,cost) = cost++ mainBox <- hBoxNew False 0+ model <- listStoreNew modelData+ sortable <- treeModelSortNewWithModel model+ tree <- treeViewNewWithModel sortable+ widgetSetSizeRequest tree 0 0++ scrollPos <- fromJust <$> treeViewGetVAdjustment tree+ scrollBar <- vScrollbarNew scrollPos+ + [nameColumn,costColumn] <- replicateM 2 treeViewColumnNew+ [nameRender,costRender] <- replicateM 2 cellRendererTextNew++ set nameRender [cellTextEllipsize := EllipsizeEnd]++ treeViewColumnPackStart nameColumn nameRender True+ treeViewColumnPackStart costColumn costRender True++ set nameColumn [ treeViewColumnTitle := "Name"+ , treeViewColumnExpand := True+ ]++ set costColumn [ treeViewColumnTitle := "Total cost"+ , treeViewColumnSortColumnId := 1+ ]++ treeSortableSetSortFunc sortable 1 $ \i1 i2 ->+ compare <$> (getCost <$> treeModelGetRow model i1)+ <*> (getCost <$> treeModelGetRow model i2)++ cellLayoutSetAttributes nameColumn nameRender model $ \ccdat -> [cellTextMarkup := Just (getName ccdat)]+ cellLayoutSetAttributes costColumn costRender model $ \ccdat -> [cellText := show (getCost ccdat)]++ mapM_ (treeViewAppendColumn tree) [nameColumn,costColumn]+ + onScroll tree $ \Scroll { eventDirection = dir } -> do+ let mult = case dir of+ ScrollUp -> -1+ ScrollDown -> 1+ _ -> 0+ + step <- (mult*) <$> adjustmentGetStepIncrement scrollPos + valMax <- (-) <$> adjustmentGetUpper scrollPos <*> adjustmentGetPageSize scrollPos+ adjustmentSetValue scrollPos =<< (\val -> min (step+val) valMax) <$> adjustmentGetValue scrollPos+ adjustmentValueChanged scrollPos+ return True++ boxPackStart mainBox tree PackGrow 0+ boxPackStart mainBox scrollBar PackNatural 0++ -- Select the cost centre with the given colour+ rgb <- newIORef backgroundColour+ selection <- treeViewGetSelection tree++ let selectRgb rgbNew = do+ rgbOld <- readIORef rgb+ when (rgbNew /= rgbOld) $ do+ writeIORef rgb rgbNew+ if (rgbNew == backgroundColour) || (rgbNew == otherColour) then+ treeSelectionUnselectAll selection+ else+ case findIndex (==rgbNew) (take (modelSize+2) colours) of+ Nothing -> return ()+ Just idx -> do+ Just iter <- treeModelGetIterFromString model (show (idx-1))+ iter' <- treeModelSortConvertChildIterToIter sortable iter+ treeSelectionSelectIter selection iter'++ return (mainBox,\r g b -> selectRgb (Color3 r g b))++{-| Create a scrollable and zoomable graph canvas that also supports+multiple viewing modes. -}++makeGraphCanvas selectRgb prof = do+ mainBox <- vBoxNew False 0++ let smps = prepareSamples prof+ tmin = minTime prof+ tmax = maxTime prof++ glCanvas <- glDrawingAreaNew glConfig+ widgetSetRedrawOnAllocate glCanvas True+ scrollBar <- hScrollbarNewDefaults+ scrollPos <- rangeGetAdjustment scrollBar++ boxPackStart mainBox glCanvas PackGrow 0+ boxPackStart mainBox scrollBar PackNatural 0++ set scrollPos [ adjustmentLower := tmin+ , adjustmentUpper := tmax+ , adjustmentValue := tmin+ , adjustmentPageSize := tmax-tmin+ ]++ graphRender <- newIORef []+ graphMode <- newIORef Accumulated++ let getInterval = do+ beg <- adjustmentGetValue scrollPos+ len <- adjustmentGetPageSize scrollPos+ return (beg,beg+len)++ getMaxCost = do+ mode <- readIORef graphMode+ (t1,t2) <- getInterval+ case mode of+ Accumulated -> return (maxCostTotalIvl prof t1 t2)+ Separate -> return (maxCostIvl prof t1 t2)++ -- Creation handler (called whenever the widget is removed and readded).+ onRealize glCanvas $ withGLDrawingArea glCanvas $ const $ do+ clearColor $= Color4 1 1 1 1+ + -- Display lists have to be rebuilt every time. They can't be+ -- migrated between different canvases, which is annoying.+ [accList,sepList] <- forM [Accumulated,Separate] $ \mode ->+ defineNewList Compile (renderSamples mode smps tmax)+ + let acc t1 t2 = do+ scale2 (realToFrac ((tmax-tmin)/(t2-t1)))+ (fromIntegral (maxCostTotal prof)/fromIntegral (maxCostTotalIvl prof t1 t2))+ translate2 (realToFrac ((tmin-t1)/(tmax-tmin))) 0+ callList accList+ sep t1 t2 = do+ GL.lineWidth $= 3+ scale2 (realToFrac ((tmax-tmin)/(t2-t1)))+ (fromIntegral (maxCost prof)/fromIntegral (maxCostIvl prof t1 t2))+ translate2 (realToFrac ((tmin-t1)/(tmax-tmin))) 0+ callList sepList+ + writeIORef graphRender [(Accumulated,acc),(Separate,sep)]++ -- We need to communicate with ourselves on dedicated channels,+ -- since there can be multiple OpenGL canvases interfering with each+ -- other.+ canvasSize <- newIORef (Size 0 0)++ let repaint = withGLDrawingArea glCanvas $ \glw -> do+ clear [ColorBuffer]+ + size <- readIORef canvasSize+ (t1,t2) <- getInterval++ viewport $= (Position 0 0,size)+ matrixMode $= Projection+ loadIdentity+ translate2 (-1) (-1)+ scale2 2 2+ matrixMode $= Modelview 0+ loadIdentity+ + renders <- readIORef graphRender+ mode <- readIORef graphMode++ case find ((==mode).fst) renders of+ Nothing -> return ()+ Just (_,r) -> preservingMatrix (r t1 t2)++ glDrawableSwapBuffers glw++ onSizeAllocate glCanvas $ \(Rectangle _ _ w h) -> do+ writeIORef canvasSize (Size (fromIntegral w) (fromIntegral h))++ -- Repaint handler, called after every resize for instance.+ onExpose glCanvas $ const $ repaint >> return True++ -- Managing the life cycle of the coordinate window.+ coordWindow <- windowNew+ set coordWindow [ windowDecorated := False+ , windowAcceptFocus := False+ , windowSkipPagerHint := True+ , windowSkipTaskbarHint := True+ , windowResizable := False+ ]+ windowSetKeepAbove coordWindow True+ coordLabel <- labelNew Nothing+ containerAdd coordWindow coordLabel ++ onDestroy glCanvas $ widgetDestroy coordWindow++ -- Displaying coordinate tooltip when entering the graph area.+ onEnterNotify glCanvas $ const $ do+ widgetShowAll coordWindow+ return True++ -- Hiding the coordinate display unless that was the very widget we+ -- left the canvas for.+ onLeaveNotify glCanvas $ \evt -> do+ let (x,y) = (floor (eventX evt),floor (eventY evt))+ Size w h <- readIORef canvasSize+ unless (x >= 0 && x < w && y >= 0 && y < h) $ widgetHideAll coordWindow+ return True++ -- Highlighting cost centre names on hover and displaying+ -- coordinates (time and cost).+ onMotionNotify glCanvas False $ \evt -> do+ let (x,y) = (floor (eventX evt),floor (eventY evt))++ -- Updating coordinate window.+ Size w h <- readIORef canvasSize++ windowMove coordWindow (floor (eventXRoot evt)+16) (floor (eventYRoot evt)+8)+ (t1,t2) <- getInterval+ c <- getMaxCost+ labelSetText coordLabel $ printf " time=%0.2f, cost=%d " (t1+eventX evt*(t2-t1)/fromIntegral w)+ ((fromIntegral h-fromIntegral y)*fromIntegral c `div` fromIntegral h :: Integer)++ -- Highlighting current cost centre under the mouse.+ withGLDrawingArea glCanvas $ \glw -> do+ mpb <- pixbufGetFromDrawable glw (Rectangle x y 1 1)+ case mpb of+ Nothing -> return ()+ Just buf -> do+ dat <- pixbufGetPixels buf :: IO (PixbufData Int GLubyte)+ r <- readArray dat 0+ g <- readArray dat 1+ b <- readArray dat 2+ selectRgb r g b++ return True++ -- Zooming with the mouse wheel.+ onScroll glCanvas $ \Scroll { eventX = x, eventDirection = dir } -> do+ Size w _ <- readIORef canvasSize+ (t1,t2) <- getInterval+ let t = t1 + x*len/(fromIntegral w)+ len = t2-t1+ len' = case dir of+ ScrollUp -> max 0.5 (len/1.5)+ ScrollDown -> min (tmax-tmin) (len*1.5)+ _ -> len++ when (len/=len') $ do+ set scrollPos [ adjustmentValue := min (tmax-len') $ max tmin $ t-len'/2+ , adjustmentPageSize := len'+ ]+ widgetQueueDraw glCanvas++ return True++ -- Panning with the scroll bar.+ onValueChanged scrollPos $ widgetQueueDraw glCanvas++ let toggleViewMode = do+ modifyIORef graphMode nextGraphMode+ widgetQueueDraw glCanvas+ readIORef graphMode++ return (mainBox,toggleViewMode,repaint >> widgetQueueDraw glCanvas)++-- Fast hack: run this bugger only once in order to reduce the chance+-- of hanging...+glConfig = unsafePerformIO $ glConfigNew [GLModeRGB,GLModeDouble]++{-| Create an OpenGL graph widget including a toolbar. The input is a+previously loaded heap profile and a function that can be used to+update a progress bar. The latter is used during the phase where the+raw profile data is preprocessed for rendering, and it expects numbers+between 0 and 1. -}++makeProfileGraph :: Profile -> IO VBox+makeProfileGraph prof = do+ getWidget <- loadWidget "graphWidget"+ getMenuWidget <- loadWidget "graphMenu"++ graphWidget <- getWidget castToVBox "graphWidget"++ let getAncestors = do+ column <- castToVBox . fromJust <$> widgetGetParent graphWidget+ window <- castToHBox . fromJust <$> widgetGetParent column+ return (column,window)+ stats = buildStats prof++ closeButton <- getWidget castToButton "closeButton"+ goLeftButton <- getWidget castToButton "goLeftButton"+ goRightButton <- getWidget castToButton "goRightButton"+ optionsButton <- getWidget castToButton "optionsButton"+ jobLabel <- getWidget castToLabel "jobLabel"+ graphPane <- getWidget castToHPaned "graphPane"++ graphMenu <- getMenuWidget castToMenu "graphMenu"++ labelSetText jobLabel $ job stats ++ " @ " ++ date stats++ -- It seems to randomly crap out at this point. :s+ -- But only if there is a text surface???+ -- gdk_gl_config_new_by_mode doesn't seem to return?+ -- glDrawableWait* calls in renderSurface don't help...+ --config <- glConfigNew [GLModeRGB,GLModeDouble]++ (ccList,ccSelectRgb) <- makeCostCentreList stats+ (graphCanvas,toggleViewMode,repaintCanvas) <- makeGraphCanvas ccSelectRgb stats++ panedPack1 graphPane graphCanvas True True+ panedPack2 graphPane ccList True True++ -- MonadFix helps us define a self-disconnecting signal. We don't+ -- know the size of the pane before it is exposed first, so we+ -- position the separator at that moment.+ mfix $ \sig -> onExpose graphPane $ const $ do+ columnWidth <- fst <$> (widgetGetSize =<< fst <$> getAncestors)+ panedSetPosition graphPane (columnWidth*2 `div` 3)+ signalDisconnect sig+ return False++ -- Resizing the column open button if this was the last graph+ let removeFromColumn column = do+ siblings <- containerGetChildren column+ -- 3: column close button, new graph button, and the last graph+ -- that's just about to be destroyed+ when (length siblings <= 3) $ do+ boxSetChildPacking column (last siblings) PackGrow 0 PackEnd++ containerRemove column graphWidget+ + onClicked closeButton $ do+ -- Removing the graph from the column+ --(column,_window) <- getAncestors+ --removeFromColumn column+ widgetDestroy graphWidget++ onClicked goLeftButton $ do+ (column,window) <- getAncestors++ let addLeft (cl:c:cs) | c == column = do+ removeFromColumn column+ addPenultimate graphWidget cl+ | otherwise = addLeft (c:cs)+ addLeft _ = return ()++ addLeft =<< map castToVBox . init <$> containerGetChildren window++ onClicked goRightButton $ do+ (column,window) <- getAncestors++ let addRight (c:cr:cs) | c == column = do+ removeFromColumn column+ addPenultimate graphWidget cr+ | otherwise = addRight (cr:cs)+ addRight _ = return ()++ addRight =<< map castToVBox . init <$> containerGetChildren window++ onClicked optionsButton $ menuPopup graphMenu Nothing++ showCostCentres <- getMenuWidget castToCheckMenuItem "showCostCentres"+ viewMode <- getMenuWidget castToMenuItem "viewMode"++ let showHideCcList = do+ c <- get showCostCentres checkMenuItemActive+ (if c then widgetShowAll else widgetHideAll) ccList++ updateViewMode mode = do+ label <- castToLabel . fromJust <$> binGetChild viewMode+ labelSetText label $ "View mode: " ++ case mode of+ Accumulated -> "accumulated"+ Separate -> "separate"++ onActivateLeaf showCostCentres showHideCcList++ onActivateLeaf viewMode (updateViewMode =<< toggleViewMode)++{-+ onButtonPress glCanvas $ \evt -> case evt of+ --Button { eventButton = RightButton, eventTime = t } -> do+ -- menuPopup graphMenu (Just (RightButton,t))+ -- return True+ --Button { eventButton = LeftButton, eventX = x, eventY = y } ->+ -- withGLDrawingArea glCanvas $ \glw -> do+ -- mpb <- pixbufGetFromDrawable glw (Rectangle (floor x) (floor y) 1 1)+ -- case mpb of+ -- Nothing -> return ()+ -- Just buf -> do+ -- dat <- pixbufGetPixels buf :: IO (PixbufData Int GLubyte)+ -- r <- readArray dat 0+ -- g <- readArray dat 1+ -- b <- readArray dat 2+ -- print (r,g,b)+ -- return True+ _ -> return False+-}++ onExpose graphWidget $ const $ showHideCcList >> return False++ -- This should happen automatically, but apparently it doesn't...+ onSizeAllocate graphWidget $ const $ repaintCanvas++ updateViewMode Accumulated+ return graphWidget++-- * Program logic++{-| Load the given list of files into the specified column. The new+graphs will be created at the bottom. -}++loadHpFiles :: VBox -> [FilePath] -> IO ()+loadHpFiles column hpFiles = do+ let numFiles = length hpFiles++ when (numFiles > 0) $ do+ cancelled <- newIORef False+ let withCancelled act = readIORef cancelled >>= act+ (progWin,progString,progFrac,cancelHook) <- makeProgressWindow+ widgetShowAll progWin++ -- Load the files one by one+ forM_ (zip hpFiles [1..]) $ \(name,num) -> withCancelled $ \c -> unless c $ do+ progString $ takeFileName name ++ " (" ++ show (num :: Int) ++ "/" ++ show numFiles ++ ")"+ refresh+ + -- Initiate loading+ (queryProgress,stopLoading) <- readProfileAsync name+ + cancelHook $ do+ writeIORef cancelled True+ stopLoading++ tStart <- getCurrentTime++ -- Update the progress bar while loading+ profData <- fix $ \update -> do+ progress <- queryProgress+ case progress of+ Right res -> return res+ Left frac -> do+ progFrac (frac*0.5)+ threadDelay 50000+ update++ tEnd <- getCurrentTime++ -- Update a fake progress bar for the rest of the preparation,+ -- because the preparation of statistics cannot be truly+ -- monitored. We assume that it takes about the same time as+ -- loading, which is more or less realistic. This doesn't work+ -- in ghci by default, but it does in the compiled executable+ -- (note that -threaded is not allowed).+ ptid <- forkIO $ forever $ do+ t <- getCurrentTime+ progFrac . realToFrac $ 0.5+min 0.5+ (diffUTCTime t tEnd/(diffUTCTime tEnd tStart*2))+ threadDelay 50000++ -- Create the graph widget (more progress bar action)+ graph <- makeProfileGraph profData+ killThread ptid++ withCancelled $ \c -> if c+ then widgetDestroy graph+ else addPenultimate graph column++ widgetDestroy progWin++ return ()++-- * Entry point++main :: IO ()+main = do+ initGUI+ initGL++ mainWindow <- windowNew+ windowSetTitle mainWindow "Heap profile manager"+ onDestroy mainWindow mainQuit+ windowSetDefaultSize mainWindow 800 600+ mainColumns <- hBoxNew False 2+ containerAdd mainWindow mainColumns++ addColumnButton <- buttonNewWithLabel "+"+ boxPackEnd mainColumns addColumnButton PackNatural 0++ startColumn <- makeColumn+ boxPackStart mainColumns startColumn PackGrow 0++ onClicked addColumnButton $ do+ newColumn <- makeColumn+ boxPackStart mainColumns newColumn PackGrow 0+ boxReorderChild mainColumns addColumnButton (-1)+ widgetShowAll newColumn++ widgetShowAll mainWindow+ mainGUI
+ src/manager.glade view
@@ -0,0 +1,207 @@+<?xml version="1.0"?>+<glade-interface>+ <!-- interface-requires gtk+ 2.16 -->+ <!-- interface-naming-policy toplevel-contextual -->+ <widget class="GtkWindow" id="dummyWindow">+ <child>+ <widget class="GtkVBox" id="dummyContainer">+ <property name="visible">True</property>+ <child>+ <widget class="GtkVBox" id="graphWidget">+ <property name="visible">True</property>+ <child>+ <widget class="GtkHBox" id="graphHeader">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="jobLabel">+ <property name="width_request">0</property>+ <property name="height_request">0</property>+ <property name="visible">True</property>+ <property name="label" translatable="yes">job @ date</property>+ </widget>+ <packing>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="optionsButton">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <child>+ <widget class="GtkImage" id="image1">+ <property name="visible">True</property>+ <property name="stock">gtk-preferences</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="goLeftButton">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <child>+ <widget class="GtkImage" id="image2">+ <property name="visible">True</property>+ <property name="stock">gtk-go-back</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="goRightButton">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <child>+ <widget class="GtkImage" id="image3">+ <property name="visible">True</property>+ <property name="stock">gtk-go-forward</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">3</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="closeButton">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <child>+ <widget class="GtkImage" id="image4">+ <property name="visible">True</property>+ <property name="stock">gtk-close</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">5</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHPaned" id="graphPane">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ </widget>+ </child>+ </widget>+ <widget class="GtkWindow" id="progressWindow">+ <property name="width_request">600</property>+ <property name="title" translatable="yes">Loading profile</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <child>+ <widget class="GtkVBox" id="progressBox">+ <property name="visible">True</property>+ <child>+ <widget class="GtkAlignment" id="progressBarAlignment">+ <property name="visible">True</property>+ <property name="top_padding">15</property>+ <property name="bottom_padding">15</property>+ <property name="left_padding">15</property>+ <property name="right_padding">15</property>+ <child>+ <widget class="GtkProgressBar" id="progressBar">+ <property name="visible">True</property>+ <property name="ellipsize">middle</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkAlignment" id="progressActionAlignment">+ <property name="visible">True</property>+ <property name="xalign">1</property>+ <property name="xscale">0.10000000149011612</property>+ <property name="bottom_padding">15</property>+ <property name="right_padding">15</property>+ <child>+ <widget class="GtkButton" id="cancelProgressButton">+ <property name="label" translatable="yes">gtk-cancel</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+ <widget class="GtkMenu" id="graphMenu">+ <property name="visible">True</property>+ <child>+ <widget class="GtkCheckMenuItem" id="showCostCentres">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Show cost centres</property>+ <property name="use_underline">True</property>+ <property name="active">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="orderMode">+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="label" translatable="yes">Order mode</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="viewMode">+ <property name="visible">True</property>+ <property name="label" translatable="yes">View mode</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ </widget>+</glade-interface>