ghcprofview (empty) → 0.1.0.0
raw patch · 15 files changed
+1403/−0 lines, 15 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, ghc-prof, gi-gtk, haskell-gi-base, regex-tdfa, regex-tdfa-text, scientific, text
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +74/−0
- Setup.hs +2/−0
- ghcprofview.cabal +57/−0
- src/Converter.hs +60/−0
- src/Gui.hs +65/−0
- src/Gui/Page.hs +205/−0
- src/Gui/TreeWidget.hs +105/−0
- src/Gui/Utils.hs +156/−0
- src/Json.hs +67/−0
- src/Loader.hs +27/−0
- src/Main.hs +64/−0
- src/Operations.hs +374/−0
- src/Types.hs +114/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for gtk3test++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Author name here nor the names of other+ 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.md view
@@ -0,0 +1,74 @@+ghcprofview README+==================++This is GHC `.prof` files viewer, implemented in Haskell + Gtk3.++Unlike [profiterole][1] and [profiteur][2], `ghcprofview` uses a traditional+approach to profiling. It allows you to view cost centres tree as it is and+browse it interactively, and allows you to do some actions that you may be used+to in, for example, Java's `visualvm`.++See also a very similar application in Python + Qt5 - [ghcprofview-py][3].++[1]: https://hackage.haskell.org/package/profiterole+[2]: https://hackage.haskell.org/package/profiteur+[3]: https://github.com/portnov/ghcprofview-py++++Features+--------++* GUI is tab-oriented. Default tab is called "All" and contains the whole tree.+ Other tabs may appear when you do filtering or some other actions. You may+ close unneeded tabs.+* Two additional columns in addition to what we have in standard GHC's text `.prof` output:+ * Time Relative: share of "Time Inherited" of this item with relation to it's+ parent item. For example, if this item has "Time Inherited" 20%, and it's+ parent has "Time Inherited" 30%, then "Time Relative" is 20% / 30% =+ 66.66%.+ * Alloc Relative: same, but about "Alloc Inherited".+* Click on column header to sort by that column.+* Right-click on table header to select which columns to display.+* Double-click at the edge of column header to adjust column width automatically.+* Use Search and Next buttons to search function by name. There are three+ search modes available: Contains (search by substring), Exact (search for+ exact match), Reg.Exp (search by regular expression).+* Use filters to display interesting records only. Filter results will be shown+ in separate tab.+ * Supported fields for filtering are: Entries, Time Individual, Alloc+ Individual, Time Inherited, Alloc Inherited, Module (by substring match),+ Source (by substring match).+ * Filter works by AND; so if you set Entries = 5, Module = "Gui", then you+ will be searching for items that have entries >= 5 AND in module "Gui".+ * Logic of filter application to the tree is the following: it keeps an item+ if that item conforms to filter conditions, OR if it has child items that+ conform to filter condition.+* "Narrow view to selected item" in right-click menu. This will open a tab and+ show only selected item and it's descendants.+* "Group all outgoing calls" in right-click menu. This does the following:+ * Searches for all occurences of selected function in the tree.+ * Merges call subtrees of these occurences into new tree; for example, if+ function "search" appeared in one place with "time inherited" of 15%, and+ in another place with 10%, then in the merged tree you will see it with+ 25%.+ * Displays the result in a new tab.+* "Group all incoming calls" in right-click menu. This does the following:+ * Searches for all occurences of selected function in the tree.+ * Reverses call stacks of found occurences and merges them into a new tree.+ So in that tree, the root will be the item you selected, and it's children+ will be all functions that call the selected function, and so on. Numbers+ are merged similar to "group all outgoing calls" function.+ * Displays the result in a new tab.+* Text format of `.prof` files is supported; there is support for Json format,+ but it is buggy currently.++Installation+------------++Install it by `stack`:++ $ git clone https://github.com/portnov/ghcprofview-hs.git+ $ cd ghcprofview-hs/+ $ stack install+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghcprofview.cabal view
@@ -0,0 +1,57 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: b1508baa3bc5a0e04f53b8a9b3d8f2faca0079ca881ff61113d2b31c5f472e93++name: ghcprofview+version: 0.1.0.0+synopsis: GHC .prof files viewer+description: Please see the README on GitHub at <https://github.com/portnov/ghcprofview-hs#readme>+category: Development+homepage: https://github.com/portnov/ghcprofview-hs#readme+bug-reports: https://github.com/portnov/ghcprofview-hs/issues+author: Ilya V. Portnov+maintainer: portnov84@rambler.ru+copyright: 2019 Ilya V. Portnov+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/portnov/ghcprofview-hs++executable ghcprofview+ main-is: Main.hs+ other-modules:+ Converter+ Gui+ Gui.Page+ Gui.TreeWidget+ Gui.Utils+ Json+ Loader+ Operations+ Types+ Paths_ghcprofview+ hs-source-dirs:+ src+ ghc-options: -threaded -rtsopts -fwarn-unused-imports -with-rtsopts=-N -O2+ build-depends:+ aeson+ , base >=4.7 && <5+ , containers+ , ghc-prof+ , gi-gtk+ , haskell-gi-base+ , regex-tdfa+ , regex-tdfa-text+ , scientific+ , text+ default-language: Haskell2010
+ src/Converter.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++module Converter where++import qualified GHC.Prof.Types as P -- ghc-prof package+import Data.Tree+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Scientific++import Types++convertCc :: P.Profile -> Tree P.CostCentre -> CostCentreData+convertCc profile node = go Nothing node+ where+ profile' = convertProfile profile+ go parent node =+ let cc = rootLabel node+ ccd = CostCentreData {+ ccdProfile = profile'+ , ccdParent = parent+ , ccdRecords = [+ ProfileRecord {+ prCcId = IndividualId $ P.costCentreNo cc+ , prEntries = P.costCentreEntries cc+ , prTicks = P.costCentreTicks cc+ , prAlloc = P.costCentreBytes cc+ , prTimeIndividual = Just $ toRealFloat $ P.costCentreIndTime cc+ , prAllocIndividual = Just $ toRealFloat $ P.costCentreIndAlloc cc+ , prTimeInherited = Just $ toRealFloat $ P.costCentreInhTime cc+ , prAllocInherited = Just $ toRealFloat $ P.costCentreInhAlloc cc+ }+ ]+ , ccdCostCentre = CostCentre {+ ccLabel = P.costCentreName cc+ , ccId = P.costCentreNo cc+ , ccModule = P.costCentreModule cc+ , ccSource = fromMaybe "<unknown>" $ P.costCentreSrc cc+ , ccIsCaf = "CAF:" `T.isPrefixOf` P.costCentreName cc+ }+ , ccdChildren = map (go (Just ccd)) (subForest node)+ }+ in ccd++convertProfile :: P.Profile -> Profile+convertProfile p = Profile {+ profileProgram = P.profileCommandLine p+ , profileTotalTime = 0+ , profileRtsArguments = []+ , profileInitCaps = 0+ , profileTickInterval = 0+ , profileTotalAlloc = P.totalAllocBytes $ P.profileTotalAlloc p+ , profileTotalTicks = P.totalTimeTicks $ P.profileTotalTime p+ , profileTree = error "profile tree was not read from .prof file"+ , profileTreeMap = IM.empty+ , profileCostCentres = IM.empty+ }+
+ src/Gui.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Gui where++import qualified Data.Text as T () -- instances only+import Data.Int++import Data.GI.Base.GType+import Data.GI.Base.GValue++import Types+import Operations+import Gui.TreeWidget++treeWidgetConfig :: TreeWidgetConfig CostCentreData+treeWidgetConfig =+ TreeWidgetConfig {+ twcColumns = [+ Column "No" gtypeString TextColumn (toGValue . Just . ccdRecordIds), -- 0+ Column "Name" gtypeString TextColumn (toGValue . Just . ccdLabel), -- 1+ Column "Entries" gtypeInt64 TextColumn (toGValue . ccdEntries), -- 2+ Column "Individual Time" gtypeDouble PercentColumn (toGValue . ccdTimeIndividual), -- 3+ Column "Individual Alloc" gtypeDouble PercentColumn (toGValue . ccdAllocIndividual), -- 4+ Column "Inherited Time" gtypeDouble PercentColumn (toGValue . ccdTimeInherited), -- 5+ Column "Inherited Alloc" gtypeDouble PercentColumn (toGValue . ccdAllocInherited), -- 6+ Column "Relative Time" gtypeDouble PercentColumn (toGValue . ccdTimeRelative), -- 7+ Column "Relative Alloc" gtypeDouble PercentColumn (toGValue . ccdAllocRelative), -- 8+ Column "Module" gtypeString TextColumn (toGValue . Just . ccdModule), -- 9+ Column "Source" gtypeString TextColumn (toGValue . Just . ccdSource) -- 10+ ]+ }++noColumn :: Int32+noColumn = 0++nameColumn :: Int32+nameColumn = 1++entriesColumn :: Int32+entriesColumn = 2++individualTimeColumn :: Int32+individualTimeColumn = 3++individualAllocColumn :: Int32+individualAllocColumn = 4++inheritedTimeColumn :: Int32+inheritedTimeColumn = 5++inheritedAllocColumn :: Int32+inheritedAllocColumn = 6++relativeTimeColumn :: Int32+relativeTimeColumn = 7++relativeAllocColumn :: Int32+relativeAllocColumn = 8++moduleColumn :: Int32+moduleColumn = 9++sourceColumn :: Int32+sourceColumn = 10+
+ src/Gui/Page.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}++module Gui.Page where++import Control.Monad+import qualified Data.Text as T+import Data.IORef++import GI.Gtk hiding (main)++import Gui+import Gui.TreeWidget+import Gui.Utils++import Types+import Operations++data Page = Page {+ pageWidget :: Box+ , pageSearchState :: IORef (Int, [TreePath])+ }++type ShowTree = T.Text -> CostCentreData -> IO ()++mkContextMenu :: TreeView -> CostCentreData -> ShowTree -> IO Menu+mkContextMenu tree ccd showTree = do+ menu <- menuNew++-- mkMenuItem menu "Test" $ do+-- withSelected tree $ \store selected -> do+-- Just name <- getItem store selected nameColumn+-- print (name :: T.Text)+-- Just mod <- getItem store selected moduleColumn+-- Just src <- getItem store selected sourceColumn+-- let subtrees = ccdFind mod src name ccd+-- forM_ subtrees $ \child -> do+-- let parent = case ccdParent child of+-- Nothing -> "no parent"+-- Just parent -> T.pack (ccdRecordIds parent) <> ": " <> ccdLabel parent <> " = " <> T.pack (show $ ccdTimeInherited parent)+-- print $ T.pack (ccdRecordIds child) <> ": " <> ccdLabel child <> " = " <> T.pack (show $ ccdTimeInherited child) <> " => " <> parent++ mkMenuItem menu "Narrow view to this item" $ do+ withSelected tree $ \store selected -> do+ path <- getTruePath store selected+ Just idxs <- treePathGetIndices path+ case ccdByPath idxs ccd of+ Nothing -> return ()+ Just child -> do+ let label = ccdLabel child+ showTree ("Narrowed view: " <> label) child++ mkMenuItem menu "Group all outgoing calls" $+ withSelected tree $ \store selected -> do+ Just name <- getItem store selected nameColumn+ Just mod <- getItem store selected moduleColumn+ Just src <- getItem store selected sourceColumn+ let subtrees = ccdFind mod src name ccd+ result = ccdSum subtrees+ showTree ("Calls of " <> name) result++ mkMenuItem menu "Group all incoming calls" $+ withSelected tree $ \store selected -> do+ Just name <- getItem store selected nameColumn+ Just mod <- getItem store selected moduleColumn+ Just src <- getItem store selected sourceColumn+ let subtrees = ccdFindIncoming mod src name ccd+ result = ccdSum subtrees+ showTree ("Calls to " <> name) result+ + return menu++mkPage :: Statusbar -> T.Text -> CostCentreData -> ShowTree -> IO Page+mkPage status label ccd showTree = do+ vbox <- boxNew OrientationVertical 0+ searchHbox <- boxNew OrientationHorizontal 0+ filterBox <- boxNew OrientationHorizontal 0++ entry <- searchEntryNew+ boxPackStart searchHbox entry True True 0+ searchButton <- buttonNewWithLabel "Search"+ searchNextButton <- buttonNewWithLabel "Next"+ searchMethodCombo <- mkComboBox [+ (Contains, "Contains")+ , (Exact, "Exact")+ , (Regexp, "Reg.Exp")+ ]++ boxPackStart searchHbox searchButton False False 0+ boxPackStart searchHbox searchNextButton False False 0+ boxPackStart searchHbox searchMethodCombo False False 0+ boxPackStart vbox searchHbox False False 0++ on entry #activate $ buttonClicked searchButton++ let addFilterPercent name = do+ lbl <- labelNew (Just name)+ spin <- spinButtonNewWithRange 0 100 1+ spinButtonSetDigits spin 2+ boxPackStart filterBox lbl False False 10+ boxPackStart filterBox spin True True 0+ return spin++ let addFilterNumber name = do+ lbl <- labelNew (Just name)+ spin <- spinButtonNewWithRange 0 (1e38) 1+ spinButtonSetDigits spin 0+ boxPackStart filterBox lbl False False 10+ boxPackStart filterBox spin True True 0+ return spin++ let addFilterText name = do+ lbl <- labelNew (Just name)+ entry <- entryNew+ boxPackStart filterBox lbl False False 10+ boxPackStart filterBox entry True True 0+ return entry++ fltrEntries <- addFilterNumber "Entries:"+ fltrTimeIndividual <- addFilterPercent "Time Individual:"+ fltrAllocIndividual <- addFilterPercent "Alloc Individual:"+ fltrTimeInherited <- addFilterPercent "Time Inherited:"+ fltrAllocInherited <- addFilterPercent "Alloc Inherited:"+ fltrModule <- addFilterText "Module:"+ fltrSource <- addFilterText "Source:"++ filterButton <- buttonNewWithLabel "Filter"++ boxPackStart filterBox filterButton False False 0+ boxPackStart vbox filterBox False False 0++ tree <- mkTreeView treeWidgetConfig ccd+ treeViewSetSearchColumn tree 1+ treeViewSetEnableSearch tree False+ let noAdjustment = Nothing :: Maybe Adjustment+ scroll <- scrolledWindowNew noAdjustment noAdjustment+ containerAdd scroll tree+ boxPackStart vbox scroll True True 10++ statusContext <- statusbarGetContextId status label++ searchResults <- newIORef (0, [])++ let message text =+ void $ statusbarPush status statusContext (T.pack text)++ on searchButton #clicked $ do+ text <- entryGetText entry+ unless (T.null text) $ do+ Just methodId <- comboBoxGetActiveId searchMethodCombo+ let method = read $ T.unpack methodId+ results <- treeSearch tree method text+ if null results+ then message "Not found."+ else do+ message $ "Found: " ++ show (length results)+ writeIORef searchResults (0, results)+ Just store <- treeViewGetModel tree+ let path = head results+ treeViewExpandToPath tree path+ treeViewSetCursor tree path (Nothing :: Maybe TreeViewColumn) False++ on searchNextButton #clicked $ do+ (prevIndex, results) <- readIORef searchResults+ if null results+ then message "Not found."+ else do+ let n = length results+ index = (prevIndex + 1) `mod` n+ path = results !! index+ message $ "Found: " ++ show index ++ "/" ++ show n+ writeIORef searchResults (index, results)+ treeViewExpandToPath tree path+ treeViewSetCursor tree path (Nothing :: Maybe TreeViewColumn) False++ on filterButton #clicked $ do+ entries <- spinButtonGetValueAsInt fltrEntries+ timeIndividual <- spinButtonGetValue fltrTimeIndividual+ allocIndividual <- spinButtonGetValue fltrAllocIndividual+ timeInherited <- spinButtonGetValue fltrTimeInherited+ allocInherited <- spinButtonGetValue fltrAllocInherited+ mod <- entryGetText fltrModule+ src <- entryGetText fltrSource++ let params = FilterParams {+ fpEntries = fromIntegral entries+ , fpTimeIndividual = timeIndividual+ , fpAllocIndividual = allocIndividual+ , fpTimeInherited = timeInherited+ , fpAllocInherited = allocInherited+ , fpModule = mod+ , fpSource = src+ }+ let ccd' = filterCcdRecursive (checkFilter params) ccd+ showTree "Filtered" ccd'++ on tree #buttonPressEvent $ \ev -> do+ button <- get ev #button+ when (button == 3) $ do+ menu <- mkContextMenu tree ccd showTree+ menuPopupAtPointer menu Nothing+ return False++ return $ Page vbox searchResults+
+ src/Gui/TreeWidget.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++module Gui.TreeWidget where++import Control.Monad+import qualified Data.Text as T++import Data.GI.Base.GType+import Data.GI.Base.GValue+import GI.Gtk ++import Types++data ColumnType =+ TextColumn+ | PercentColumn+ deriving (Eq, Show)++data Column a = Column {+ columnTitle :: T.Text+ , columnGType :: GType+ , columnType :: ColumnType+ , columnData :: a -> IO GValue+ }++newtype TreeWidgetConfig a = TreeWidgetConfig {+ twcColumns :: [Column a]+ }++mkTreeStore :: forall a t . IsTree t a => TreeWidgetConfig a -> t -> IO TreeStore+mkTreeStore cfg tree = do+ let columns = twcColumns cfg+ let gtypes = map columnGType columns+ store <- treeStoreNew gtypes+ fill store Nothing tree+ return store+ where+ fill :: TreeStore -> Maybe TreeIter -> t -> IO ()+ fill store root node = do+ let cc = treeRoot node+ item <- treeStoreInsert store root (negate 1)+ forM_ (zip [0..] (twcColumns cfg)) $ \(i, column) ->+ treeStoreSetValue store item i =<< columnData column cc+ forM_ (treeChildren node) $ fill store (Just item)+ +mkTreeView :: forall t a . IsTree t a => TreeWidgetConfig a -> t -> IO TreeView+mkTreeView cfg@(TreeWidgetConfig columns) tree = do+ srcStore <- mkTreeStore cfg tree+ store <- treeModelSortNewWithModel srcStore+ view <- treeViewNewWithModel store+ treeViewSetHeadersVisible view True+ forM_ (zip [0..] columns) $ \(i, column) ->+ addColumn view i (columnType column) (columnTitle column)++ return view+ where+ addColumn view i ctype title = do+ column <- treeViewColumnNew+ treeViewColumnSetTitle column title+ withRenderer ctype $ \renderer -> do+ treeViewColumnPackStart column renderer True+ let propName = getPropName ctype+ treeViewColumnAddAttribute column renderer propName i+ set column [ #resizable := True ]+ treeViewColumnSetSizing column TreeViewColumnSizingFixed+ treeViewColumnSetSortColumnId column i+ treeViewAppendColumn view column++ button <- treeViewColumnGetButton column+ on button #buttonPressEvent $ \ev -> do+ button <- get ev #button+ if button == 3+ then do+ menu <- mkColumnsMenu view+ menuPopupAtPointer menu Nothing+ return True+ else return False++ withRenderer :: ColumnType -> (forall r. IsCellRenderer r => r -> IO x) -> IO x+ withRenderer TextColumn f = cellRendererTextNew >>= f+ withRenderer PercentColumn f = cellRendererProgressNew >>= f++ getPropName TextColumn = "text"+ getPropName PercentColumn = "value"++mkColumnsMenu :: TreeView -> IO Menu+mkColumnsMenu tree = do+ menu <- menuNew+ columns <- treeViewGetColumns tree+ forM_ (zip [0..] columns) $ \(i, column) -> do+ title <- treeViewColumnGetTitle column+ item <- checkMenuItemNewWithLabel title+ menuShellAppend menu item+ widgetShow item+ visible <- treeViewColumnGetVisible column+ checkMenuItemSetActive item visible+ on item #activate $ do+ treeViewColumnSetVisible column (not visible)+ return menu+
+ src/Gui/Utils.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}++module Gui.Utils where++import Control.Monad+import qualified Data.Text as T+import Data.Int+import Data.IORef+import Text.Regex.TDFA+import Text.Regex.TDFA.Text () -- instances only++import Data.GI.Base.GValue+import GI.Gtk hiding (main)++import Types++iterChildren :: TreeModel+ -> TreeIter -- ^ Root+ -> (TreeIter -> IO (Bool, [a])) -- ^ Should return (whether to stop iterations; result)+ -> IO [a]+iterChildren store parent func = do+ (hasFirst, first) <- treeModelIterChildren store (Just parent)+ if not hasFirst+ then return []+ else go first+ where+ go iter = do+ (stop, results) <- func iter+ if stop+ then return results+ else do+ hasNext <- treeModelIterNext store iter+ if hasNext+ then do+ rest <- go iter+ return $ results ++ rest+ else return results++iterChildrenR :: TreeModel -> TreeIter -> (TreeIter -> IO (Bool, [a])) -> IO [a]+iterChildrenR store parent func = do+ childResults <- iterChildren store parent $ \child -> do+ (stop, result) <- func child+ if stop+ then return (True, [result])+ else do+ rest <- iterChildrenR store child func+ return (False, [result ++ rest])+ return $ concat childResults++treeSearch :: TreeView -> SearchMetohd -> T.Text -> IO [TreePath]+treeSearch view method needle = do+ Just store <- treeViewGetModel view+ (hasFirst, first) <- treeModelGetIterFirst store+ if not hasFirst+ then return []+ else iterChildrenR store first $ \child -> do+ found <- checkValue store child+ if found+ then do+ path <- treeModelGetPath store child+ return (False, [path])+ else return (False, [])+ where+ checkValue store row = do+ mbValue <- fromGValue =<< treeModelGetValue store row 1+ case mbValue of+ Nothing -> return False -- not ok+ Just value ->+ case method of+ Contains -> return $ needle `T.isInfixOf` value+ Exact -> return $ needle == value+ Regexp -> return $ value =~ needle++treeCheck :: TreeModel -> (TreeIter -> IO Bool) -> IO Bool+treeCheck store check = or <$> do+ (hasFirst, first) <- treeModelGetIterFirst store+ if not hasFirst+ then return []+ else iterChildrenR store first $ \child -> do+ found <- check child+ if found+ then return (True, [True])+ else return (False, [])++withSelected :: TreeView -> (TreeModel -> TreeIter -> IO ()) -> IO ()+withSelected tree fn = do+ (isSelected, store, selected) <- treeSelectionGetSelected =<< treeViewGetSelection tree+ when isSelected $ fn store selected++getTruePath :: TreeModel -> TreeIter -> IO TreePath+getTruePath top iter = do+ Just sorted <- castTo TreeModelSort top+ topPath <- treeModelGetPath top iter+ Just truePath <- treeModelSortConvertPathToChildPath sorted topPath+ return truePath++defFilterParams :: FilterParams+defFilterParams = FilterParams 0 0 0 0 0 "" ""++getItem :: IsGValue a => TreeModel -> TreeIter -> Int32 -> IO a+getItem store row col = + fromGValue =<< treeModelGetValue store row col++treeFilterFunc :: IORef FilterParams -> TreeModelFilterVisibleFunc+treeFilterFunc paramsRef store row = do+ params <- readIORef paramsRef+ hasChild <- treeModelIterHasChild store row+ good <- do+ entries <- getItem store row 2 :: IO Integer+ timeIndividual <- getItem store row 3+ allocIndividual <- getItem store row 4+ timeInherited <- getItem store row 5+ allocInherited <- getItem store row 6+ Just mod <- getItem store row 7+ Just src <- getItem store row 8+ return $+ entries >= fpEntries params &&+ timeIndividual >= fpTimeIndividual params &&+ allocIndividual >= fpAllocIndividual params &&+ timeInherited >= fpTimeInherited params &&+ allocInherited >= fpAllocInherited params &&+ fpModule params `T.isInfixOf` mod &&+ fpSource params `T.isInfixOf` src+ return $ hasChild || good++mkComboBox :: (Show a) => [(a, T.Text)] -> IO ComboBoxText+mkComboBox pairs = do+ combo <- comboBoxTextNew+ forM_ pairs $ \(value, title) -> do+ let id = T.pack (show value)+ comboBoxTextAppend combo (Just id) title+ comboBoxSetActive combo 0+ return combo++mkMenuItem :: Menu -> T.Text -> MenuItemActivateCallback -> IO ()+mkMenuItem menu label callback = do+ item <- menuItemNewWithLabel label+ menuShellAppend menu item+ on item #activate callback+ widgetShow item+ return ()++mkTabLabelWidget :: T.Text -> ButtonClickedCallback -> IO Box+mkTabLabelWidget text callback = do+ label <- labelNew (Just text)+ let size = fromIntegral $ fromEnum IconSizeMenu+ button <- buttonNewFromIconName (Just "window-close") size+ on button #clicked callback+ buttonSetRelief button ReliefStyleNone+ box <- boxNew OrientationHorizontal 0+ boxPackStart box label True True 0+ boxPackStart box button False False 0+ widgetShowAll box+ return box+
+ src/Json.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Json where++import Data.Aeson+import Data.Aeson.Types+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Tree++import Types++instance FromJSON Profile where+ parseJSON = withObject "profile" $ \v -> do+ program <- v .: "program"+ totalTime <- v .: "total_time"+ rtsArgs <- v .: "rts_arguments"+ initCaps <- v .: "initial_capabilities"+ tickInterval <- v .: "tick_interval"+ totalAlloc <- v .: "total_alloc"+ totalTicks <- v .: "total_ticks"+ profile <- explicitParseField parseTree v "profile"+ let profileTree = mkTreeMap profile+ costCentres <- mkMap <$> v .: "cost_centres"+ return $ Profile+ program+ totalTime+ rtsArgs+ initCaps+ tickInterval+ totalAlloc+ totalTicks+ profile+ profileTree+ costCentres++ where+ mkMap list = IM.fromList [(ccId r, r) | r <- list]++ mkTreeMap node = IM.fromList $ mkTreePairs node++ mkTreePairs node =+ (singleRecordId $ rootLabel node, node) : concatMap mkTreePairs (subForest node)++parseTree :: Value -> Parser (Tree (ProfileRecord Individual))+parseTree = withObject "record" $ \v -> do+ root <- ProfileRecord+ <$> (IndividualId <$> v .: "id")+ <*> v .: "entries"+ <*> v .: "ticks"+ <*> v .: "alloc"+ <*> return Nothing+ <*> return Nothing+ <*> return Nothing+ <*> return Nothing+ children <- explicitParseField (listParser parseTree) v "children"+ return $ Node root children++instance FromJSON CostCentre where+ parseJSON = withObject "cost_centre" $ \v -> CostCentre+ <$> v .: "label"+ <*> v .: "id"+ <*> v .: "module"+ <*> v .: "src_loc"+ <*> v .: "is_caf"+
+ src/Loader.hs view
@@ -0,0 +1,27 @@++module Loader where++import Data.Aeson (eitherDecodeFileStrict)+import qualified Data.Text.IO as TIO+import qualified GHC.Prof as P -- from ghc-prof package++import Types+import Converter+import Operations+import Json () -- instances only++loadProfile :: FilePath -> IO CostCentreData+loadProfile path = do+ r <- eitherDecodeFileStrict path+ case r of+ Left _ -> do+ text <- TIO.readFile path+ let r = P.decode' text+ case r of+ Left err -> fail err+ Right profile -> do + let Just centres = P.costCentres profile+ return $ convertCc profile centres++ Right profile -> return $ resolveProfile profile+
+ src/Main.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}+module Main (main) where++import qualified GI.Gtk as GI (main, init)+import GI.Gtk hiding (main)++import System.Environment++import Operations+import Loader+import Gui.Page+import Gui.Utils++main :: IO ()+main = do+ [path] <- getArgs+ treeData <- loadProfile path+ let treeData' = updateTotals $ filterCcd (not . ccdToIgnore) treeData+-- print $ profileTotalTicks $ ccdProfile treeData'+-- printTree treeData'+-- print $ ccdLabel `fmap` ccdByPath [0, 20] treeData'++ GI.init Nothing++ -- Create a new window+ window <- windowNew WindowTypeToplevel++ -- Here we connect the "destroy" event to a signal handler.+ onWidgetDestroy window mainQuit++ -- Sets the border width of the window.+ setContainerBorderWidth window 10+ vbox <- boxNew OrientationVertical 0++ notebook <- notebookNew+ status <- statusbarNew++ let showTree label ccd = do+ page <- pageWidget `fmap` mkPage status label ccd showTree+ widgetShowAll page+ labelWidget <- mkTabLabelWidget label $ do+ n <- notebookGetNPages notebook+ if n == 1+ then mainQuit+ else notebookDetachTab notebook page+ notebookAppendPage notebook page (Just labelWidget)+ return ()++ showTree "All" treeData'++ boxPackStart vbox notebook True True 0+ boxPackStart vbox status False False 0+ setContainerChild window vbox++ -- The final step is to display everything (the window and all the widgets+ -- contained within it)+ widgetShowAll window++ -- All Gtk+ applications must run the main event loop. Control ends here and+ -- waits for an event to occur (like a key press or mouse event).+ GI.main+
+ src/Operations.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+module Operations where++import Control.Monad+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Tree+import Data.Int+import Data.Maybe+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS++import Types++-- import Debug.Trace++(//) :: (Integral a, Fractional b) => a -> a -> b+x // y = fromIntegral x / fromIntegral y++fromSingletonSet :: IS.IntSet -> Id+fromSingletonSet set =+ if IS.size set == 1+ then head (IS.toList set)+ else error "fromSingletonSet for a non-singleton set"++resolveProfile :: Profile -> CostCentreData+resolveProfile p = go Nothing (profileTree p)+ where+ go parent node =+ let root = CostCentreData {+ ccdProfile = p+ , ccdParent = parent+ , ccdRecords = [rootLabel node]+ , ccdCostCentre = cc+ , ccdChildren = children+ }+ children = map (go (Just root)) (subForest node)+ IndividualId id = prCcId (rootLabel node)+ Just cc = IM.lookup id (profileCostCentres p)+ in root++withCostCentre :: (CostCentre -> a) -> CostCentreData -> a+withCostCentre fn ccd =+ fn (ccdCostCentre ccd)++toAggregated :: ProfileRecord Individual -> ProfileRecord Aggregated+toAggregated r@(ProfileRecord {prCcId = IndividualId id}) =+ r {prCcId = AggregatedId (IS.singleton id)}++summaryRecord :: CostCentreData -> ProfileRecord Aggregated+summaryRecord ccd = summary (ccdRecords ccd)+ where+ summary = foldr plus zero+ zero = ProfileRecord {+ prCcId = AggregatedId IS.empty+ , prEntries = 0+ , prTicks = Nothing+ , prAlloc = Nothing+ , prTimeIndividual = Nothing+ , prAllocIndividual = Nothing+ , prTimeInherited = Nothing+ , prAllocInherited = Nothing+ }++ plusN :: Num a => Maybe a -> Maybe a -> Maybe a+ plusN Nothing Nothing = Nothing+ plusN (Just x) Nothing = Just x+ plusN Nothing (Just y) = Just y+ plusN (Just x) (Just y) = Just (x+y)+ + plus :: ProfileRecord Individual -> ProfileRecord Aggregated -> ProfileRecord Aggregated+ plus r@(ProfileRecord {prCcId = IndividualId id}) agg@(ProfileRecord {prCcId = AggregatedId set})+ | id `IS.member` set = agg+ | otherwise = ProfileRecord {+ prCcId = AggregatedId (IS.insert id set)+ , prEntries = prEntries r + prEntries agg+ , prTicks = prTicks r `plusN` prTicks agg+ , prAlloc = prAlloc r `plusN` prAlloc agg+ , prTimeIndividual = prTimeIndividual r `plusN` prTimeIndividual agg+ , prAllocIndividual = prAllocIndividual r `plusN` prAllocIndividual agg+ , prTimeInherited = prTimeInherited r `plusN` prTimeInherited agg+ , prAllocInherited = prAllocInherited r `plusN` prAllocInherited agg+ }++ccdId :: CostCentreData -> (T.Text, T.Text, T.Text)+ccdId ccd = (ccdModule ccd, ccdSource ccd, ccdLabel ccd)++ccdPlus :: CostCentreData -> CostCentreData -> CostCentreData+ccdPlus c1 c2 = go (addParent (ccdParent c1) (ccdParent c2)) c1 c2+ where+ + go parent c1 c2 =+ let result = c1 {+ ccdParent = parent+ , ccdRecords = addRecords (ccdRecords c1) (ccdRecords c2)+ , ccdChildren = addChildren result (ccdChildren c1) (ccdChildren c2)+ }+ in result++ addParent Nothing Nothing = Nothing+ addParent (Just p) Nothing = Just p+ addParent Nothing (Just q) = Just q+ addParent (Just p) (Just q) = Just (ccdPlus p q)++ addRecords rs1 rs2 =+ let ids1 = IS.fromList (map singleRecordId rs1)+ rs2' = filter (\r -> singleRecordId r `IS.notMember` ids1) rs2+ in rs1 ++ rs2'++ addChildren parent cs1 cs2 =+ let zero :: M.Map (T.Text, T.Text, T.Text) CostCentreData+ zero = M.fromList [(ccdId c, c) | c <- cs1]++ plus :: CostCentreData -> M.Map (T.Text, T.Text, T.Text) CostCentreData -> M.Map (T.Text, T.Text, T.Text) CostCentreData+ plus c result = M.insertWith (go (Just parent)) (ccdId c) c result+ in M.elems $ foldr plus zero cs2++ccdSum :: [CostCentreData] -> CostCentreData+ccdSum list = foldr1 ccdPlus list++filterTree :: (a -> Bool) -> Tree a -> Tree a+filterTree good node = Node (rootLabel node) $ go (subForest node)+ where+ go [] = []+ go (node : nodes)+ | good (rootLabel node) =+ let node' = Node (rootLabel node) $ go (subForest node)+ in node' : go nodes+ | otherwise = go nodes++filterCcd :: (CostCentreData -> Bool) -> CostCentreData -> CostCentreData+filterCcd good node = node {ccdChildren = go (ccdChildren node)}+ where+ go [] = []+ go (node : nodes)+ | good node =+ let node' = node {ccdChildren = go (ccdChildren node)}+ in node' : go nodes+ | otherwise = go nodes++filterCcdRecursive :: (CostCentreData -> Bool) -> CostCentreData -> CostCentreData+filterCcdRecursive check node = node {ccdChildren = go (ccdChildren node)}+ where+ go [] = []+ go (node : nodes)+ | check node =+ let node' = node {ccdChildren = go (ccdChildren node)}+ in node' : go nodes+ | otherwise =+ let children' = go (ccdChildren node)+ node' = node {ccdChildren = children'}+ in if null children'+ then go nodes+ else node' : go nodes++ccdCheckRecursive :: (CostCentreData -> Bool) -> CostCentreData -> Bool+ccdCheckRecursive check ccd = go ccd+ where+ go ccd+ | check ccd = True+ | otherwise = any go (ccdChildren ccd)++timeIndividual :: Profile -> CostCentreData -> Double+timeIndividual p node =+ case prTimeIndividual (summaryRecord node) of+ Just value -> value+ Nothing ->+ case prTicks (summaryRecord node) of+ Nothing -> error "no individual time percentage and no ticks data provided"+ Just ticks -> 100 * ticks // profileTotalTicks p++ccdTimeIndividual :: CostCentreData -> Double+ccdTimeIndividual ccd = timeIndividual (ccdProfile ccd) ccd++allocIndividual :: Profile -> CostCentreData -> Double+allocIndividual p node =+ case prAllocIndividual (summaryRecord node) of+ Just value -> value+ Nothing ->+ case prAlloc (summaryRecord node) of+ Nothing -> error "no individual alloc percentage and no bytes data provided"+ Just bytes -> 100 * bytes // profileTotalAlloc p++ccdAllocIndividual :: CostCentreData -> Double+ccdAllocIndividual ccd = allocIndividual (ccdProfile ccd) ccd++timeInherited :: Profile -> CostCentreData -> Double+timeInherited p node =+ case prTimeInherited (summaryRecord node) of+ Just value -> value+ Nothing -> 100 * inheritedSum node // profileTotalTicks p+ where+ inheritedSum node =+ case prTicks (summaryRecord node) of+ Nothing -> error "no inherited time percentage and no ticks data provided"+ Just ticks -> ticks + sum (map inheritedSum $ ccdChildren node)++ticksInherited :: Profile -> CostCentreData -> Maybe Integer+ticksInherited p node = inheritedSum node+ where+ inheritedSum node = do+ individual <- prTicks (summaryRecord node) + children <- mapM inheritedSum $ ccdChildren node+ return $ individual + sum children++ccdTimeInherited :: CostCentreData -> Double+ccdTimeInherited ccd = timeInherited (ccdProfile ccd) ccd++ccdTicksInherited :: CostCentreData -> Maybe Integer+ccdTicksInherited ccd = ticksInherited (ccdProfile ccd) ccd++allocInherited :: Profile -> CostCentreData -> Double+allocInherited p node =+ case prAllocInherited (summaryRecord node) of+ Just value -> value+ Nothing -> 100 * inheritedSum node // profileTotalAlloc p+ where+ inheritedSum node =+ case prAlloc (summaryRecord node) of+ Nothing -> error "no inherited alloc percentage and no bytes data provided"+ Just bytes -> bytes + sum (map inheritedSum $ ccdChildren node)++ccdAllocInherited :: CostCentreData -> Double+ccdAllocInherited ccd = allocInherited (ccdProfile ccd) ccd++ccdTimeRelative :: CostCentreData -> Double+ccdTimeRelative ccd =+ case ccdParent ccd of+ Nothing -> 0+ Just parent ->+ let parentTime = ccdTimeInherited parent+ thisTime = ccdTimeInherited ccd+ result =+ if thisTime <= parentTime+ then if parentTime <= 1e-4+ then 0+ else 100 * thisTime / parentTime+ else if thisTime <= 1e-4+ then 0+ else 100 * parentTime / thisTime+ in -- trace (T.unpack (ccdLabel ccd) ++ ": this: " ++ show thisTime ++ ", parent: " ++ show parentTime ++ ", result = " ++ show result)+ result++ccdAllocRelative :: CostCentreData -> Double+ccdAllocRelative ccd =+ case ccdParent ccd of+ Nothing -> 0+ Just parent ->+ let parentAlloc = ccdAllocInherited parent+ thisAlloc = ccdAllocInherited ccd+ in if thisAlloc <= parentAlloc+ then if parentAlloc <= 1e-4+ then 0+ else 100 * thisAlloc / parentAlloc+ else if thisAlloc <= 1e-4+ then 0+ else 100 * parentAlloc / thisAlloc++ccdLabel :: CostCentreData -> T.Text+ccdLabel = withCostCentre ccLabel++ccdRecordIds :: CostCentreData -> String+ccdRecordIds ccd = show $ concatMap listRecordId (ccdRecords ccd)++ccdModule :: CostCentreData -> T.Text+ccdModule = withCostCentre ccModule++ccdSource :: CostCentreData -> T.Text+ccdSource = withCostCentre ccSource++ccdIsCaf :: CostCentreData -> Bool+ccdIsCaf = withCostCentre ccIsCaf++ccdToIgnore :: CostCentreData -> Bool+ccdToIgnore = withCostCentre $ \cc -> ccIsCaf cc || ccLabel cc `elem` [+ "OVERHEAD_of",+ "DONT_CARE",+ "GC",+ "SYSTEM",+ "IDLE"+ ]++ccdEntries :: CostCentreData -> Integer+ccdEntries ccd = prEntries (summaryRecord ccd)++calcTotals :: CostCentreData -> Maybe (Integer, Integer)+calcTotals ccd = calc ccd+ where+ calc node = do+ (childTicks_s, childAlloc_s) <- unzip <$> mapM calc (ccdChildren node)+ ticks <- prTicks (summaryRecord node) + alloc <- prAlloc (summaryRecord node) + return (ticks + sum childTicks_s, alloc + sum childAlloc_s)++updateTotals :: CostCentreData -> CostCentreData+updateTotals node =+ case calcTotals node of+ Nothing -> node+ Just (totalTicks, totalAlloc) ->+ let profile' = (ccdProfile node) {+ profileTotalTicks = totalTicks,+ profileTotalAlloc = totalAlloc+ }+ updateCcd ccd = ccd {+ ccdProfile = profile',+ ccdChildren = map updateCcd (ccdChildren ccd)+ }+ in updateCcd node++ccdFind :: T.Text -> T.Text -> T.Text -> CostCentreData -> [CostCentreData]+ccdFind mod src label ccd = go Nothing ccd+ where+ go parent ccd = self parent ccd ++ children parent ccd++ self parent ccd+ | ccdId ccd == (mod, src, label) = [ccd {ccdParent = parent}]+ | otherwise = []+ + children parent ccd =+ concatMap (go (Just ccd)) (ccdChildren ccd)++ccdFindIncoming :: T.Text -> T.Text -> T.Text -> CostCentreData -> [CostCentreData]+ccdFindIncoming mod src label ccd = map (reverseTree Nothing) $ ccdFind mod src label ccd+ where+ reverseTree parent ccd =+ let children = map (reverseTree (Just root)) $ maybeToList $ ccdParent ccd+ root = ccd {ccdParent = parent, ccdChildren = children}+ in root++ccdByIdStr :: String -> CostCentreData -> Maybe CostCentreData+ccdByIdStr idStr ccd+ | ccdRecordIds ccd == idStr = Just ccd+ | otherwise = go (ccdChildren ccd)+ where+ go [] = Nothing+ go (child : children) =+ case ccdByIdStr idStr child of+ Just found -> Just found+ Nothing -> go children++ccdByPath :: [Int32] -> CostCentreData -> Maybe CostCentreData+ccdByPath path ccd = go (tail path) ccd+ where+ go [] ccd = Just ccd+ go (ix : ixs) ccd+ | fromIntegral ix >= length (ccdChildren ccd) = Nothing+ | otherwise = go ixs (ccdChildren ccd !! fromIntegral ix)++checkFilter :: FilterParams -> CostCentreData -> Bool+checkFilter (FilterParams {..}) ccd =+ ccdEntries ccd >= fpEntries &&+ ccdTimeIndividual ccd >= fpTimeIndividual &&+ ccdAllocIndividual ccd >= fpAllocIndividual &&+ ccdTimeInherited ccd >= fpTimeInherited &&+ ccdAllocInherited ccd >= fpAllocInherited &&+ fpSource `T.isInfixOf` ccdSource ccd &&+ fpModule `T.isInfixOf` ccdModule ccd+ +printTree :: CostCentreData -> IO ()+printTree node = go 0 node+ where+ go i node = do+ let prefix = T.replicate i " "+ TIO.putStrLn $ prefix <>+ ccdLabel node <> "\t"+ <> T.pack (show $ ccdTicksInherited node) <> "\t"+ <> T.pack (show $ ccdTimeInherited node)+ forM_ (ccdChildren node) $ \child ->+ go (i+1) child+
+ src/Types.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Types where++import qualified Data.Text as T+import Data.Int+import Data.Tree+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Data.Scientific+-- import Data.Typeable+import Data.GI.Base.GValue++type Id = Int++class IsTree t a | t -> a where+ treeRoot :: t -> a+ treeChildren :: t -> [t]++data AggregateState = Individual | Aggregated+ deriving (Eq, Show)++data RecordId (a :: AggregateState) where+ IndividualId :: Id -> RecordId Individual+ AggregatedId :: IS.IntSet -> RecordId Aggregated++instance Show (RecordId a) where+ show (IndividualId id) = show id+ show (AggregatedId set) = show set++instance IsGValue Int where+ toGValue x = toGValue (fromIntegral x :: Int64)+ fromGValue v = fromIntegral `fmap` (fromGValue v :: IO Int64)++instance IsGValue Integer where+ toGValue x = toGValue (fromIntegral x :: Int64)+ fromGValue v = fromIntegral `fmap` (fromGValue v :: IO Int64)++instance IsGValue Scientific where+ toGValue x = toGValue (toRealFloat x :: Double)+ fromGValue v = fromFloatDigits `fmap` (fromGValue v :: IO Double)++data CostCentreData = CostCentreData {+ ccdProfile :: ! Profile+ , ccdParent :: Maybe CostCentreData+ , ccdRecords :: ! [ProfileRecord Individual]+ , ccdCostCentre :: ! CostCentre+ , ccdChildren :: ! [CostCentreData]+ }+ deriving (Show)++instance IsTree CostCentreData CostCentreData where+ treeRoot = id+ treeChildren = ccdChildren++data CostCentre = CostCentre {+ ccLabel :: ! T.Text+ , ccId :: ! Id+ , ccModule :: ! T.Text+ , ccSource :: ! T.Text+ , ccIsCaf :: ! Bool+ }+ deriving (Eq, Show)++data ProfileRecord s = ProfileRecord {+ prCcId :: ! (RecordId s)+ , prEntries :: ! Integer+ , prTicks :: ! (Maybe Integer) -- ^ If present in input file+ , prAlloc :: ! (Maybe Integer) -- ^ If present in input file+ , prTimeIndividual :: ! (Maybe Double) -- ^ If present in input file+ , prAllocIndividual :: ! (Maybe Double) -- ^ If present in input file+ , prTimeInherited :: ! (Maybe Double) -- ^ If present in input file+ , prAllocInherited :: ! (Maybe Double) -- ^ If present in input file+ }+ deriving (Show)++singleRecordId :: ProfileRecord Individual -> Id+singleRecordId r@(ProfileRecord {prCcId = IndividualId id}) = id++listRecordId :: ProfileRecord a -> [Id]+listRecordId (ProfileRecord {prCcId = IndividualId id}) = [id]+listRecordId (ProfileRecord {prCcId = AggregatedId set}) = IS.toList set++data Profile = Profile {+ profileProgram :: ! T.Text+ , profileTotalTime :: ! Double+ , profileRtsArguments :: ! [T.Text]+ , profileInitCaps :: ! Int32+ , profileTickInterval :: ! Int32+ , profileTotalAlloc :: ! Integer+ , profileTotalTicks :: ! Integer+ , profileTree :: Tree (ProfileRecord Individual)+ , profileTreeMap :: IM.IntMap (Tree (ProfileRecord Individual))+ , profileCostCentres :: IM.IntMap CostCentre+ }+ deriving (Show)++data FilterParams = FilterParams {+ fpEntries :: Integer+ , fpTimeIndividual :: Double+ , fpAllocIndividual :: Double+ , fpTimeInherited :: Double+ , fpAllocInherited :: Double+ , fpModule :: T.Text+ , fpSource :: T.Text+ }++data SearchMetohd = Contains | Exact | Regexp+ deriving (Eq, Show, Read, Enum, Bounded)+