diff --git a/CHANGES b/CHANGES
new file mode 100644
--- /dev/null
+++ b/CHANGES
@@ -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
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/hp2any-manager.cabal b/hp2any-manager.cabal
new file mode 100644
--- /dev/null
+++ b/hp2any-manager.cabal
@@ -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
diff --git a/src/Manager.hs b/src/Manager.hs
new file mode 100644
--- /dev/null
+++ b/src/Manager.hs
@@ -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 " "
+ (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
diff --git a/src/manager.glade b/src/manager.glade
new file mode 100644
--- /dev/null
+++ b/src/manager.glade
@@ -0,0 +1,207 @@
+
+
+
+
+
+
+
+ True
+
+
+ True
+
+
+
+ False
+ 0
+
+
+
+
+ True
+ True
+
+
+
+
+
+
+
+
+ 1
+
+
+
+
+ 0
+
+
+
+
+
+
+
+
+
+
+
+
+ 600
+ Loading profile
+ False
+ True
+
+
+ True
+
+
+ True
+ 15
+ 15
+ 15
+ 15
+
+
+ True
+ middle
+
+
+
+
+ False
+ 0
+
+
+
+
+ True
+ 1
+ 0.10000000149011612
+ 15
+ 15
+
+
+ gtk-cancel
+ True
+ True
+ True
+ True
+
+
+
+
+ False
+ 1
+
+
+
+
+
+
+