diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for gtk3test + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + +![Screenshot](https://user-images.githubusercontent.com/284644/61590344-1a57ff80-abd1-11e9-93ce-dfc316c825ae.png) + +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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghcprofview.cabal b/ghcprofview.cabal new file mode 100644 --- /dev/null +++ b/ghcprofview.cabal @@ -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 +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 diff --git a/src/Converter.hs b/src/Converter.hs new file mode 100644 --- /dev/null +++ b/src/Converter.hs @@ -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 "" $ 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 + } + diff --git a/src/Gui.hs b/src/Gui.hs new file mode 100644 --- /dev/null +++ b/src/Gui.hs @@ -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 + diff --git a/src/Gui/Page.hs b/src/Gui/Page.hs new file mode 100644 --- /dev/null +++ b/src/Gui/Page.hs @@ -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 + diff --git a/src/Gui/TreeWidget.hs b/src/Gui/TreeWidget.hs new file mode 100644 --- /dev/null +++ b/src/Gui/TreeWidget.hs @@ -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 + diff --git a/src/Gui/Utils.hs b/src/Gui/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Gui/Utils.hs @@ -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 + diff --git a/src/Json.hs b/src/Json.hs new file mode 100644 --- /dev/null +++ b/src/Json.hs @@ -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" + diff --git a/src/Loader.hs b/src/Loader.hs new file mode 100644 --- /dev/null +++ b/src/Loader.hs @@ -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 + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + diff --git a/src/Operations.hs b/src/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Operations.hs @@ -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 + diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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) +