├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── debian ├── changelog ├── compat ├── control ├── copyright ├── ghcprofview.debhelper.log ├── ghcprofview.dirs ├── ghcprofview.install ├── ghcprofview.substvars ├── rules ├── source │ ├── format │ └── options └── watch ├── docker ├── .dockerignore ├── Dockerfile.ubuntu ├── build-ubuntu-package.sh ├── builder-entrypoint.sh └── debian-entrypoint.sh ├── package.yaml ├── prepare_debian_package.sh ├── src ├── Converter.hs ├── Gui.hs ├── Gui │ ├── Page.hs │ ├── TreeWidget.hs │ └── Utils.hs ├── Json.hs ├── Loader.hs ├── Main.hs ├── Operations.hs └── Types.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | ghcprofview.cabal 3 | *.hi 4 | *.o 5 | *.swp 6 | *~ 7 | docker/work 8 | docker/target 9 | docker/stack 10 | docker/build/ 11 | debian/ghcprofview/ 12 | debian/files 13 | debian/debhelper-build-stamp 14 | 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Choose a build environment 12 | dist: xenial 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.stack 21 | 22 | # Ensure necessary system libraries are present 23 | addons: 24 | apt: 25 | packages: 26 | - libgmp-dev 27 | - alex 28 | - happy 29 | - libgtk-3-dev 30 | - libgirepository-1.0-1 31 | - libgirepository1.0-dev 32 | - gobject-introspection 33 | - libghc-gi-harfbuzz-dev 34 | 35 | matrix: 36 | include: 37 | - compiler: ": #stack 8.10.3" 38 | env: ARGS="--resolver lts-17" 39 | 40 | before_install: 41 | # Download and unpack the stack executable 42 | - mkdir -p ~/.local/bin 43 | - export PATH=$HOME/.local/bin:$PATH 44 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 45 | 46 | install: 47 | # Build dependencies 48 | - stack --no-terminal --install-ghc $ARGS test --only-dependencies 49 | 50 | script: 51 | # Build the package, its tests, and its docs and run the tests 52 | - stack --no-terminal $ARGS test --haddock --no-haddock-deps 53 | 54 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for gtk3test 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ghcprofview README 2 | ================== 3 | 4 | [![Build Status](https://travis-ci.org/portnov/ghcprofview-hs.svg?branch=master)](https://travis-ci.org/portnov/ghcprofview-hs) 5 | 6 | This is GHC `.prof` files viewer, implemented in Haskell + Gtk3. 7 | 8 | Unlike [profiterole][1] and [profiteur][2], `ghcprofview` uses a traditional 9 | approach to profiling. It allows you to view cost centres tree as it is and 10 | browse it interactively, and allows you to do some actions that you may be used 11 | to in, for example, Java's `visualvm`. 12 | 13 | See also a very similar application in Python + Qt5 - [ghcprofview-py][3]. 14 | 15 | [1]: https://hackage.haskell.org/package/profiterole 16 | [2]: https://hackage.haskell.org/package/profiteur 17 | [3]: https://github.com/portnov/ghcprofview-py 18 | 19 | ![Screenshot](https://user-images.githubusercontent.com/284644/61590344-1a57ff80-abd1-11e9-93ce-dfc316c825ae.png) 20 | 21 | Features 22 | -------- 23 | 24 | * GUI is tab-oriented. Default tab is called "All" and contains the whole tree. 25 | Other tabs may appear when you do filtering or some other actions. You may 26 | close unneeded tabs. 27 | * Two additional columns in addition to what we have in standard GHC's text `.prof` output: 28 | * Time Relative: share of "Time Inherited" of this item with relation to it's 29 | parent item. For example, if this item has "Time Inherited" 20%, and it's 30 | parent has "Time Inherited" 30%, then "Time Relative" is 20% / 30% = 31 | 66.66%. 32 | * Alloc Relative: same, but about "Alloc Inherited". 33 | * Click on column header to sort by that column. 34 | * Right-click on table header to select which columns to display. 35 | * Double-click at the edge of column header to adjust column width automatically. 36 | * Use Search and Next buttons to search function by name. There are three 37 | search modes available: Contains (search by substring), Exact (search for 38 | exact match), Reg.Exp (search by regular expression). 39 | * Use filters to display interesting records only. Filter results will be shown 40 | in separate tab. 41 | * Supported fields for filtering are: Entries, Time Individual, Alloc 42 | Individual, Time Inherited, Alloc Inherited, Module (by substring match), 43 | Source (by substring match). 44 | * Filter works by AND; so if you set Entries = 5, Module = "Gui", then you 45 | will be searching for items that have entries >= 5 AND in module "Gui". 46 | * Logic of filter application to the tree is the following: it keeps an item 47 | if that item conforms to filter conditions, OR if it has child items that 48 | conform to filter condition. 49 | * "Narrow view to selected item" in right-click menu. This will open a tab and 50 | show only selected item and it's descendants. 51 | * "Group all outgoing calls" in right-click menu. This does the following: 52 | * Searches for all occurences of selected function in the tree. 53 | * Merges call subtrees of these occurences into new tree; for example, if 54 | function "search" appeared in one place with "time inherited" of 15%, and 55 | in another place with 10%, then in the merged tree you will see it with 56 | 25%. 57 | * Displays the result in a new tab. 58 | * "Group all incoming calls" in right-click menu. This does the following: 59 | * Searches for all occurences of selected function in the tree. 60 | * Reverses call stacks of found occurences and merges them into a new tree. 61 | So in that tree, the root will be the item you selected, and it's children 62 | will be all functions that call the selected function, and so on. Numbers 63 | are merged similar to "group all outgoing calls" function. 64 | * Displays the result in a new tab. 65 | * Text format of `.prof` files is supported; there is support for Json format, 66 | but it is buggy currently. 67 | 68 | Installation 69 | ------------ 70 | 71 | Install it by `stack`: 72 | 73 | $ git clone https://github.com/portnov/ghcprofview-hs.git 74 | $ cd ghcprofview-hs/ 75 | $ stack install 76 | 77 | Installing it by `nix-shell`: 78 | $ nix-shell -p haskellPackages.ghcprofview 79 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /debian/changelog: -------------------------------------------------------------------------------- 1 | ghcprofview (0.1.0.0-1) UNRELEASED; urgency=low 2 | 3 | * Initial release 4 | 5 | -- Ilya V . Portnov Sat, 09 Mar 2019 10:56:44 +0500 6 | -------------------------------------------------------------------------------- /debian/compat: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: ghcprofview 2 | Maintainer: Ilya V . Portnov 3 | Priority: optional 4 | Section: haskell 5 | Build-Depends: debhelper (>= 9) 6 | Standards-Version: 3.9.6 7 | Homepage: https://github.com/githubuser/ghcprofview-hs#readme 8 | X-Description: 9 | Please see the README on GitHub at 10 | 11 | Package: ghcprofview 12 | Architecture: any 13 | Section: misc 14 | Depends: ${shlibs:Depends} 15 | Description: GHC .prof files viewer, implemented in Haskell + Gtk3. 16 | . 17 | Unlike profiterole and profiteur, ghcprofview uses a traditional approach to 18 | profiling. It allows you to view cost centres tree as it is and browse it 19 | interactively, and allows you to do some actions that you may be used to in, 20 | for example, Java's visualvm. 21 | 22 | -------------------------------------------------------------------------------- /debian/copyright: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: ghcprofview 3 | Upstream-Contact: example@example.com 4 | Source: https://hackage.haskell.org/package/ghcprofview 5 | 6 | Files: * 7 | Copyright: 2018 Author name here 8 | License: BSD3 9 | 10 | Files: debian/* 11 | Copyright: held by the contributors mentioned in debian/changelog 12 | License: BSD3 13 | 14 | License: BSD3 15 | Copyright Ilya Portnov (c) 2018 16 | . 17 | All rights reserved. 18 | . 19 | Redistribution and use in source and binary forms, with or without 20 | modification, are permitted provided that the following conditions are met: 21 | . 22 | * Redistributions of source code must retain the above copyright 23 | notice, this list of conditions and the following disclaimer. 24 | . 25 | * Redistributions in binary form must reproduce the above 26 | copyright notice, this list of conditions and the following 27 | disclaimer in the documentation and/or other materials provided 28 | with the distribution. 29 | . 30 | * Neither the name of Author name here nor the names of other 31 | contributors may be used to endorse or promote products derived 32 | from this software without specific prior written permission. 33 | . 34 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 35 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 36 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 37 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 38 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 39 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 40 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 41 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 42 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 43 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 44 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 45 | -------------------------------------------------------------------------------- /debian/ghcprofview.debhelper.log: -------------------------------------------------------------------------------- 1 | dh_prep 2 | dh_installdirs 3 | dh_install 4 | dh_installdocs 5 | dh_installchangelogs 6 | dh_installman 7 | dh_installdebconf 8 | dh_compress 9 | dh_fixperms 10 | dh_strip 11 | dh_makeshlibs 12 | dh_shlibdeps 13 | dh_installdeb 14 | dh_gencontrol 15 | dh_md5sums 16 | dh_builddeb 17 | dh_builddeb 18 | -------------------------------------------------------------------------------- /debian/ghcprofview.dirs: -------------------------------------------------------------------------------- 1 | usr/bin 2 | -------------------------------------------------------------------------------- /debian/ghcprofview.install: -------------------------------------------------------------------------------- 1 | .stack-work/install/x86_64-linux/f328d036c19212621926aa2ee41f803cf30cd4dff8e8592f72da38ad18df83b3/8.6.5/bin/ghcprofview usr/bin 2 | -------------------------------------------------------------------------------- /debian/ghcprofview.substvars: -------------------------------------------------------------------------------- 1 | shlibs:Depends=libatk1.0-0 (>= 2.12.0), libc6 (>= 2.14), libcairo-gobject2 (>= 1.10.0), libcairo2 (>= 1.2.4), libgdk-pixbuf2.0-0 (>= 2.31.1), libgirepository-1.0-1 (>= 0.9.2), libglib2.0-0 (>= 2.47.1), libgmp10, libgtk-3-0 (>= 3.17.9), libpango-1.0-0 (>= 1.37.2), libpangocairo-1.0-0 (>= 1.14.0), zlib1g (>= 1:1.1.4) 2 | misc:Depends= 3 | misc:Pre-Depends= 4 | -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | 3 | clean: 4 | rm -rf debian/ghcprofview 5 | rm -rf *.log 6 | rm -rf *.cabal 7 | stack clean --allow-different-user 8 | 9 | check: 10 | 11 | build-arch: build 12 | 13 | build: 14 | stack build --allow-different-user 15 | 16 | override_dh_auto_build: 17 | stack build --allow-different-user 18 | 19 | binary-arch: binary 20 | 21 | binary: 22 | dh_clean 23 | dh_testroot 24 | dh_prep 25 | dh_installdirs 26 | dh_install 27 | dh_installdocs 28 | dh_installchangelogs 29 | dh_installman 30 | dh_installdebconf 31 | dh_compress 32 | dh_fixperms 33 | dh_strip 34 | dh_makeshlibs 35 | dh_shlibdeps 36 | dh_installdeb 37 | dh_gencontrol 38 | dh_md5sums 39 | dh_builddeb 40 | 41 | %: 42 | dh $@ 43 | 44 | -------------------------------------------------------------------------------- /debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (quilt) 2 | -------------------------------------------------------------------------------- /debian/source/options: -------------------------------------------------------------------------------- 1 | tar-ignore = .git 2 | tar-ignore = .gitignore 3 | tar-ignore = .stack-work 4 | tar-ignore = debian 5 | tar-ignore = docker 6 | tar-ignore = test 7 | tar-ignore = *.tar.xz 8 | tar-ignore = *.cabal 9 | 10 | extend-diff-ignore = "(^|/)(\.git|\.gitignore|\.stack-work|debian|docker|test|.*tar.xz|.*cabal)" 11 | 12 | -------------------------------------------------------------------------------- /debian/watch: -------------------------------------------------------------------------------- 1 | version=3 2 | https://hackage.haskell.org/package/ghcprofview/distro-monitor .*-([0-9\.]+)\.(?:zip|tgz|tbz|txz|(?:tar\.(?:gz|bz2|xz))) 3 | -------------------------------------------------------------------------------- /docker/.dockerignore: -------------------------------------------------------------------------------- 1 | stack/ 2 | -------------------------------------------------------------------------------- /docker/Dockerfile.ubuntu: -------------------------------------------------------------------------------- 1 | FROM ubuntu 2 | MAINTAINER Ilya V. Portnov 3 | 4 | RUN apt-get update -y && \ 5 | apt-get install -y ca-certificates curl unzip zlib1g-dev c2hs pkg-config libreadline-dev debhelper devscripts libgmp-dev alex happy libgtk-3-dev libgirepository-1.0-1 libgirepository1.0-dev gobject-introspection 6 | # Version of stack in ubuntu repos is too old. 7 | RUN curl -sSL https://get.haskellstack.org/ | sh 8 | RUN ln /usr/local/bin/stack /usr/bin/stack 9 | 10 | WORKDIR /src 11 | VOLUME /dst 12 | 13 | ADD debian-entrypoint.sh / 14 | 15 | CMD ["/bin/bash", "/debian-entrypoint.sh"] 16 | -------------------------------------------------------------------------------- /docker/build-ubuntu-package.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | SRC=$(realpath $PWD/..) 5 | 6 | docker build -t ghcprofview-ubuntu -f Dockerfile.ubuntu . 7 | 8 | docker run --name ghcprofview-ubuntu --rm -v $(pwd)/target:/dst -v $(pwd)/stack:/root/.stack -v $SRC:/src ghcprofview-ubuntu 9 | 10 | -------------------------------------------------------------------------------- /docker/builder-entrypoint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | curl -sSL https://github.com/portnov/ghcprofview-hs/archive/master.zip -o master.zip 5 | unzip master.zip && rm master.zip 6 | cd ghcprofview-hs-master/ 7 | stack install --work-dir=./build --allow-different-user 8 | 9 | cp /root/.local/bin/ghcprofview /dst/ 10 | -------------------------------------------------------------------------------- /docker/debian-entrypoint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | set -x 4 | 5 | cd /src 6 | bash prepare_debian_package.sh 7 | 8 | cp ../*.deb /dst/ 9 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: ghcprofview 2 | version: 0.1.0.2 3 | github: "portnov/ghcprofview-hs" 4 | license: BSD3 5 | author: "Ilya V. Portnov" 6 | maintainer: "portnov84@rambler.ru" 7 | copyright: "2019 Ilya V. Portnov" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: GHC .prof files viewer 15 | category: Development 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - mtl >= 2.2 25 | - containers 26 | - text 27 | - aeson 28 | - scientific 29 | - regex-tdfa 30 | - ghc-prof 31 | - haskell-gi-base 32 | - gi-gtk < 4 33 | 34 | executables: 35 | ghcprofview: 36 | main: Main.hs 37 | source-dirs: src 38 | ghc-options: 39 | - -threaded 40 | - -rtsopts 41 | - -fwarn-unused-imports 42 | - -with-rtsopts=-N 43 | - -O2 44 | -------------------------------------------------------------------------------- /prepare_debian_package.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | set -x 4 | 5 | TARGET=ghcprofview_0.1.0.0.orig.tar.xz 6 | tar -v -cJ --exclude-vcs --exclude='*.cabal' --exclude='*.log' --exclude='*.build' --exclude=./docker --exclude=./work --exclude=./.stack-work --exclude=./debian --exclude=./test --exclude='*.tar.xz' -f ../$TARGET . 7 | 8 | LOCAL_INSTALL_ROOT=$(stack path --local-install-root --allow-different-user) 9 | LOCAL_INSTALL_ROOT=$(realpath --relative-to=$PWD $LOCAL_INSTALL_ROOT) 10 | echo "$LOCAL_INSTALL_ROOT/bin/ghcprofview usr/bin" > debian/ghcprofview.install 11 | 12 | debuild -uc -us 13 | 14 | -------------------------------------------------------------------------------- /src/Converter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Converter where 4 | 5 | import qualified GHC.Prof.Types as P -- ghc-prof package 6 | import Data.Tree 7 | import Data.Maybe 8 | import qualified Data.Text as T 9 | import qualified Data.Map as M 10 | import qualified Data.IntMap as IM 11 | import Data.Scientific 12 | 13 | import Types 14 | 15 | convertCc :: P.Profile -> Tree P.CostCentre -> CostCentreData 16 | convertCc profile node = go Nothing node 17 | where 18 | profile' = convertProfile profile 19 | go parent node = 20 | let cc = rootLabel node 21 | ccd = CostCentreData { 22 | ccdProfile = profile' 23 | , ccdParent = parent 24 | , ccdRecords = [ 25 | ProfileRecord { 26 | prCcId = IndividualId $ P.costCentreNo cc 27 | , prEntries = P.costCentreEntries cc 28 | , prTicks = P.costCentreTicks cc 29 | , prAlloc = P.costCentreBytes cc 30 | , prTimeIndividual = Just $ toRealFloat $ P.costCentreIndTime cc 31 | , prAllocIndividual = Just $ toRealFloat $ P.costCentreIndAlloc cc 32 | , prTimeInherited = Just $ toRealFloat $ P.costCentreInhTime cc 33 | , prAllocInherited = Just $ toRealFloat $ P.costCentreInhAlloc cc 34 | } 35 | ] 36 | , ccdCostCentre = CostCentre { 37 | ccLabel = P.costCentreName cc 38 | , ccId = P.costCentreNo cc 39 | , ccModule = P.costCentreModule cc 40 | , ccSource = fromMaybe "" $ P.costCentreSrc cc 41 | , ccIsCaf = "CAF:" `T.isPrefixOf` P.costCentreName cc 42 | } 43 | , ccdChildren = map (go (Just ccd)) (subForest node) 44 | } 45 | in ccd 46 | 47 | convertProfile :: P.Profile -> Profile 48 | convertProfile p = Profile { 49 | profileProgram = P.profileCommandLine p 50 | , profileTotalTime = 0 51 | , profileRtsArguments = [] 52 | , profileInitCaps = 0 53 | , profileTickInterval = 0 54 | , profileTotalAlloc = P.totalAllocBytes $ P.profileTotalAlloc p 55 | , profileTotalTicks = P.totalTimeTicks $ P.profileTotalTime p 56 | , profileTree = error "profile tree was not read from .prof file" 57 | , profileTreeMap = IM.empty 58 | , profileCostCentres = IM.empty 59 | } 60 | 61 | -------------------------------------------------------------------------------- /src/Gui.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Gui where 4 | 5 | import qualified Data.Text as T () -- instances only 6 | import Data.Int 7 | 8 | import Data.GI.Base.GType 9 | import Data.GI.Base.GValue 10 | 11 | import Types 12 | import Operations 13 | import Gui.TreeWidget 14 | 15 | treeWidgetConfig :: TreeWidgetConfig CostCentreData 16 | treeWidgetConfig = 17 | TreeWidgetConfig { 18 | twcColumns = [ 19 | Column "No" gtypeString TextColumn (toGValue . Just . ccdRecordIds), -- 0 20 | Column "Name" gtypeString TextColumn (toGValue . Just . ccdLabel), -- 1 21 | Column "Entries" gtypeInt64 TextColumn (toGValue . ccdEntries), -- 2 22 | Column "Individual Time" gtypeDouble PercentColumn (toGValue . ccdTimeIndividual), -- 3 23 | Column "Individual Alloc" gtypeDouble PercentColumn (toGValue . ccdAllocIndividual), -- 4 24 | Column "Inherited Time" gtypeDouble PercentColumn (toGValue . ccdTimeInherited), -- 5 25 | Column "Inherited Alloc" gtypeDouble PercentColumn (toGValue . ccdAllocInherited), -- 6 26 | Column "Relative Time" gtypeDouble PercentColumn (toGValue . ccdTimeRelative), -- 7 27 | Column "Relative Alloc" gtypeDouble PercentColumn (toGValue . ccdAllocRelative), -- 8 28 | Column "Module" gtypeString TextColumn (toGValue . Just . ccdModule), -- 9 29 | Column "Source" gtypeString TextColumn (toGValue . Just . ccdSource) -- 10 30 | ] 31 | } 32 | 33 | noColumn :: Int32 34 | noColumn = 0 35 | 36 | nameColumn :: Int32 37 | nameColumn = 1 38 | 39 | entriesColumn :: Int32 40 | entriesColumn = 2 41 | 42 | individualTimeColumn :: Int32 43 | individualTimeColumn = 3 44 | 45 | individualAllocColumn :: Int32 46 | individualAllocColumn = 4 47 | 48 | inheritedTimeColumn :: Int32 49 | inheritedTimeColumn = 5 50 | 51 | inheritedAllocColumn :: Int32 52 | inheritedAllocColumn = 6 53 | 54 | relativeTimeColumn :: Int32 55 | relativeTimeColumn = 7 56 | 57 | relativeAllocColumn :: Int32 58 | relativeAllocColumn = 8 59 | 60 | moduleColumn :: Int32 61 | moduleColumn = 9 62 | 63 | sourceColumn :: Int32 64 | sourceColumn = 10 65 | 66 | -------------------------------------------------------------------------------- /src/Gui/Page.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | 4 | module Gui.Page where 5 | 6 | import Control.Monad 7 | import qualified Data.Text as T 8 | import Data.IORef 9 | 10 | import GI.Gtk hiding (main) 11 | 12 | import Gui 13 | import Gui.TreeWidget 14 | import Gui.Utils 15 | 16 | import Types 17 | import Operations 18 | 19 | data Page = Page { 20 | pageWidget :: Box 21 | , pageSearchState :: IORef (Int, [TreePath]) 22 | } 23 | 24 | type ShowTree = T.Text -> CostCentreData -> IO () 25 | 26 | mkContextMenu :: TreeView -> CostCentreData -> ShowTree -> IO Menu 27 | mkContextMenu tree ccd showTree = do 28 | menu <- menuNew 29 | 30 | -- mkMenuItem menu "Test" $ do 31 | -- withSelected tree $ \store selected -> do 32 | -- Just name <- getItem store selected nameColumn 33 | -- print (name :: T.Text) 34 | -- Just mod <- getItem store selected moduleColumn 35 | -- Just src <- getItem store selected sourceColumn 36 | -- let subtrees = ccdFind mod src name ccd 37 | -- forM_ subtrees $ \child -> do 38 | -- let parent = case ccdParent child of 39 | -- Nothing -> "no parent" 40 | -- Just parent -> T.pack (ccdRecordIds parent) <> ": " <> ccdLabel parent <> " = " <> T.pack (show $ ccdTimeInherited parent) 41 | -- print $ T.pack (ccdRecordIds child) <> ": " <> ccdLabel child <> " = " <> T.pack (show $ ccdTimeInherited child) <> " => " <> parent 42 | 43 | mkMenuItem menu "Narrow view to this item" $ do 44 | withSelected tree $ \store selected -> do 45 | path <- getTruePath store selected 46 | Just idxs <- treePathGetIndices path 47 | case ccdByPath idxs ccd of 48 | Nothing -> return () 49 | Just child -> do 50 | let label = ccdLabel child 51 | showTree ("Narrowed view: " <> label) child 52 | 53 | mkMenuItem menu "Group all outgoing calls" $ 54 | withSelected tree $ \store selected -> do 55 | Just name <- getItem store selected nameColumn 56 | Just mod <- getItem store selected moduleColumn 57 | Just src <- getItem store selected sourceColumn 58 | let subtrees = ccdFind mod src name ccd 59 | result = ccdSum subtrees 60 | showTree ("Calls of " <> name) result 61 | 62 | mkMenuItem menu "Group all incoming calls" $ 63 | withSelected tree $ \store selected -> do 64 | Just name <- getItem store selected nameColumn 65 | Just mod <- getItem store selected moduleColumn 66 | Just src <- getItem store selected sourceColumn 67 | let subtrees = ccdFindIncoming mod src name ccd 68 | result = ccdSum subtrees 69 | showTree ("Calls to " <> name) result 70 | 71 | return menu 72 | 73 | mkPage :: Statusbar -> T.Text -> CostCentreData -> ShowTree -> IO Page 74 | mkPage status label ccd showTree = do 75 | vbox <- boxNew OrientationVertical 0 76 | searchHbox <- boxNew OrientationHorizontal 0 77 | filterBox <- boxNew OrientationHorizontal 0 78 | filterSettingsBox <- flowBoxNew 79 | flowBoxSetSelectionMode filterSettingsBox SelectionModeNone 80 | 81 | entry <- searchEntryNew 82 | boxPackStart searchHbox entry True True 0 83 | searchButton <- buttonNewWithLabel "Search" 84 | searchNextButton <- buttonNewWithLabel "Next" 85 | searchMethodCombo <- mkComboBox [ 86 | (Contains, "Contains") 87 | , (Exact, "Exact") 88 | , (Regexp, "Reg.Exp") 89 | ] 90 | 91 | boxPackStart searchHbox searchButton False False 0 92 | boxPackStart searchHbox searchNextButton False False 0 93 | boxPackStart searchHbox searchMethodCombo False False 0 94 | boxPackStart vbox searchHbox False False 0 95 | 96 | on entry #activate $ buttonClicked searchButton 97 | 98 | let mkEntry :: IsWidget w => T.Text -> w -> IO (Box, w) 99 | mkEntry name widget = do 100 | lbl <- labelNew (Just name) 101 | box <- boxNew OrientationHorizontal 0 102 | boxPackStart box lbl False False 0 103 | boxPackStart box widget True True 10 104 | return (box, widget) 105 | 106 | let addFilterPercent name = do 107 | (box, spin) <- mkEntry name =<< spinButtonNewWithRange 0 100 1 108 | spinButtonSetDigits spin 2 109 | containerAdd filterSettingsBox box 110 | return spin 111 | 112 | let addFilterNumber name = do 113 | (box, spin) <- mkEntry name =<< spinButtonNewWithRange 0 (1e38) 1 114 | spinButtonSetDigits spin 0 115 | containerAdd filterSettingsBox box 116 | return spin 117 | 118 | let addFilterText name = do 119 | (box, spin) <- mkEntry name =<< entryNew 120 | containerAdd filterSettingsBox box 121 | return entry 122 | 123 | fltrEntries <- addFilterNumber "Entries:" 124 | fltrTimeIndividual <- addFilterPercent "Time Individual:" 125 | fltrAllocIndividual <- addFilterPercent "Alloc Individual:" 126 | fltrTimeInherited <- addFilterPercent "Time Inherited:" 127 | fltrAllocInherited <- addFilterPercent "Alloc Inherited:" 128 | fltrModule <- addFilterText "Module:" 129 | fltrSource <- addFilterText "Source:" 130 | 131 | filterButton <- buttonNewWithLabel "Filter" 132 | 133 | boxPackStart filterBox filterSettingsBox True True 0 134 | boxPackStart filterBox filterButton False False 0 135 | boxPackStart vbox filterBox False False 0 136 | 137 | tree <- mkTreeView treeWidgetConfig ccd 138 | treeViewSetSearchColumn tree 1 139 | treeViewSetEnableSearch tree False 140 | let noAdjustment = Nothing :: Maybe Adjustment 141 | scroll <- scrolledWindowNew noAdjustment noAdjustment 142 | containerAdd scroll tree 143 | boxPackStart vbox scroll True True 10 144 | 145 | statusContext <- statusbarGetContextId status label 146 | 147 | searchResults <- newIORef (0, []) 148 | 149 | let message text = 150 | void $ statusbarPush status statusContext (T.pack text) 151 | 152 | on searchButton #clicked $ do 153 | text <- entryGetText entry 154 | unless (T.null text) $ do 155 | Just methodId <- comboBoxGetActiveId searchMethodCombo 156 | let method = read $ T.unpack methodId 157 | results <- treeSearch tree method text 158 | if null results 159 | then message "Not found." 160 | else do 161 | message $ "Found: " ++ show (length results) 162 | writeIORef searchResults (0, results) 163 | Just store <- treeViewGetModel tree 164 | let path = head results 165 | treeViewExpandToPath tree path 166 | treeViewSetCursor tree path (Nothing :: Maybe TreeViewColumn) False 167 | 168 | on searchNextButton #clicked $ do 169 | (prevIndex, results) <- readIORef searchResults 170 | if null results 171 | then message "Not found." 172 | else do 173 | let n = length results 174 | index = (prevIndex + 1) `mod` n 175 | path = results !! index 176 | message $ "Found: " ++ show index ++ "/" ++ show n 177 | writeIORef searchResults (index, results) 178 | treeViewExpandToPath tree path 179 | treeViewSetCursor tree path (Nothing :: Maybe TreeViewColumn) False 180 | 181 | on filterButton #clicked $ do 182 | entries <- spinButtonGetValueAsInt fltrEntries 183 | timeIndividual <- spinButtonGetValue fltrTimeIndividual 184 | allocIndividual <- spinButtonGetValue fltrAllocIndividual 185 | timeInherited <- spinButtonGetValue fltrTimeInherited 186 | allocInherited <- spinButtonGetValue fltrAllocInherited 187 | mod <- entryGetText fltrModule 188 | src <- entryGetText fltrSource 189 | 190 | let params = FilterParams { 191 | fpEntries = fromIntegral entries 192 | , fpTimeIndividual = timeIndividual 193 | , fpAllocIndividual = allocIndividual 194 | , fpTimeInherited = timeInherited 195 | , fpAllocInherited = allocInherited 196 | , fpModule = mod 197 | , fpSource = src 198 | } 199 | let ccd' = filterCcdRecursive (checkFilter params) ccd 200 | showTree "Filtered" ccd' 201 | 202 | on tree #buttonPressEvent $ \ev -> do 203 | button <- get ev #button 204 | when (button == 3) $ do 205 | menu <- mkContextMenu tree ccd showTree 206 | menuPopupAtPointer menu Nothing 207 | return False 208 | 209 | return $ Page vbox searchResults 210 | 211 | -------------------------------------------------------------------------------- /src/Gui/TreeWidget.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE MonoLocalBinds #-} 8 | 9 | module Gui.TreeWidget where 10 | 11 | import Control.Monad 12 | import qualified Data.Text as T 13 | import Data.Int 14 | 15 | import Data.GI.Base.GType 16 | import Data.GI.Base.GValue 17 | import Data.GI.Base.Signals 18 | import GI.Gtk 19 | 20 | import Types 21 | 22 | data ColumnType = 23 | TextColumn 24 | | PercentColumn 25 | deriving (Eq, Show) 26 | 27 | data Column a = Column { 28 | columnTitle :: T.Text 29 | , columnGType :: GType 30 | , columnType :: ColumnType 31 | , columnData :: a -> IO GValue 32 | } 33 | 34 | newtype TreeWidgetConfig a = TreeWidgetConfig { 35 | twcColumns :: [Column a] 36 | } 37 | 38 | mkTreeStore :: forall a t . IsTree t a => TreeWidgetConfig a -> t -> IO TreeStore 39 | mkTreeStore cfg tree = do 40 | let columns = twcColumns cfg 41 | let gtypes = map columnGType columns 42 | store <- treeStoreNew gtypes 43 | fill store Nothing tree 44 | return store 45 | where 46 | fill :: TreeStore -> Maybe TreeIter -> t -> IO () 47 | fill store root node = do 48 | let cc = treeRoot node 49 | item <- treeStoreInsert store root (negate 1) 50 | forM_ (zip [0..] (twcColumns cfg)) $ \(i, column) -> 51 | treeStoreSetValue store item i =<< columnData column cc 52 | forM_ (treeChildren node) $ fill store (Just item) 53 | 54 | mkTreeView :: forall t a . IsTree t a => TreeWidgetConfig a -> t -> IO TreeView 55 | mkTreeView cfg@(TreeWidgetConfig columns) tree = do 56 | srcStore <- mkTreeStore cfg tree 57 | store <- treeModelSortNewWithModel srcStore 58 | view <- treeViewNewWithModel store 59 | treeViewSetHeadersVisible view True 60 | forM_ (zip [0..] columns) $ \(i, column) -> 61 | addColumn view i (columnType column) (columnTitle column) 62 | 63 | return view 64 | where 65 | addColumn :: TreeView 66 | -> Int32 67 | -> ColumnType 68 | -> T.Text 69 | -> IO SignalHandlerId 70 | addColumn view i ctype title = do 71 | column <- treeViewColumnNew 72 | treeViewColumnSetTitle column title 73 | withRenderer ctype $ \renderer -> do 74 | treeViewColumnPackStart column renderer True 75 | let propName = getPropName ctype 76 | treeViewColumnAddAttribute column renderer propName i 77 | set column [ #resizable := True ] 78 | treeViewColumnSetSizing column TreeViewColumnSizingFixed 79 | treeViewColumnSetSortColumnId column i 80 | treeViewAppendColumn view column 81 | 82 | button <- treeViewColumnGetButton column 83 | on button #buttonPressEvent $ \ev -> do 84 | button <- get ev #button 85 | if button == 3 86 | then do 87 | menu <- mkColumnsMenu view 88 | menuPopupAtPointer menu Nothing 89 | return True 90 | else return False 91 | 92 | withRenderer :: forall x. ColumnType -> (forall r. IsCellRenderer r => r -> IO Int32) -> IO Int32 93 | withRenderer TextColumn f = cellRendererTextNew >>= f 94 | withRenderer PercentColumn f = cellRendererProgressNew >>= f 95 | 96 | getPropName TextColumn = "text" 97 | getPropName PercentColumn = "value" 98 | 99 | mkColumnsMenu :: TreeView -> IO Menu 100 | mkColumnsMenu tree = do 101 | menu <- menuNew 102 | columns <- treeViewGetColumns tree 103 | forM_ (zip [0..] columns) $ \(i, column) -> do 104 | title <- treeViewColumnGetTitle column 105 | item <- checkMenuItemNewWithLabel title 106 | menuShellAppend menu item 107 | widgetShow item 108 | visible <- treeViewColumnGetVisible column 109 | checkMenuItemSetActive item visible 110 | on item #activate $ do 111 | treeViewColumnSetVisible column (not visible) 112 | return menu 113 | 114 | -------------------------------------------------------------------------------- /src/Gui/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | 4 | module Gui.Utils where 5 | 6 | import Control.Monad 7 | import qualified Data.Text as T 8 | import Data.Int 9 | import Data.IORef 10 | import Text.Regex.TDFA 11 | import Text.Regex.TDFA.Text () -- instances only 12 | 13 | import Data.GI.Base.GValue 14 | import GI.Gtk hiding (main) 15 | 16 | import Types 17 | 18 | iterChildren :: TreeModel 19 | -> TreeIter -- ^ Root 20 | -> (TreeIter -> IO (Bool, [a])) -- ^ Should return (whether to stop iterations; result) 21 | -> IO [a] 22 | iterChildren store parent func = do 23 | (hasFirst, first) <- treeModelIterChildren store (Just parent) 24 | if not hasFirst 25 | then return [] 26 | else go first 27 | where 28 | go iter = do 29 | (stop, results) <- func iter 30 | if stop 31 | then return results 32 | else do 33 | hasNext <- treeModelIterNext store iter 34 | if hasNext 35 | then do 36 | rest <- go iter 37 | return $ results ++ rest 38 | else return results 39 | 40 | iterChildrenR :: TreeModel -> TreeIter -> (TreeIter -> IO (Bool, [a])) -> IO [a] 41 | iterChildrenR store parent func = do 42 | childResults <- iterChildren store parent $ \child -> do 43 | (stop, result) <- func child 44 | if stop 45 | then return (True, [result]) 46 | else do 47 | rest <- iterChildrenR store child func 48 | return (False, [result ++ rest]) 49 | return $ concat childResults 50 | 51 | treeSearch :: TreeView -> SearchMetohd -> T.Text -> IO [TreePath] 52 | treeSearch view method needle = do 53 | Just store <- treeViewGetModel view 54 | (hasFirst, first) <- treeModelGetIterFirst store 55 | if not hasFirst 56 | then return [] 57 | else iterChildrenR store first $ \child -> do 58 | found <- checkValue store child 59 | if found 60 | then do 61 | path <- treeModelGetPath store child 62 | return (False, [path]) 63 | else return (False, []) 64 | where 65 | checkValue store row = do 66 | mbValue <- fromGValue =<< treeModelGetValue store row 1 67 | case mbValue of 68 | Nothing -> return False -- not ok 69 | Just value -> 70 | case method of 71 | Contains -> return $ needle `T.isInfixOf` value 72 | Exact -> return $ needle == value 73 | Regexp -> return $ value =~ needle 74 | 75 | treeCheck :: TreeModel -> (TreeIter -> IO Bool) -> IO Bool 76 | treeCheck store check = or <$> do 77 | (hasFirst, first) <- treeModelGetIterFirst store 78 | if not hasFirst 79 | then return [] 80 | else iterChildrenR store first $ \child -> do 81 | found <- check child 82 | if found 83 | then return (True, [True]) 84 | else return (False, []) 85 | 86 | withSelected :: TreeView -> (TreeModel -> TreeIter -> IO ()) -> IO () 87 | withSelected tree fn = do 88 | (isSelected, store, selected) <- treeSelectionGetSelected =<< treeViewGetSelection tree 89 | when isSelected $ fn store selected 90 | 91 | getTruePath :: TreeModel -> TreeIter -> IO TreePath 92 | getTruePath top iter = do 93 | Just sorted <- castTo TreeModelSort top 94 | topPath <- treeModelGetPath top iter 95 | Just truePath <- treeModelSortConvertPathToChildPath sorted topPath 96 | return truePath 97 | 98 | defFilterParams :: FilterParams 99 | defFilterParams = FilterParams 0 0 0 0 0 "" "" 100 | 101 | getItem :: IsGValue a => TreeModel -> TreeIter -> Int32 -> IO a 102 | getItem store row col = 103 | fromGValue =<< treeModelGetValue store row col 104 | 105 | treeFilterFunc :: IORef FilterParams -> TreeModelFilterVisibleFunc 106 | treeFilterFunc paramsRef store row = do 107 | params <- readIORef paramsRef 108 | hasChild <- treeModelIterHasChild store row 109 | good <- do 110 | entries <- getItem store row 2 :: IO Integer 111 | timeIndividual <- getItem store row 3 112 | allocIndividual <- getItem store row 4 113 | timeInherited <- getItem store row 5 114 | allocInherited <- getItem store row 6 115 | Just mod <- getItem store row 7 116 | Just src <- getItem store row 8 117 | return $ 118 | entries >= fpEntries params && 119 | timeIndividual >= fpTimeIndividual params && 120 | allocIndividual >= fpAllocIndividual params && 121 | timeInherited >= fpTimeInherited params && 122 | allocInherited >= fpAllocInherited params && 123 | fpModule params `T.isInfixOf` mod && 124 | fpSource params `T.isInfixOf` src 125 | return $ hasChild || good 126 | 127 | mkComboBox :: (Show a) => [(a, T.Text)] -> IO ComboBoxText 128 | mkComboBox pairs = do 129 | combo <- comboBoxTextNew 130 | forM_ pairs $ \(value, title) -> do 131 | let id = T.pack (show value) 132 | comboBoxTextAppend combo (Just id) title 133 | comboBoxSetActive combo 0 134 | return combo 135 | 136 | mkMenuItem :: Menu -> T.Text -> MenuItemActivateCallback -> IO () 137 | mkMenuItem menu label callback = do 138 | item <- menuItemNewWithLabel label 139 | menuShellAppend menu item 140 | on item #activate callback 141 | widgetShow item 142 | return () 143 | 144 | mkTabLabelWidget :: T.Text -> ButtonClickedCallback -> IO Box 145 | mkTabLabelWidget text callback = do 146 | label <- labelNew (Just text) 147 | let size = fromIntegral $ fromEnum IconSizeMenu 148 | button <- buttonNewFromIconName (Just "window-close") size 149 | on button #clicked callback 150 | buttonSetRelief button ReliefStyleNone 151 | box <- boxNew OrientationHorizontal 0 152 | boxPackStart box label True True 0 153 | boxPackStart box button False False 0 154 | widgetShowAll box 155 | return box 156 | 157 | -------------------------------------------------------------------------------- /src/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DataKinds #-} 3 | 4 | module Json where 5 | 6 | import Data.Aeson 7 | import Data.Aeson.Types 8 | import qualified Data.Map as M 9 | import qualified Data.IntMap as IM 10 | import Data.Tree 11 | 12 | import Types 13 | 14 | instance FromJSON Profile where 15 | parseJSON = withObject "profile" $ \v -> do 16 | program <- v .: "program" 17 | totalTime <- v .: "total_time" 18 | rtsArgs <- v .: "rts_arguments" 19 | initCaps <- v .: "initial_capabilities" 20 | tickInterval <- v .: "tick_interval" 21 | totalAlloc <- v .: "total_alloc" 22 | totalTicks <- v .: "total_ticks" 23 | profile <- explicitParseField parseTree v "profile" 24 | let profileTree = mkTreeMap profile 25 | costCentres <- mkMap <$> v .: "cost_centres" 26 | return $ Profile 27 | program 28 | totalTime 29 | rtsArgs 30 | initCaps 31 | tickInterval 32 | totalAlloc 33 | totalTicks 34 | profile 35 | profileTree 36 | costCentres 37 | 38 | where 39 | mkMap list = IM.fromList [(ccId r, r) | r <- list] 40 | 41 | mkTreeMap node = IM.fromList $ mkTreePairs node 42 | 43 | mkTreePairs node = 44 | (singleRecordId $ rootLabel node, node) : concatMap mkTreePairs (subForest node) 45 | 46 | parseTree :: Value -> Parser (Tree (ProfileRecord Individual)) 47 | parseTree = withObject "record" $ \v -> do 48 | root <- ProfileRecord 49 | <$> (IndividualId <$> v .: "id") 50 | <*> v .: "entries" 51 | <*> v .: "ticks" 52 | <*> v .: "alloc" 53 | <*> return Nothing 54 | <*> return Nothing 55 | <*> return Nothing 56 | <*> return Nothing 57 | children <- explicitParseField (listParser parseTree) v "children" 58 | return $ Node root children 59 | 60 | instance FromJSON CostCentre where 61 | parseJSON = withObject "cost_centre" $ \v -> CostCentre 62 | <$> v .: "label" 63 | <*> v .: "id" 64 | <*> v .: "module" 65 | <*> v .: "src_loc" 66 | <*> v .: "is_caf" 67 | 68 | -------------------------------------------------------------------------------- /src/Loader.hs: -------------------------------------------------------------------------------- 1 | 2 | module Loader where 3 | 4 | import Data.Aeson (eitherDecodeFileStrict) 5 | import qualified Data.Text.IO as TIO 6 | import qualified GHC.Prof as P -- from ghc-prof package 7 | 8 | import Types 9 | import Converter 10 | import Operations 11 | import Json () -- instances only 12 | 13 | loadProfile :: FilePath -> IO CostCentreData 14 | loadProfile path = do 15 | r <- eitherDecodeFileStrict path 16 | case r of 17 | Left _ -> do 18 | text <- TIO.readFile path 19 | let r = P.decode' text 20 | case r of 21 | Left err -> fail err 22 | Right profile -> do 23 | let Just centres = P.costCentres profile 24 | return $ convertCc profile centres 25 | 26 | Right profile -> return $ resolveProfile profile 27 | 28 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | module Main (main) where 5 | 6 | import qualified GI.Gtk as GI (main, init) 7 | import GI.Gtk hiding (main) 8 | 9 | import System.Environment 10 | 11 | import Operations 12 | import Loader 13 | import Gui.Page 14 | import Gui.Utils 15 | 16 | main :: IO () 17 | main = do 18 | [path] <- getArgs 19 | treeData <- loadProfile path 20 | let treeData' = updateTotals $ filterCcd (not . ccdToIgnore) treeData 21 | -- print $ profileTotalTicks $ ccdProfile treeData' 22 | -- printTree treeData' 23 | -- print $ ccdLabel `fmap` ccdByPath [0, 20] treeData' 24 | 25 | GI.init Nothing 26 | 27 | -- Create a new window 28 | window <- windowNew WindowTypeToplevel 29 | 30 | -- Here we connect the "destroy" event to a signal handler. 31 | onWidgetDestroy window mainQuit 32 | 33 | -- Sets the border width of the window. 34 | setContainerBorderWidth window 10 35 | vbox <- boxNew OrientationVertical 0 36 | 37 | notebook <- notebookNew 38 | status <- statusbarNew 39 | 40 | let showTree label ccd = do 41 | page <- pageWidget `fmap` mkPage status label ccd showTree 42 | widgetShowAll page 43 | labelWidget <- mkTabLabelWidget label $ do 44 | n <- notebookGetNPages notebook 45 | if n == 1 46 | then mainQuit 47 | else notebookDetachTab notebook page 48 | notebookAppendPage notebook page (Just labelWidget) 49 | return () 50 | 51 | showTree "All" treeData' 52 | 53 | boxPackStart vbox notebook True True 0 54 | boxPackStart vbox status False False 0 55 | setContainerChild window vbox 56 | 57 | -- The final step is to display everything (the window and all the widgets 58 | -- contained within it) 59 | widgetShowAll window 60 | 61 | -- All Gtk+ applications must run the main event loop. Control ends here and 62 | -- waits for an event to occur (like a key press or mouse event). 63 | GI.main 64 | 65 | -------------------------------------------------------------------------------- /src/Operations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | module Operations where 6 | 7 | import Control.Monad 8 | import qualified Data.Text as T 9 | import qualified Data.Text.IO as TIO 10 | import Data.Tree 11 | import Data.Int 12 | import Data.Maybe 13 | import qualified Data.Map as M 14 | import qualified Data.IntMap as IM 15 | import qualified Data.IntSet as IS 16 | 17 | import Types 18 | 19 | -- import Debug.Trace 20 | 21 | (//) :: (Integral a, Fractional b) => a -> a -> b 22 | x // y = fromIntegral x / fromIntegral y 23 | 24 | fromSingletonSet :: IS.IntSet -> Id 25 | fromSingletonSet set = 26 | if IS.size set == 1 27 | then head (IS.toList set) 28 | else error "fromSingletonSet for a non-singleton set" 29 | 30 | resolveProfile :: Profile -> CostCentreData 31 | resolveProfile p = go Nothing (profileTree p) 32 | where 33 | go parent node = 34 | let root = CostCentreData { 35 | ccdProfile = p 36 | , ccdParent = parent 37 | , ccdRecords = [rootLabel node] 38 | , ccdCostCentre = cc 39 | , ccdChildren = children 40 | } 41 | children = map (go (Just root)) (subForest node) 42 | IndividualId id = prCcId (rootLabel node) 43 | Just cc = IM.lookup id (profileCostCentres p) 44 | in root 45 | 46 | withCostCentre :: (CostCentre -> a) -> CostCentreData -> a 47 | withCostCentre fn ccd = 48 | fn (ccdCostCentre ccd) 49 | 50 | toAggregated :: ProfileRecord Individual -> ProfileRecord Aggregated 51 | toAggregated r@(ProfileRecord {prCcId = IndividualId id}) = 52 | r {prCcId = AggregatedId (IS.singleton id)} 53 | 54 | summaryRecord :: CostCentreData -> ProfileRecord Aggregated 55 | summaryRecord ccd = summary (ccdRecords ccd) 56 | where 57 | summary = foldr plus zero 58 | zero = ProfileRecord { 59 | prCcId = AggregatedId IS.empty 60 | , prEntries = 0 61 | , prTicks = Nothing 62 | , prAlloc = Nothing 63 | , prTimeIndividual = Nothing 64 | , prAllocIndividual = Nothing 65 | , prTimeInherited = Nothing 66 | , prAllocInherited = Nothing 67 | } 68 | 69 | plusN :: Num a => Maybe a -> Maybe a -> Maybe a 70 | plusN Nothing Nothing = Nothing 71 | plusN (Just x) Nothing = Just x 72 | plusN Nothing (Just y) = Just y 73 | plusN (Just x) (Just y) = Just (x+y) 74 | 75 | plus :: ProfileRecord Individual -> ProfileRecord Aggregated -> ProfileRecord Aggregated 76 | plus r@(ProfileRecord {prCcId = IndividualId id}) agg@(ProfileRecord {prCcId = AggregatedId set}) 77 | | id `IS.member` set = agg 78 | | otherwise = ProfileRecord { 79 | prCcId = AggregatedId (IS.insert id set) 80 | , prEntries = prEntries r + prEntries agg 81 | , prTicks = prTicks r `plusN` prTicks agg 82 | , prAlloc = prAlloc r `plusN` prAlloc agg 83 | , prTimeIndividual = prTimeIndividual r `plusN` prTimeIndividual agg 84 | , prAllocIndividual = prAllocIndividual r `plusN` prAllocIndividual agg 85 | , prTimeInherited = prTimeInherited r `plusN` prTimeInherited agg 86 | , prAllocInherited = prAllocInherited r `plusN` prAllocInherited agg 87 | } 88 | 89 | ccdId :: CostCentreData -> (T.Text, T.Text, T.Text) 90 | ccdId ccd = (ccdModule ccd, ccdSource ccd, ccdLabel ccd) 91 | 92 | ccdPlus :: CostCentreData -> CostCentreData -> CostCentreData 93 | ccdPlus c1 c2 = go (addParent (ccdParent c1) (ccdParent c2)) c1 c2 94 | where 95 | 96 | go parent c1 c2 = 97 | let result = c1 { 98 | ccdParent = parent 99 | , ccdRecords = addRecords (ccdRecords c1) (ccdRecords c2) 100 | , ccdChildren = addChildren result (ccdChildren c1) (ccdChildren c2) 101 | } 102 | in result 103 | 104 | addParent Nothing Nothing = Nothing 105 | addParent (Just p) Nothing = Just p 106 | addParent Nothing (Just q) = Just q 107 | addParent (Just p) (Just q) = Just (ccdPlus p q) 108 | 109 | addRecords rs1 rs2 = 110 | let ids1 = IS.fromList (map singleRecordId rs1) 111 | rs2' = filter (\r -> singleRecordId r `IS.notMember` ids1) rs2 112 | in rs1 ++ rs2' 113 | 114 | addChildren parent cs1 cs2 = 115 | let zero :: M.Map (T.Text, T.Text, T.Text) CostCentreData 116 | zero = M.fromList [(ccdId c, c) | c <- cs1] 117 | 118 | plus :: CostCentreData -> M.Map (T.Text, T.Text, T.Text) CostCentreData -> M.Map (T.Text, T.Text, T.Text) CostCentreData 119 | plus c result = M.insertWith (go (Just parent)) (ccdId c) c result 120 | in M.elems $ foldr plus zero cs2 121 | 122 | ccdSum :: [CostCentreData] -> CostCentreData 123 | ccdSum list = foldr1 ccdPlus list 124 | 125 | filterTree :: (a -> Bool) -> Tree a -> Tree a 126 | filterTree good node = Node (rootLabel node) $ go (subForest node) 127 | where 128 | go [] = [] 129 | go (node : nodes) 130 | | good (rootLabel node) = 131 | let node' = Node (rootLabel node) $ go (subForest node) 132 | in node' : go nodes 133 | | otherwise = go nodes 134 | 135 | filterCcd :: (CostCentreData -> Bool) -> CostCentreData -> CostCentreData 136 | filterCcd good node = node {ccdChildren = go (ccdChildren node)} 137 | where 138 | go [] = [] 139 | go (node : nodes) 140 | | good node = 141 | let node' = node {ccdChildren = go (ccdChildren node)} 142 | in node' : go nodes 143 | | otherwise = go nodes 144 | 145 | filterCcdRecursive :: (CostCentreData -> Bool) -> CostCentreData -> CostCentreData 146 | filterCcdRecursive check node = node {ccdChildren = go (ccdChildren node)} 147 | where 148 | go [] = [] 149 | go (node : nodes) 150 | | check node = 151 | let node' = node {ccdChildren = go (ccdChildren node)} 152 | in node' : go nodes 153 | | otherwise = 154 | let children' = go (ccdChildren node) 155 | node' = node {ccdChildren = children'} 156 | in if null children' 157 | then go nodes 158 | else node' : go nodes 159 | 160 | ccdCheckRecursive :: (CostCentreData -> Bool) -> CostCentreData -> Bool 161 | ccdCheckRecursive check ccd = go ccd 162 | where 163 | go ccd 164 | | check ccd = True 165 | | otherwise = any go (ccdChildren ccd) 166 | 167 | timeIndividual :: Profile -> CostCentreData -> Double 168 | timeIndividual p node = 169 | case prTimeIndividual (summaryRecord node) of 170 | Just value -> value 171 | Nothing -> 172 | case prTicks (summaryRecord node) of 173 | Nothing -> error "no individual time percentage and no ticks data provided" 174 | Just ticks -> 100 * ticks // profileTotalTicks p 175 | 176 | ccdTimeIndividual :: CostCentreData -> Double 177 | ccdTimeIndividual ccd = timeIndividual (ccdProfile ccd) ccd 178 | 179 | allocIndividual :: Profile -> CostCentreData -> Double 180 | allocIndividual p node = 181 | case prAllocIndividual (summaryRecord node) of 182 | Just value -> value 183 | Nothing -> 184 | case prAlloc (summaryRecord node) of 185 | Nothing -> error "no individual alloc percentage and no bytes data provided" 186 | Just bytes -> 100 * bytes // profileTotalAlloc p 187 | 188 | ccdAllocIndividual :: CostCentreData -> Double 189 | ccdAllocIndividual ccd = allocIndividual (ccdProfile ccd) ccd 190 | 191 | timeInherited :: Profile -> CostCentreData -> Double 192 | timeInherited p node = 193 | case prTimeInherited (summaryRecord node) of 194 | Just value -> value 195 | Nothing -> 100 * inheritedSum node // profileTotalTicks p 196 | where 197 | inheritedSum node = 198 | case prTicks (summaryRecord node) of 199 | Nothing -> error "no inherited time percentage and no ticks data provided" 200 | Just ticks -> ticks + sum (map inheritedSum $ ccdChildren node) 201 | 202 | ticksInherited :: Profile -> CostCentreData -> Maybe Integer 203 | ticksInherited p node = inheritedSum node 204 | where 205 | inheritedSum node = do 206 | individual <- prTicks (summaryRecord node) 207 | children <- mapM inheritedSum $ ccdChildren node 208 | return $ individual + sum children 209 | 210 | ccdTimeInherited :: CostCentreData -> Double 211 | ccdTimeInherited ccd = timeInherited (ccdProfile ccd) ccd 212 | 213 | ccdTicksInherited :: CostCentreData -> Maybe Integer 214 | ccdTicksInherited ccd = ticksInherited (ccdProfile ccd) ccd 215 | 216 | allocInherited :: Profile -> CostCentreData -> Double 217 | allocInherited p node = 218 | case prAllocInherited (summaryRecord node) of 219 | Just value -> value 220 | Nothing -> 100 * inheritedSum node // profileTotalAlloc p 221 | where 222 | inheritedSum node = 223 | case prAlloc (summaryRecord node) of 224 | Nothing -> error "no inherited alloc percentage and no bytes data provided" 225 | Just bytes -> bytes + sum (map inheritedSum $ ccdChildren node) 226 | 227 | ccdAllocInherited :: CostCentreData -> Double 228 | ccdAllocInherited ccd = allocInherited (ccdProfile ccd) ccd 229 | 230 | ccdTimeRelative :: CostCentreData -> Double 231 | ccdTimeRelative ccd = 232 | case ccdParent ccd of 233 | Nothing -> 0 234 | Just parent -> 235 | let parentTime = ccdTimeInherited parent 236 | thisTime = ccdTimeInherited ccd 237 | result = 238 | if thisTime <= parentTime 239 | then if parentTime <= 1e-4 240 | then 0 241 | else 100 * thisTime / parentTime 242 | else if thisTime <= 1e-4 243 | then 0 244 | else 100 * parentTime / thisTime 245 | in -- trace (T.unpack (ccdLabel ccd) ++ ": this: " ++ show thisTime ++ ", parent: " ++ show parentTime ++ ", result = " ++ show result) 246 | result 247 | 248 | ccdAllocRelative :: CostCentreData -> Double 249 | ccdAllocRelative ccd = 250 | case ccdParent ccd of 251 | Nothing -> 0 252 | Just parent -> 253 | let parentAlloc = ccdAllocInherited parent 254 | thisAlloc = ccdAllocInherited ccd 255 | in if thisAlloc <= parentAlloc 256 | then if parentAlloc <= 1e-4 257 | then 0 258 | else 100 * thisAlloc / parentAlloc 259 | else if thisAlloc <= 1e-4 260 | then 0 261 | else 100 * parentAlloc / thisAlloc 262 | 263 | ccdLabel :: CostCentreData -> T.Text 264 | ccdLabel = withCostCentre ccLabel 265 | 266 | ccdRecordIds :: CostCentreData -> String 267 | ccdRecordIds ccd = show $ concatMap listRecordId (ccdRecords ccd) 268 | 269 | ccdModule :: CostCentreData -> T.Text 270 | ccdModule = withCostCentre ccModule 271 | 272 | ccdSource :: CostCentreData -> T.Text 273 | ccdSource = withCostCentre ccSource 274 | 275 | ccdIsCaf :: CostCentreData -> Bool 276 | ccdIsCaf = withCostCentre ccIsCaf 277 | 278 | ccdToIgnore :: CostCentreData -> Bool 279 | ccdToIgnore = withCostCentre $ \cc -> ccIsCaf cc || ccLabel cc `elem` [ 280 | "OVERHEAD_of", 281 | "DONT_CARE", 282 | "GC", 283 | "SYSTEM", 284 | "IDLE" 285 | ] 286 | 287 | ccdEntries :: CostCentreData -> Integer 288 | ccdEntries ccd = prEntries (summaryRecord ccd) 289 | 290 | calcTotals :: CostCentreData -> Maybe (Integer, Integer) 291 | calcTotals ccd = calc ccd 292 | where 293 | calc node = do 294 | (childTicks_s, childAlloc_s) <- unzip <$> mapM calc (ccdChildren node) 295 | ticks <- prTicks (summaryRecord node) 296 | alloc <- prAlloc (summaryRecord node) 297 | return (ticks + sum childTicks_s, alloc + sum childAlloc_s) 298 | 299 | updateTotals :: CostCentreData -> CostCentreData 300 | updateTotals node = 301 | case calcTotals node of 302 | Nothing -> node 303 | Just (totalTicks, totalAlloc) -> 304 | let profile' = (ccdProfile node) { 305 | profileTotalTicks = totalTicks, 306 | profileTotalAlloc = totalAlloc 307 | } 308 | updateCcd ccd = ccd { 309 | ccdProfile = profile', 310 | ccdChildren = map updateCcd (ccdChildren ccd) 311 | } 312 | in updateCcd node 313 | 314 | ccdFind :: T.Text -> T.Text -> T.Text -> CostCentreData -> [CostCentreData] 315 | ccdFind mod src label ccd = go Nothing ccd 316 | where 317 | go parent ccd = self parent ccd ++ children parent ccd 318 | 319 | self parent ccd 320 | | ccdId ccd == (mod, src, label) = [ccd {ccdParent = parent}] 321 | | otherwise = [] 322 | 323 | children parent ccd = 324 | concatMap (go (Just ccd)) (ccdChildren ccd) 325 | 326 | ccdFindIncoming :: T.Text -> T.Text -> T.Text -> CostCentreData -> [CostCentreData] 327 | ccdFindIncoming mod src label ccd = map (reverseTree Nothing) $ ccdFind mod src label ccd 328 | where 329 | reverseTree parent ccd = 330 | let children = map (reverseTree (Just root)) $ maybeToList $ ccdParent ccd 331 | root = ccd {ccdParent = parent, ccdChildren = children} 332 | in root 333 | 334 | ccdByIdStr :: String -> CostCentreData -> Maybe CostCentreData 335 | ccdByIdStr idStr ccd 336 | | ccdRecordIds ccd == idStr = Just ccd 337 | | otherwise = go (ccdChildren ccd) 338 | where 339 | go [] = Nothing 340 | go (child : children) = 341 | case ccdByIdStr idStr child of 342 | Just found -> Just found 343 | Nothing -> go children 344 | 345 | ccdByPath :: [Int32] -> CostCentreData -> Maybe CostCentreData 346 | ccdByPath path ccd = go (tail path) ccd 347 | where 348 | go [] ccd = Just ccd 349 | go (ix : ixs) ccd 350 | | fromIntegral ix >= length (ccdChildren ccd) = Nothing 351 | | otherwise = go ixs (ccdChildren ccd !! fromIntegral ix) 352 | 353 | checkFilter :: FilterParams -> CostCentreData -> Bool 354 | checkFilter (FilterParams {..}) ccd = 355 | ccdEntries ccd >= fpEntries && 356 | ccdTimeIndividual ccd >= fpTimeIndividual && 357 | ccdAllocIndividual ccd >= fpAllocIndividual && 358 | ccdTimeInherited ccd >= fpTimeInherited && 359 | ccdAllocInherited ccd >= fpAllocInherited && 360 | fpSource `T.isInfixOf` ccdSource ccd && 361 | fpModule `T.isInfixOf` ccdModule ccd 362 | 363 | printTree :: CostCentreData -> IO () 364 | printTree node = go 0 node 365 | where 366 | go i node = do 367 | let prefix = T.replicate i " " 368 | TIO.putStrLn $ prefix <> 369 | ccdLabel node <> "\t" 370 | <> T.pack (show $ ccdTicksInherited node) <> "\t" 371 | <> T.pack (show $ ccdTimeInherited node) 372 | forM_ (ccdChildren node) $ \child -> 373 | go (i+1) child 374 | 375 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | module Types where 9 | 10 | import qualified Data.Text as T 11 | import Data.Int 12 | import Data.Tree 13 | import qualified Data.IntMap as IM 14 | import qualified Data.IntSet as IS 15 | import Data.Scientific 16 | -- import Data.Typeable 17 | import Data.GI.Base.GValue 18 | 19 | type Id = Int 20 | 21 | class IsTree t a | t -> a where 22 | treeRoot :: t -> a 23 | treeChildren :: t -> [t] 24 | 25 | data AggregateState = Individual | Aggregated 26 | deriving (Eq, Show) 27 | 28 | data RecordId (a :: AggregateState) where 29 | IndividualId :: Id -> RecordId Individual 30 | AggregatedId :: IS.IntSet -> RecordId Aggregated 31 | 32 | instance Show (RecordId a) where 33 | show (IndividualId id) = show id 34 | show (AggregatedId set) = show set 35 | 36 | instance IsGValue Int where 37 | gvalueGType_ = gvalueGType_ @Int64 38 | gvalueSet_ ptr v = gvalueSet_ ptr (fromIntegral v :: Int64) 39 | gvalueGet_ v = fromIntegral `fmap` (gvalueGet_ v :: IO Int64) 40 | 41 | instance IsGValue Integer where 42 | gvalueGType_ = gvalueGType_ @Int64 43 | gvalueSet_ ptr v = gvalueSet_ ptr (fromIntegral v :: Int64) 44 | gvalueGet_ v = fromIntegral `fmap` (gvalueGet_ v :: IO Int64) 45 | 46 | instance IsGValue Scientific where 47 | gvalueGType_ = gvalueGType_ @Double 48 | gvalueSet_ ptr v = gvalueSet_ ptr (toRealFloat v :: Double) 49 | gvalueGet_ v = fromFloatDigits `fmap` (gvalueGet_ v :: IO Double) 50 | 51 | data CostCentreData = CostCentreData { 52 | ccdProfile :: !Profile 53 | , ccdParent :: Maybe CostCentreData 54 | , ccdRecords :: ![ProfileRecord Individual] 55 | , ccdCostCentre :: !CostCentre 56 | , ccdChildren :: ![CostCentreData] 57 | } 58 | deriving (Show) 59 | 60 | instance IsTree CostCentreData CostCentreData where 61 | treeRoot = id 62 | treeChildren = ccdChildren 63 | 64 | data CostCentre = CostCentre { 65 | ccLabel :: !T.Text 66 | , ccId :: !Id 67 | , ccModule :: !T.Text 68 | , ccSource :: !T.Text 69 | , ccIsCaf :: !Bool 70 | } 71 | deriving (Eq, Show) 72 | 73 | data ProfileRecord s = ProfileRecord { 74 | prCcId :: !(RecordId s) 75 | , prEntries :: !Integer 76 | , prTicks :: !(Maybe Integer) -- ^ If present in input file 77 | , prAlloc :: !(Maybe Integer) -- ^ If present in input file 78 | , prTimeIndividual :: !(Maybe Double) -- ^ If present in input file 79 | , prAllocIndividual :: !(Maybe Double) -- ^ If present in input file 80 | , prTimeInherited :: !(Maybe Double) -- ^ If present in input file 81 | , prAllocInherited :: !(Maybe Double) -- ^ If present in input file 82 | } 83 | deriving (Show) 84 | 85 | singleRecordId :: ProfileRecord Individual -> Id 86 | singleRecordId r@(ProfileRecord {prCcId = IndividualId id}) = id 87 | 88 | listRecordId :: ProfileRecord a -> [Id] 89 | listRecordId (ProfileRecord {prCcId = IndividualId id}) = [id] 90 | listRecordId (ProfileRecord {prCcId = AggregatedId set}) = IS.toList set 91 | 92 | data Profile = Profile { 93 | profileProgram :: !T.Text 94 | , profileTotalTime :: !Double 95 | , profileRtsArguments :: ![T.Text] 96 | , profileInitCaps :: !Int32 97 | , profileTickInterval :: !Int32 98 | , profileTotalAlloc :: !Integer 99 | , profileTotalTicks :: !Integer 100 | , profileTree :: Tree (ProfileRecord Individual) 101 | , profileTreeMap :: IM.IntMap (Tree (ProfileRecord Individual)) 102 | , profileCostCentres :: IM.IntMap CostCentre 103 | } 104 | deriving (Show) 105 | 106 | data FilterParams = FilterParams { 107 | fpEntries :: Integer 108 | , fpTimeIndividual :: Double 109 | , fpAllocIndividual :: Double 110 | , fpTimeInherited :: Double 111 | , fpAllocInherited :: Double 112 | , fpModule :: T.Text 113 | , fpSource :: T.Text 114 | } 115 | 116 | data SearchMetohd = Contains | Exact | Regexp 117 | deriving (Eq, Show, Read, Enum, Bounded) 118 | 119 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.28 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | #extra-deps: 41 | # - sajson-0.1.0.0 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.9" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | --------------------------------------------------------------------------------