Menu
▾
▴
[Gtk2hs-commit] (main branch): Move profileviewer demo to `gtk2hs/glade/demo.`
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:41
|
Sat May 1 17:13:35 EDT 2010 Andy Stewart <laz...@gm...>
* Move profileviewer demo to `gtk2hs/glade/demo.`
Ignore-this: 80f20961b905bca023b4813e7b99f2db
hunk ./demo/profileviewer/Makefile 1
-
-PROG = profileviewer
-SOURCES = ProfileViewer.hs ParseProfile.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/profileviewer/Makefile
hunk ./demo/profileviewer/ParseProfile.hs 1
--- Copyright (c) 2004 Duncan Coutts
--- This library is liscenced under the GNU General Public License version 2
--- or (at your option) any later version.
-
--- This is a not-terribly-clever parser for ghc's time profile log files.
-
-module ParseProfile (
- Profile(..),
- ProfileNode(..),
- parseProfileFile,
- pruneOnThreshold
-) where
-
-import Char
-import Maybe (catMaybes)
-
-data Profile = Profile {
- title :: String,
- command :: String,
- totalTime :: Float,
- totalAlloc :: Integer, --can be several GB
- breakdown :: ProfileNode
- }
-
-data ProfileNode = ProfileNode {
- costCentre :: String,
- moduleName :: String,
- entries :: !Int,
- individualTime :: !Int, --scaled by 10
- individualAlloc :: !Int, --scaled by 10
- inheritedTime :: !Int, --scaled by 10
- inheritedAlloc :: !Int, --scaled by 10
- children :: [ProfileNode]
- }
-
-pruneOnThreshold :: Int -> ProfileNode -> Maybe ProfileNode
-pruneOnThreshold threshold node
- | inheritedTime node >= threshold
- || inheritedAlloc node >= threshold =
- let children' = catMaybes $ map (pruneOnThreshold threshold) (children node)
- in Just $ node { children = children' }
- | otherwise = Nothing
-
-
-parseProfileFile :: String -> IO Profile
-parseProfileFile filename = do
- content <- readFile filename
- let (titleLine:_:commandLine:_:timeLine:allocLine:theRest) = lines content
- profileDetail = dropWhile (\line -> take 4 line /= "MAIN") theRest
- return $ Profile {
- title = dropWhile isSpace titleLine,
- command = dropWhile isSpace commandLine,
- totalTime = read $ words timeLine !! 3,
- totalAlloc = read $ filter (/=',') $ words allocLine !! 3,
- breakdown = parseProfile profileDetail
- }
-
--- intermediate form
-data ProfileEntry = ProfileEntry {
- depth :: !Int,
- ecostCentre :: String,
- emoduleName :: String,
- eentries :: !Int,
- eindividualTime :: !Int, --scaled by 10
- eindividualAlloc :: !Int, --scaled by 10
- einheritedTime :: !Int, --scaled by 10
- einheritedAlloc :: !Int --scaled by 10
- }
-
-parseProfile :: [String] -> ProfileNode
-parseProfile file =
- case (profileEntriesToProfile [] 0 . map parseProfileEntry) file of
- ([profile],[]) -> profile
- _ -> error "multiple top level entries"
-
-parseProfileEntry :: String -> ProfileEntry
-parseProfileEntry line =
- let depth = length (takeWhile (==' ') line)
- in case words line of
- [costCentre, moduleName, _, entries,
- individualTime, individualAlloc,
- inheritedTime, inheritedAlloc] ->
- ProfileEntry {
- depth = depth,
- ecostCentre = costCentre,
- emoduleName = moduleName,
- eentries = read entries,
- eindividualTime = floor $ (read individualTime) * 10,
- eindividualAlloc = floor $ (read individualAlloc) * 10,
- einheritedTime = floor $ (read inheritedTime) * 10,
- einheritedAlloc = floor $ (read inheritedAlloc) * 10 [_$_]
- }
- _ -> error $ "bad profile line:\n\t" ++ line
-
-profileEntriesToProfile :: [ProfileNode] -> Int -> [ProfileEntry] -> ([ProfileNode], [ProfileEntry])
-profileEntriesToProfile acum curDepth [] = (acum, [])
-profileEntriesToProfile acum curDepth (entry:entries)
- | depth entry == curDepth =
- let (children, remaining) = profileEntriesToProfile
- [] (depth entry + 1) entries
- curNode = ProfileNode {
- costCentre = ecostCentre entry,
- moduleName = emoduleName entry,
- entries = eentries entry,
- individualTime = eindividualTime entry,
- individualAlloc = eindividualAlloc entry,
- inheritedTime = einheritedTime entry,
- inheritedAlloc = einheritedAlloc entry,
- children = children
- }
- in profileEntriesToProfile (curNode:acum) (depth entry) remaining
- | depth entry < curDepth = (acum, entry:entries) --we're done for this level
- | otherwise = error "bad indentation in file"
rmfile ./demo/profileviewer/ParseProfile.hs
hunk ./demo/profileviewer/ProfileViewer.glade 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
-
-<glade-interface>
-
-<widget class="GtkWindow" id="mainWindow">
- <property name="visible">True</property>
- <property name="title" translatable="yes">GHC timing profile viewer</property>
- <property name="type">GTK_WINDOW_TOPLEVEL</property>
- <property name="window_position">GTK_WIN_POS_NONE</property>
- <property name="modal">False</property>
- <property name="default_width">650</property>
- <property name="default_height">400</property>
- <property name="resizable">True</property>
- <property name="destroy_with_parent">False</property>
-
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">0</property>
-
- <child>
- <widget class="GtkMenuBar" id="menubar1">
- <property name="visible">True</property>
-
- <child>
- <widget class="GtkMenuItem" id="menuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_File</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="menuitem1_menu">
-
- <child>
- <widget class="GtkImageMenuItem" id="openMenuItem">
- <property name="visible">True</property>
- <property name="label">gtk-open</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="separatormenuitem1">
- <property name="visible">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkImageMenuItem" id="quitMenuItem">
- <property name="visible">True</property>
- <property name="label">gtk-quit</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="view1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_View</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="view1_menu">
-
- <child>
- <widget class="GtkRadioMenuItem" id="allEntries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">All entries</property>
- <property name="use_underline">True</property>
- <property name="active">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="0.1%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 0.1% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="0.5%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 0.5% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="1%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 1% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="5%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 5% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="10%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 10% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="50%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 50% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="menuitem4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Help</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="menuitem4_menu">
-
- <child>
- <widget class="GtkMenuItem" id="aboutMenuItem">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_About</property>
- <property name="use_underline">True</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkTable" id="table1">
- <property name="border_width">5</property>
- <property name="visible">True</property>
- <property name="n_rows">4</property>
- <property name="n_columns">2</property>
- <property name="homogeneous">False</property>
- <property name="row_spacing">2</property>
- <property name="column_spacing">10</property>
-
- <child>
- <widget class="GtkLabel" id="label4">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Total time</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label4">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Total alloc</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="titleLabel">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">True</property>
- <property name="xalign">0</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- <property name="x_options">expand|shrink|fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="totalTimeLabel">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">True</property>
- <property name="xalign">0</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="totalAllocLabel">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">True</property>
- <property name="xalign">0</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label11">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Report</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label12">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Command</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="commandLabel">
- <property name="visible">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">True</property>
- <property name="selectable">False</property>
- <property name="xalign">0</property>
- <property name="yalign">0</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkScrolledWindow" id="scrolledwindow1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <property name="shadow_type">GTK_SHADOW_NONE</property>
- <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
-
- <child>
- <widget class="GtkTreeView" id="mainView">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="headers_visible">True</property>
- <property name="rules_hint">True</property>
- <property name="reorderable">False</property>
- <property name="enable_search">True</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkStatusbar" id="statusbar">
- <property name="visible">True</property>
- <property name="has_resize_grip">True</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
- </widget>
- </child>
-</widget>
-
-</glade-interface>
rmfile ./demo/profileviewer/ProfileViewer.glade
hunk ./demo/profileviewer/ProfileViewer.gladep 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-project SYSTEM "http://glade.gnome.org/glade-project-2.0.dtd">
-
-<glade-project>
- <name>ProfileViewer</name>
- <program_name>profileviewer</program_name>
- <gnome_support>FALSE</gnome_support>
-</glade-project>
rmfile ./demo/profileviewer/ProfileViewer.gladep
hunk ./demo/profileviewer/ProfileViewer.hs 1
--- Copyright (c) 2004 Duncan Coutts
--- This program is liscenced under the GNU General Public License version 2
--- or (at your option) any later version.
-
--- This is a slightly larger demo that combines use of glade, the file chooser
--- dialog, program state (IORefs) and use of the mogul tree view wrapper
--- interface. [_$_]
-
--- The program is a simple viewer for the log files that ghc produces when you
--- do time profiling. The parser is not very clever so loading large files can
--- take several seconds.
-
--- TODO: The gui will appear to hang when loading files. We should use threads
--- to keep the gui responsive.
-
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-import Graphics.UI.Gtk.ModelView as New
-
-import ParseProfile
-
-import Data.Maybe (isJust, fromJust)
-import Control.Monad (when)
-import Data.List (unfoldr, intersperse)
-import qualified Data.Tree as Tree
-import System.Environment (getArgs)
-import Data.IORef
-
-main :: IO ()
-main = do
- -- our global state
- thresholdVar <- newIORef 0 --current cuttoff/threshhold value
- profileVar <- newIORef Nothing --holds the current profile data structure
- [_$_]
- -- initialisation stuff
- initGUI
-
- Just dialogXml <- xmlNew "ProfileViewer.glade"
-
- -- get a handle on a various objects from the glade file
- mainWindow <- xmlGetWidget dialogXml castToWindow "mainWindow"
- onDestroy mainWindow mainQuit
-
- mainView <- xmlGetWidget dialogXml castToTreeView "mainView"
-
- titleLabel <- xmlGetWidget dialogXml castToLabel "titleLabel"
- commandLabel <- xmlGetWidget dialogXml castToLabel "commandLabel"
- totalTimeLabel <- xmlGetWidget dialogXml castToLabel "totalTimeLabel"
- totalAllocLabel <- xmlGetWidget dialogXml castToLabel "totalAllocLabel"
- [_$_]
- -- create the tree model
- store <- New.treeStoreNew []
- New.treeViewSetModel mainView store
-
- let createTextColumn name field = do
- column <- New.treeViewColumnNew
- New.treeViewAppendColumn mainView column
- New.treeViewColumnSetTitle column name
- cell <- New.cellRendererTextNew
- New.treeViewColumnPackStart column cell True
- New.cellLayoutSetAttributes column cell store
- (\record -> [New.cellText := field record])
-
- -- create the various columns in both the model and view
- createTextColumn "Cost Centre" costCentre
- createTextColumn "Module" moduleName
- createTextColumn "Entries" (show.entries)
- createTextColumn "Individual %time" (show.(/10).fromIntegral.individualTime)
- createTextColumn "Individual %alloc" (show.(/10).fromIntegral.individualAlloc)
- createTextColumn "Inherited %time" (show.(/10).fromIntegral.inheritedTime)
- createTextColumn "Inherited %alloc" (show.(/10).fromIntegral.inheritedAlloc)
-
- -- this action clears the tree model and then populates it with the
- -- profile contained in the profileVar, taking into account the current
- -- threshold value kept in the thresholdVar [_$_]
- let repopulateTreeStore = do
- profile <- readIORef profileVar
- maybe (return ()) repopulateTreeStore' profile
-
- repopulateTreeStore' profile = do
- New.treeStoreClear store
-
- titleLabel `labelSetText` (title profile)
- commandLabel `labelSetText` (command profile)
- totalTimeLabel `labelSetText` (show (totalTime profile) ++ " sec")
- totalAllocLabel `labelSetText` (formatNumber (totalAlloc profile) ++ " bytes")
- [_$_]
- threshold <- readIORef thresholdVar
- let node = if threshold > 0
- then pruneOnThreshold threshold (breakdown profile)
- else Just (breakdown profile)
- toTree :: ProfileNode -> Tree.Tree ProfileNode
- toTree = Tree.unfoldTree (\node -> (node, children node))
- case node of
- Nothing -> return ()
- Just node -> New.treeStoreInsertTree store [] 0 (toTree node)
-
- -- associate actions with the menus
- [_$_]
- -- the open menu item, opens a file dialog and then loads and displays
- -- the the profile (unless the user cancleled the dialog)
- openMenuItem <- xmlGetWidget dialogXml castToMenuItem "openMenuItem"
- openMenuItem `onActivateLeaf` do
- filename <- openFileDialog mainWindow
- when (isJust filename)
- (do profile <- parseProfileFile (fromJust filename)
- writeIORef profileVar (Just profile)
- repopulateTreeStore)
-
- quitMenuItem <- xmlGetWidget dialogXml castToMenuItem "quitMenuItem"
- quitMenuItem `onActivateLeaf` mainQuit
- [_$_]
- aboutMenuItem <- xmlGetWidget dialogXml castToMenuItem "aboutMenuItem"
- aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow
- [_$_]
- -- each menu item in the "View" menu sets the thresholdVar and re-displays
- -- the current profile
- let doThresholdMenuItem threshold itemName = do
- menuItem <- xmlGetWidget dialogXml castToMenuItem itemName
- menuItem `onActivateLeaf` do writeIORef thresholdVar threshold
- repopulateTreeStore
- mapM_ (uncurry doThresholdMenuItem)
- [(0, "allEntries"), (1, "0.1%Entries"), (5, "0.5%Entries"), (10, "1%Entries"),
- (50, "5%Entries"), (100, "10%Entries"), (500, "50%Entries")]
-
- -- Check the command line to see if a profile file was given
- commands <- getArgs
- when (not (null commands))
- (do profile <- parseProfileFile (head commands)
- writeIORef profileVar (Just profile)
- repopulateTreeStore)
-
- -- The final step is to display the main window and run the main loop
- widgetShowAll mainWindow
- mainGUI
-
-
--- display a standard file open dialog
-openFileDialog :: Window -> IO (Maybe String)
-openFileDialog parentWindow = do
- dialog <- fileChooserDialogNew
- (Just "Open Profile... ")
- (Just parentWindow)
- FileChooserActionOpen
- [("gtk-cancel", ResponseCancel)
- ,("gtk-open", ResponseAccept)]
- widgetShow dialog
- response <- dialogRun dialog
- widgetHide dialog
- case response of
- ResponseAccept -> fileChooserGetFilename dialog
- _ -> return Nothing
-
--- just to display a number using thousand seperators
--- eg "3,456,235,596"
-formatNumber :: Integer -> String
-formatNumber =
- reverse . concat . intersperse ","
- . unfoldr (\l -> case splitAt 3 l of
- ([], _) -> Nothing
- p -> Just p)
- . reverse . show
-
-showAboutDialog :: Window -> IO ()
-showAboutDialog parent = do
- -- create the about dialog
- aboutDialog <- aboutDialogNew
-
- -- set some attributes
- set aboutDialog [
- aboutDialogName := "profileviewer",
- aboutDialogVersion := "0.2",
- aboutDialogCopyright := "Duncan Coutts",
- aboutDialogComments := "A viewer for GHC time profiles.",
- aboutDialogWebsite := "http://haskell.org/gtk2hs/"
- ]
-
- -- make the about dialog appear above the main window
- windowSetTransientFor aboutDialog parent
-
- -- make the dialog non-modal. When the user closes the dialog destroy it.
- afterResponse aboutDialog $ \_ -> widgetDestroy aboutDialog
- widgetShow aboutDialog
rmfile ./demo/profileviewer/ProfileViewer.hs
rmdir ./demo/profileviewer
adddir ./glade/demo/profileviewer
addfile ./glade/demo/profileviewer/Makefile
hunk ./glade/demo/profileviewer/Makefile 1
+
+PROG = profileviewer
+SOURCES = ProfileViewer.hs ParseProfile.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./glade/demo/profileviewer/ParseProfile.hs
hunk ./glade/demo/profileviewer/ParseProfile.hs 1
+-- Copyright (c) 2004 Duncan Coutts
+-- This library is liscenced under the GNU General Public License version 2
+-- or (at your option) any later version.
+
+-- This is a not-terribly-clever parser for ghc's time profile log files.
+
+module ParseProfile (
+ Profile(..),
+ ProfileNode(..),
+ parseProfileFile,
+ pruneOnThreshold
+) where
+
+import Char
+import Maybe (catMaybes)
+
+data Profile = Profile {
+ title :: String,
+ command :: String,
+ totalTime :: Float,
+ totalAlloc :: Integer, --can be several GB
+ breakdown :: ProfileNode
+ }
+
+data ProfileNode = ProfileNode {
+ costCentre :: String,
+ moduleName :: String,
+ entries :: !Int,
+ individualTime :: !Int, --scaled by 10
+ individualAlloc :: !Int, --scaled by 10
+ inheritedTime :: !Int, --scaled by 10
+ inheritedAlloc :: !Int, --scaled by 10
+ children :: [ProfileNode]
+ }
+
+pruneOnThreshold :: Int -> ProfileNode -> Maybe ProfileNode
+pruneOnThreshold threshold node
+ | inheritedTime node >= threshold
+ || inheritedAlloc node >= threshold =
+ let children' = catMaybes $ map (pruneOnThreshold threshold) (children node)
+ in Just $ node { children = children' }
+ | otherwise = Nothing
+
+
+parseProfileFile :: String -> IO Profile
+parseProfileFile filename = do
+ content <- readFile filename
+ let (titleLine:_:commandLine:_:timeLine:allocLine:theRest) = lines content
+ profileDetail = dropWhile (\line -> take 4 line /= "MAIN") theRest
+ return $ Profile {
+ title = dropWhile isSpace titleLine,
+ command = dropWhile isSpace commandLine,
+ totalTime = read $ words timeLine !! 3,
+ totalAlloc = read $ filter (/=',') $ words allocLine !! 3,
+ breakdown = parseProfile profileDetail
+ }
+
+-- intermediate form
+data ProfileEntry = ProfileEntry {
+ depth :: !Int,
+ ecostCentre :: String,
+ emoduleName :: String,
+ eentries :: !Int,
+ eindividualTime :: !Int, --scaled by 10
+ eindividualAlloc :: !Int, --scaled by 10
+ einheritedTime :: !Int, --scaled by 10
+ einheritedAlloc :: !Int --scaled by 10
+ }
+
+parseProfile :: [String] -> ProfileNode
+parseProfile file =
+ case (profileEntriesToProfile [] 0 . map parseProfileEntry) file of
+ ([profile],[]) -> profile
+ _ -> error "multiple top level entries"
+
+parseProfileEntry :: String -> ProfileEntry
+parseProfileEntry line =
+ let depth = length (takeWhile (==' ') line)
+ in case words line of
+ [costCentre, moduleName, _, entries,
+ individualTime, individualAlloc,
+ inheritedTime, inheritedAlloc] ->
+ ProfileEntry {
+ depth = depth,
+ ecostCentre = costCentre,
+ emoduleName = moduleName,
+ eentries = read entries,
+ eindividualTime = floor $ (read individualTime) * 10,
+ eindividualAlloc = floor $ (read individualAlloc) * 10,
+ einheritedTime = floor $ (read inheritedTime) * 10,
+ einheritedAlloc = floor $ (read inheritedAlloc) * 10 [_$_]
+ }
+ _ -> error $ "bad profile line:\n\t" ++ line
+
+profileEntriesToProfile :: [ProfileNode] -> Int -> [ProfileEntry] -> ([ProfileNode], [ProfileEntry])
+profileEntriesToProfile acum curDepth [] = (acum, [])
+profileEntriesToProfile acum curDepth (entry:entries)
+ | depth entry == curDepth =
+ let (children, remaining) = profileEntriesToProfile
+ [] (depth entry + 1) entries
+ curNode = ProfileNode {
+ costCentre = ecostCentre entry,
+ moduleName = emoduleName entry,
+ entries = eentries entry,
+ individualTime = eindividualTime entry,
+ individualAlloc = eindividualAlloc entry,
+ inheritedTime = einheritedTime entry,
+ inheritedAlloc = einheritedAlloc entry,
+ children = children
+ }
+ in profileEntriesToProfile (curNode:acum) (depth entry) remaining
+ | depth entry < curDepth = (acum, entry:entries) --we're done for this level
+ | otherwise = error "bad indentation in file"
addfile ./glade/demo/profileviewer/ProfileViewer.glade
hunk ./glade/demo/profileviewer/ProfileViewer.glade 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="mainWindow">
+ <property name="visible">True</property>
+ <property name="title" translatable="yes">GHC timing profile viewer</property>
+ <property name="type">GTK_WINDOW_TOPLEVEL</property>
+ <property name="window_position">GTK_WIN_POS_NONE</property>
+ <property name="modal">False</property>
+ <property name="default_width">650</property>
+ <property name="default_height">400</property>
+ <property name="resizable">True</property>
+ <property name="destroy_with_parent">False</property>
+
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">0</property>
+
+ <child>
+ <widget class="GtkMenuBar" id="menubar1">
+ <property name="visible">True</property>
+
+ <child>
+ <widget class="GtkMenuItem" id="menuitem1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_File</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="menuitem1_menu">
+
+ <child>
+ <widget class="GtkImageMenuItem" id="openMenuItem">
+ <property name="visible">True</property>
+ <property name="label">gtk-open</property>
+ <property name="use_stock">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="separatormenuitem1">
+ <property name="visible">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkImageMenuItem" id="quitMenuItem">
+ <property name="visible">True</property>
+ <property name="label">gtk-quit</property>
+ <property name="use_stock">True</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="view1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_View</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="view1_menu">
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="allEntries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">All entries</property>
+ <property name="use_underline">True</property>
+ <property name="active">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="0.1%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 0.1% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="0.5%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 0.5% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="1%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 1% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="5%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 5% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="10%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 10% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="50%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 50% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="menuitem4">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_Help</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="menuitem4_menu">
+
+ <child>
+ <widget class="GtkMenuItem" id="aboutMenuItem">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_About</property>
+ <property name="use_underline">True</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkTable" id="table1">
+ <property name="border_width">5</property>
+ <property name="visible">True</property>
+ <property name="n_rows">4</property>
+ <property name="n_columns">2</property>
+ <property name="homogeneous">False</property>
+ <property name="row_spacing">2</property>
+ <property name="column_spacing">10</property>
+
+ <child>
+ <widget class="GtkLabel" id="label4">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Total time</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label4">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Total alloc</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="titleLabel">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">True</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ <property name="x_options">expand|shrink|fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="totalTimeLabel">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">True</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="totalAllocLabel">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">True</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label11">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Report</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label12">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Command</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="commandLabel">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">True</property>
+ <property name="selectable">False</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkScrolledWindow" id="scrolledwindow1">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+ <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+ <property name="shadow_type">GTK_SHADOW_NONE</property>
+ <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+ <child>
+ <widget class="GtkTreeView" id="mainView">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="headers_visible">True</property>
+ <property name="rules_hint">True</property>
+ <property name="reorderable">False</property>
+ <property name="enable_search">True</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkStatusbar" id="statusbar">
+ <property name="visible">True</property>
+ <property name="has_resize_grip">True</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+</widget>
+
+</glade-interface>
addfile ./glade/demo/profileviewer/ProfileViewer.gladep
hunk ./glade/demo/profileviewer/ProfileViewer.gladep 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-project SYSTEM "http://glade.gnome.org/glade-project-2.0.dtd">
+
+<glade-project>
+ <name>ProfileViewer</name>
+ <program_name>profileviewer</program_name>
+ <gnome_support>FALSE</gnome_support>
+</glade-project>
addfile ./glade/demo/profileviewer/ProfileViewer.hs
hunk ./glade/demo/profileviewer/ProfileViewer.hs 1
+-- Copyright (c) 2004 Duncan Coutts
+-- This program is liscenced under the GNU General Public License version 2
+-- or (at your option) any later version.
+
+-- This is a slightly larger demo that combines use of glade, the file chooser
+-- dialog, program state (IORefs) and use of the mogul tree view wrapper
+-- interface. [_$_]
+
+-- The program is a simple viewer for the log files that ghc produces when you
+-- do time profiling. The parser is not very clever so loading large files can
+-- take several seconds.
+
+-- TODO: The gui will appear to hang when loading files. We should use threads
+-- to keep the gui responsive.
+
+module Main where
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+import Graphics.UI.Gtk.ModelView as New
+
+import ParseProfile
+
+import Data.Maybe (isJust, fromJust)
+import Control.Monad (when)
+import Data.List (unfoldr, intersperse)
+import qualified Data.Tree as Tree
+import System.Environment (getArgs)
+import Data.IORef
+
+main :: IO ()
+main = do
+ -- our global state
+ thresholdVar <- newIORef 0 --current cuttoff/threshhold value
+ profileVar <- newIORef Nothing --holds the current profile data structure
+ [_$_]
+ -- initialisation stuff
+ initGUI
+
+ Just dialogXml <- xmlNew "ProfileViewer.glade"
+
+ -- get a handle on a various objects from the glade file
+ mainWindow <- xmlGetWidget dialogXml castToWindow "mainWindow"
+ onDestroy mainWindow mainQuit
+
+ mainView <- xmlGetWidget dialogXml castToTreeView "mainView"
+
+ titleLabel <- xmlGetWidget dialogXml castToLabel "titleLabel"
+ commandLabel <- xmlGetWidget dialogXml castToLabel "commandLabel"
+ totalTimeLabel <- xmlGetWidget dialogXml castToLabel "totalTimeLabel"
+ totalAllocLabel <- xmlGetWidget dialogXml castToLabel "totalAllocLabel"
+ [_$_]
+ -- create the tree model
+ store <- New.treeStoreNew []
+ New.treeViewSetModel mainView store
+
+ let createTextColumn name field = do
+ column <- New.treeViewColumnNew
+ New.treeViewAppendColumn mainView column
+ New.treeViewColumnSetTitle column name
+ cell <- New.cellRendererTextNew
+ New.treeViewColumnPackStart column cell True
+ New.cellLayoutSetAttributes column cell store
+ (\record -> [New.cellText := field record])
+
+ -- create the various columns in both the model and view
+ createTextColumn "Cost Centre" costCentre
+ createTextColumn "Module" moduleName
+ createTextColumn "Entries" (show.entries)
+ createTextColumn "Individual %time" (show.(/10).fromIntegral.individualTime)
+ createTextColumn "Individual %alloc" (show.(/10).fromIntegral.individualAlloc)
+ createTextColumn "Inherited %time" (show.(/10).fromIntegral.inheritedTime)
+ createTextColumn "Inherited %alloc" (show.(/10).fromIntegral.inheritedAlloc)
+
+ -- this action clears the tree model and then populates it with the
+ -- profile contained in the profileVar, taking into account the current
+ -- threshold value kept in the thresholdVar [_$_]
+ let repopulateTreeStore = do
+ profile <- readIORef profileVar
+ maybe (return ()) repopulateTreeStore' profile
+
+ repopulateTreeStore' profile = do
+ New.treeStoreClear store
+
+ titleLabel `labelSetText` (title profile)
+ commandLabel `labelSetText` (command profile)
+ totalTimeLabel `labelSetText` (show (totalTime profile) ++ " sec")
+ totalAllocLabel `labelSetText` (formatNumber (totalAlloc profile) ++ " bytes")
+ [_$_]
+ threshold <- readIORef thresholdVar
+ let node = if threshold > 0
+ then pruneOnThreshold threshold (breakdown profile)
+ else Just (breakdown profile)
+ toTree :: ProfileNode -> Tree.Tree ProfileNode
+ toTree = Tree.unfoldTree (\node -> (node, children node))
+ case node of
+ Nothing -> return ()
+ Just node -> New.treeStoreInsertTree store [] 0 (toTree node)
+
+ -- associate actions with the menus
+ [_$_]
+ -- the open menu item, opens a file dialog and then loads and displays
+ -- the the profile (unless the user cancleled the dialog)
+ openMenuItem <- xmlGetWidget dialogXml castToMenuItem "openMenuItem"
+ openMenuItem `onActivateLeaf` do
+ filename <- openFileDialog mainWindow
+ when (isJust filename)
+ (do profile <- parseProfileFile (fromJust filename)
+ writeIORef profileVar (Just profile)
+ repopulateTreeStore)
+
+ quitMenuItem <- xmlGetWidget dialogXml castToMenuItem "quitMenuItem"
+ quitMenuItem `onActivateLeaf` mainQuit
+ [_$_]
+ aboutMenuItem <- xmlGetWidget dialogXml castToMenuItem "aboutMenuItem"
+ aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow
+ [_$_]
+ -- each menu item in the "View" menu sets the thresholdVar and re-displays
+ -- the current profile
+ let doThresholdMenuItem threshold itemName = do
+ menuItem <- xmlGetWidget dialogXml castToMenuItem itemName
+ menuItem `onActivateLeaf` do writeIORef thresholdVar threshold
+ ...
[truncated message content] |
