profiteur 0.4.6.1 → 0.4.7.0
raw patch · 18 files changed
+445/−379 lines, 18 filesdep +profiteurdep ~basedep ~filepathdep ~vector
Dependencies added: profiteur
Dependency ranges changed: base, filepath, vector
Files
- CHANGELOG.md +6/−0
- README.md +4/−0
- data/js/main.js +10/−0
- data/js/tree-browser.js +2/−2
- data/js/tree-map.js +33/−0
- lib/Profiteur/Core.hs +143/−0
- lib/Profiteur/DataFile/Internal.hs +8/−0
- lib/Profiteur/Main.hs +110/−0
- lib/Profiteur/Parser.hs +71/−0
- lib/embed/Profiteur/DataFile.hs +22/−0
- lib/noembed/Profiteur/DataFile.hs +16/−0
- profiteur.cabal +18/−13
- src/Main.hs +2/−105
- src/Profiteur/Core.hs +0/−143
- src/Profiteur/DataFile/Internal.hs +0/−8
- src/Profiteur/Parser.hs +0/−70
- src/embed/Profiteur/DataFile.hs +0/−22
- src/noembed/Profiteur/DataFile.hs +0/−16
CHANGELOG.md view
@@ -1,5 +1,11 @@ # CHANGELOG +- 0.4.7.0 (2022-10-23)+ * Draw labels in the treemap (by Andrei Barbu)+ * On initialization, expand nodes until the first branch (by Andrei Barbu)+ * Expose `Profiteur.Core` and `Profiteur.Parser` as a library (by+ Alfredo Di Napoli)+ - 0.4.6.1 (2022-06-28) * Bump `aeson` dependency upper bound to 2.2 * Bump `bytestring` dependency upper bound to 0.12
README.md view
@@ -7,7 +7,11 @@ ------------ cabal install profiteur+ +Installation via nix + nix-shell -p haskellPackages.profiteur+ Usage -----
data/js/main.js view
@@ -13,6 +13,16 @@ var tm = new TreeMap(rc, selection, sorting, zoom); var details = new Details($('#details'), selection, sorting, zoom); selection.setSelectedNode(root);++ let currentNode = root;+ currentNode.select();+ currentNode.setExpanded(true);+ while(currentNode.children.length == 1) {+ currentNode = currentNode.children[0];+ currentNode.select();+ currentNode.setExpanded(true);+ }+ tb.scrollToNode(currentNode, true); } $(document).ready(function () {
data/js/tree-browser.js view
@@ -63,7 +63,7 @@ } }; -TreeBrowser.prototype.scrollToNode = function(node) {+TreeBrowser.prototype.scrollToNode = function(node, force) { var element = this.elements[node.id]; var position = element.position(); var top = this.container.scrollTop();@@ -71,7 +71,7 @@ var height = this.container.height(); var width = this.container.width(); - if (position.top < 0 || position.top >= height ||+ if (force || position.top < 0 || position.top >= height || position.left < 0 || position.left >= width) { this.container.scrollTop(top + position.top - height / 2); this.container.scrollLeft(left + position.left);
data/js/tree-map.js view
@@ -208,6 +208,26 @@ }, 50); }; +// Divide the label for a node into lines by wrapping.+function wrapTextToWidth(ctx, text, maxWidth) {+ var words = text.split('');+ var lines = [];+ var currentLine = words[0];++ for (var i = 1; i < words.length; i++) {+ var word = words[i];+ var width = ctx.measureText(currentLine + '' + word).width;+ if (width < maxWidth) {+ currentLine += '' + word;+ } else {+ lines.push(currentLine);+ currentLine = word;+ }+ }+ lines.push(currentLine);+ return lines;+}+ TreeMap.prototype.renderNode = function(node) { var _this = this; var context = this.canvas.getContext('2d');@@ -221,6 +241,19 @@ context.fillRect(rect.x, rect.y, rect.w, rect.h); context.strokeStyle = 'black'; context.strokeRect(rect.x, rect.y, rect.w, rect.h);++ context.font = '14px sans-serif';+ context.textBaseline = 'top';+ if (node == _this.selection.getSelectedNode()) {+ context.fillStyle = '#ffffff';+ } else {+ context.fillStyle = '#000000';+ }+ const textPadding = 3;+ const lines = wrapTextToWidth(context, node.name, rect.w-2*textPadding);+ for(var i = 0; i < lines.length; i++) {+ context.fillText(lines[i], rect.x+textPadding, rect.y+textPadding+10*i);+ } // Draw children on top. if (node.children.length > 0) {
+ lib/Profiteur/Core.hs view
@@ -0,0 +1,143 @@+--------------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+module Profiteur.Core+ ( CostCentre (..)+ , Node (..)+ , nodesFromCostCentre+ , NodeMap (..)+ , nodeMapFromNodes+ , nodeMapFromCostCentre+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (guard)+import qualified Data.Aeson as A+import qualified Data.HashMap.Strict as HMS+import Data.List (foldl')+import Data.Maybe (mapMaybe, maybeToList)+import qualified Data.Text as T+import qualified Data.Vector as V+++--------------------------------------------------------------------------------+type Id = T.Text+++--------------------------------------------------------------------------------+data CostCentre = CostCentre+ { ccName :: !T.Text+ , ccModule :: !T.Text+ , ccSrc :: !T.Text+ , ccId :: !Id+ , ccEntries :: !Int+ , ccIndividualTime :: !Double+ , ccIndividualAlloc :: !Double+ , ccInheritedTime :: !Double+ , ccInheritedAlloc :: !Double+ , ccChildren :: !(V.Vector CostCentre)+ } deriving (Show)+++--------------------------------------------------------------------------------+data Node = Node+ { nId :: !Id+ , nName :: !T.Text+ , nModule :: !T.Text+ , nSrc :: !T.Text+ , nEntries :: !Int+ , nTime :: !Double+ , nAlloc :: !Double+ , nChildren :: !(V.Vector Id)+ } deriving (Show)+++--------------------------------------------------------------------------------+-- | Returns the node and its (transitive) children.+nodesFromCostCentre :: CostCentre -> Maybe (Node, [Node])+nodesFromCostCentre cc+ | V.null (ccChildren cc), Just indiv' <- indiv =+ Just (indiv' {nId = ccId cc, nName = ccName cc}, [])+ | otherwise = do+ guard $ ccInheritedTime cc > 0 || ccInheritedAlloc cc > 0++ let (children, grandChildren) = unzip $+ mapMaybe nodesFromCostCentre (V.toList $ ccChildren cc)++ let allChildren = maybeToList indiv ++ children ++ concat grandChildren++ let self = Node+ { nId = ccId cc+ , nName = ccName cc+ , nModule = ccModule cc+ , nSrc = ccSrc cc+ , nEntries = ccEntries cc+ , nTime = ccInheritedTime cc+ , nAlloc = ccInheritedAlloc cc+ , nChildren = V.fromList $ map nId $+ maybeToList indiv ++ children+ }++ return (self, allChildren)+ where+ indiv = do+ guard $ ccIndividualTime cc > 0 || ccIndividualAlloc cc > 0+ return Node+ { nId = ccId cc <> ".indiv"+ , nName = ccName cc <> " (indiv)"+ , nModule = ccModule cc+ , nSrc = ccSrc cc+ , nEntries = ccEntries cc+ , nTime = ccIndividualTime cc+ , nAlloc = ccIndividualAlloc cc+ , nChildren = V.empty+ }+++--------------------------------------------------------------------------------+instance A.ToJSON Node where+ toJSON Node {..} = A.toJSON+ [ A.toJSON nName+ , A.toJSON nModule+ , A.toJSON nSrc+ , A.toJSON nEntries+ , A.toJSON nTime+ , A.toJSON nAlloc+ , A.toJSON nChildren+ ]+++--------------------------------------------------------------------------------+data NodeMap = NodeMap+ { nmNodes :: !(HMS.HashMap Id Node)+ , nmRoot :: !Id+ } deriving (Show)+++--------------------------------------------------------------------------------+instance A.ToJSON NodeMap where+ toJSON NodeMap {..} = A.toJSON+ [ A.toJSON nmNodes+ , A.toJSON nmRoot+ ]+++--------------------------------------------------------------------------------+nodeMapFromNodes :: Id -> [Node] -> NodeMap+nodeMapFromNodes root nodes = NodeMap+ { nmNodes = foldl' (\acc n -> HMS.insert (nId n) n acc) HMS.empty nodes+ , nmRoot = root+ }+++--------------------------------------------------------------------------------+nodeMapFromCostCentre :: CostCentre -> NodeMap+nodeMapFromCostCentre root =+ nodeMapFromNodes (ccId root) nodes+ where+ nodes = case nodesFromCostCentre root of+ Nothing -> []+ Just (n, ns) -> n : ns
+ lib/Profiteur/DataFile/Internal.hs view
@@ -0,0 +1,8 @@+module Profiteur.DataFile.Internal where++import Data.String++data DataType = JQueryFile | DataFile FilePath deriving (Show)++instance IsString DataType where+ fromString = DataFile
+ lib/Profiteur/Main.hs view
@@ -0,0 +1,110 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Profiteur.Main+ ( main+ ) where+++--------------------------------------------------------------------------------+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy.IO as TL+import Data.Version (showVersion)+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure)+import System.FilePath (takeBaseName)+import qualified System.IO as IO+++--------------------------------------------------------------------------------+import Paths_profiteur (version)+import Profiteur.Core+import Profiteur.Parser+import Profiteur.DataFile+++--------------------------------------------------------------------------------+writeReport :: IO.Handle -> String -> NodeMap -> IO ()+writeReport h profFile prof = do+ BC8.hPutStrLn h $+ "<!DOCTYPE html>\n\+ \<html>\n\+ \ <head>\n\+ \ <meta charset=\"UTF-8\">\n\+ \ <title>" `mappend` T.encodeUtf8 title `mappend` "</title>"++ BC8.hPutStr h "<script type=\"text/javascript\">var $prof = "+ BL.hPutStr h $ Aeson.encode prof+ BC8.hPutStrLn h ";</script>"++ BC8.hPutStrLn h "<style>"+ includeFile h "data/css/main.css"+ BC8.hPutStrLn h "</style>"++ includeJs JQueryFile+ includeJs "data/js/unicode.js"+ includeJs "data/js/model.js"+ includeJs "data/js/resizing-canvas.js"+ includeJs "data/js/node.js"+ includeJs "data/js/selection.js"+ includeJs "data/js/zoom.js"+ includeJs "data/js/details.js"+ includeJs "data/js/sorting.js"+ includeJs "data/js/tree-map.js"+ includeJs "data/js/tree-browser.js"+ includeJs "data/js/main.js"++ BC8.hPutStrLn h+ " </head>\n\+ \ <body>"+ includeFile h "data/html/body.html"+ BC8.hPutStrLn h+ " </body>\+ \</html>"+ where+ title = T.pack $ takeBaseName profFile++ includeJs file = do+ BC8.hPutStrLn h "<script type=\"text/javascript\">"+ includeFile h file+ BC8.hPutStrLn h "</script>"++--------------------------------------------------------------------------------+makeReport :: IO.Handle -> FilePath -> IO ()+makeReport h profFile = do+ profOrErr <- decode <$> TL.readFile profFile+ case profOrErr of+ Right prof ->+ writeReport h profFile $ nodeMapFromCostCentre prof+ Left err -> do+ putStrLnErr $ profFile ++ ": " ++ err+ exitFailure++--------------------------------------------------------------------------------+putStrLnErr :: String -> IO ()+putStrLnErr = IO.hPutStrLn IO.stderr++--------------------------------------------------------------------------------+main :: IO ()+main = do+ progName <- getProgName+ args <- getArgs+ case args of+ _ | "--version" `elem` args ->+ putStrLnErr (showVersion version)+ [profFile] ->+ let htmlFile = profFile ++ ".html"+ in IO.withBinaryFile htmlFile IO.WriteMode $ \h ->+ makeReport h profFile+ [profFile, "-"] ->+ makeReport IO.stdout profFile+ [profFile, htmlFile] ->+ IO.withBinaryFile htmlFile IO.WriteMode $ \h ->+ makeReport h profFile+ _ -> do+ putStrLnErr $ "Usage: " ++ progName ++ " <prof file> [<output file>]"+ putStrLnErr " <output file> \"-\" means STDOUT"+ exitFailure
+ lib/Profiteur/Parser.hs view
@@ -0,0 +1,71 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Profiteur.Parser+ ( decode+ , profileToCostCentre+ ) where+++--------------------------------------------------------------------------------+import qualified Data.IntMap as IM+import qualified Data.Scientific as Scientific+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V+import qualified GHC.Prof as Prof+import qualified GHC.Prof.Types as Prof++import Data.Maybe (fromMaybe)++--------------------------------------------------------------------------------+import Profiteur.Core++--------------------------------------------------------------------------------+decode :: TL.Text -> Either String CostCentre+decode txt = Prof.decode txt >>= profileToCostCentre+++--------------------------------------------------------------------------------+profileToCostCentre :: Prof.Profile -> Either String CostCentre+profileToCostCentre prof = do+ rootNo <- findRoot+ toCostCentreByNo rootNo+ where+ tree :: Prof.CostCentreTree+ tree = Prof.profileCostCentreTree prof++ findRoot :: Either String Prof.CostCentreNo+ findRoot = case IM.toList (Prof.costCentreParents tree) of+ [] -> Left "Could not find root node"+ ((_, no) : _) -> go no+ where+ go no = case IM.lookup no (Prof.costCentreParents tree) of+ Nothing -> Right no+ Just par -> go par++ toCostCentreByNo :: Prof.CostCentreNo -> Either String CostCentre+ toCostCentreByNo no = do+ cc <- maybe (Left $ "Could not find CCN " ++ show no) Right $+ IM.lookup no (Prof.costCentreNodes tree)+ toCostCentreByNode cc++ toCostCentreByNode :: Prof.CostCentre -> Either String CostCentre+ toCostCentreByNode cc = do+ let no = Prof.costCentreNo cc+ childrenNodes = maybe [] Set.toList $+ IM.lookup no (Prof.costCentreChildren tree)+ children <- V.mapM toCostCentreByNode (V.fromList childrenNodes)++ return CostCentre+ { ccName = Prof.costCentreName cc+ , ccModule = Prof.costCentreModule cc+ , ccSrc = fromMaybe mempty $ Prof.costCentreSrc cc+ , ccId = T.pack (show $ no)+ , ccEntries = fromIntegral (Prof.costCentreEntries cc)+ , ccIndividualTime = Scientific.toRealFloat (Prof.costCentreIndTime cc)+ , ccIndividualAlloc = Scientific.toRealFloat (Prof.costCentreIndAlloc cc)+ , ccInheritedTime = Scientific.toRealFloat (Prof.costCentreInhTime cc)+ , ccInheritedAlloc = Scientific.toRealFloat (Prof.costCentreInhAlloc cc)+ , ccChildren = children+ }
+ lib/embed/Profiteur/DataFile.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+module Profiteur.DataFile (+ includeFile,+ module Profiteur.DataFile.Internal+ ) where++import Profiteur.DataFile.Internal+import System.IO (Handle)+import qualified Data.ByteString as B+import Data.FileEmbed+import Control.Arrow+import qualified Language.Javascript.JQuery as JQuery+import Language.Haskell.TH (runIO)+import Data.Maybe++includeFile :: Handle -> DataType -> IO ()+includeFile h filePath = B.hPutStr h $ data' filePath+ where+ data' JQueryFile = $(embedFile =<< runIO JQuery.file)+ data' (DataFile fp) =+ fromMaybe (error $ "No such datafile: " ++ fp) $ lookup fp dataDirContents+ dataDirContents = map (first ("data/" ++)) $(embedDir "data")
+ lib/noembed/Profiteur/DataFile.hs view
@@ -0,0 +1,16 @@+module Profiteur.DataFile (+ includeFile,+ module Profiteur.DataFile.Internal+ ) where++import Paths_profiteur (getDataFileName)+import System.IO (Handle)+import qualified Data.ByteString.Lazy as BL+import qualified Language.Javascript.JQuery as JQuery+import Profiteur.DataFile.Internal++includeFile :: Handle -> DataType -> IO ()+includeFile h JQueryFile =+ BL.hPutStr h =<< BL.readFile =<< JQuery.file+includeFile h (DataFile filePath) =+ BL.hPutStr h =<< BL.readFile =<< getDataFileName filePath
profiteur.cabal view
@@ -1,5 +1,5 @@ Name: profiteur-Version: 0.4.6.1+Version: 0.4.7.0 Synopsis: Treemap visualiser for GHC prof files Description: Treemap visualiser for GHC prof files Homepage: http://github.com/jaspervdj/profiteur@@ -40,36 +40,41 @@ Type: git Location: git://github.com/jaspervdj/profiteur.git -Executable profiteur+Library Default-language: Haskell2010 Ghc-options: -Wall- Hs-source-dirs: src- Main-is: Main.hs-- Other-modules:+ Hs-source-dirs: lib+ Exposed-Modules: Profiteur.Core+ Profiteur.Main Profiteur.Parser+ Other-modules: Profiteur.DataFile Profiteur.DataFile.Internal Paths_profiteur- Build-depends: aeson >= 0.6 && < 2.2, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.12, containers >= 0.5 && < 0.7,- filepath >= 1.3 && < 1.5,+ filepath >= 1.4 && < 1.5, ghc-prof >= 1.3 && < 1.5, js-jquery >= 3.1 && < 3.4, scientific >= 0.3 && < 0.4,- text >= 0.11 && < 1.3,+ text >= 0.11 && < 2.1, unordered-containers >= 0.2 && < 0.3,- vector >= 0.10 && < 0.13-+ vector >= 0.10 && < 0.14 if flag(embed-data-files)- Hs-source-dirs: src/embed+ Hs-source-dirs: lib/embed Build-depends: file-embed >= 0.0.10 && < 0.0.12, template-haskell else- Hs-source-dirs: src/noembed+ Hs-source-dirs: lib/noembed++Executable profiteur+ Default-language: Haskell2010+ Ghc-options: -Wall+ Hs-source-dirs: src+ Main-is: Main.hs+ Build-depends: base, profiteur
src/Main.hs view
@@ -1,110 +1,7 @@ ---------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}-module Main- ( main- ) where------------------------------------------------------------------------------------import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy.IO as TL-import Data.Version (showVersion)-import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure)-import System.FilePath (takeBaseName)-import qualified System.IO as IO------------------------------------------------------------------------------------import Paths_profiteur (version)-import Profiteur.Core-import Profiteur.Parser-import Profiteur.DataFile+import qualified Profiteur.Main (main) ---------------------------------------------------------------------------------writeReport :: IO.Handle -> String -> NodeMap -> IO ()-writeReport h profFile prof = do- BC8.hPutStrLn h $- "<!DOCTYPE html>\n\- \<html>\n\- \ <head>\n\- \ <meta charset=\"UTF-8\">\n\- \ <title>" `mappend` T.encodeUtf8 title `mappend` "</title>"-- BC8.hPutStr h "<script type=\"text/javascript\">var $prof = "- BL.hPutStr h $ Aeson.encode prof- BC8.hPutStrLn h ";</script>"-- BC8.hPutStrLn h "<style>"- includeFile h "data/css/main.css"- BC8.hPutStrLn h "</style>"-- includeJs JQueryFile- includeJs "data/js/unicode.js"- includeJs "data/js/model.js"- includeJs "data/js/resizing-canvas.js"- includeJs "data/js/node.js"- includeJs "data/js/selection.js"- includeJs "data/js/zoom.js"- includeJs "data/js/details.js"- includeJs "data/js/sorting.js"- includeJs "data/js/tree-map.js"- includeJs "data/js/tree-browser.js"- includeJs "data/js/main.js"-- BC8.hPutStrLn h- " </head>\n\- \ <body>"- includeFile h "data/html/body.html"- BC8.hPutStrLn h- " </body>\- \</html>"- where- title = T.pack $ takeBaseName profFile-- includeJs file = do- BC8.hPutStrLn h "<script type=\"text/javascript\">"- includeFile h file- BC8.hPutStrLn h "</script>"-----------------------------------------------------------------------------------makeReport :: IO.Handle -> FilePath -> IO ()-makeReport h profFile = do- profOrErr <- decode <$> TL.readFile profFile- case profOrErr of- Right prof ->- writeReport h profFile $ nodeMapFromCostCentre prof- Left err -> do- putStrLnErr $ profFile ++ ": " ++ err- exitFailure-----------------------------------------------------------------------------------putStrLnErr :: String -> IO ()-putStrLnErr = IO.hPutStrLn IO.stderr---------------------------------------------------------------------------------- main :: IO ()-main = do- progName <- getProgName- args <- getArgs- case args of- _ | "--version" `elem` args ->- putStrLnErr (showVersion version)- [profFile] ->- let htmlFile = profFile ++ ".html"- in IO.withBinaryFile htmlFile IO.WriteMode $ \h ->- makeReport h profFile- [profFile, "-"] ->- makeReport IO.stdout profFile- [profFile, htmlFile] ->- IO.withBinaryFile htmlFile IO.WriteMode $ \h ->- makeReport h profFile- _ -> do- putStrLnErr $ "Usage: " ++ progName ++ " <prof file> [<output file>]"- putStrLnErr " <output file> \"-\" means STDOUT"- exitFailure+main = Profiteur.Main.main
− src/Profiteur/Core.hs
@@ -1,143 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-}-module Profiteur.Core- ( CostCentre (..)- , Node (..)- , nodesFromCostCentre- , NodeMap (..)- , nodeMapFromNodes- , nodeMapFromCostCentre- ) where------------------------------------------------------------------------------------import Control.Monad (guard)-import qualified Data.Aeson as A-import qualified Data.HashMap.Strict as HMS-import Data.List (foldl')-import Data.Maybe (mapMaybe, maybeToList)-import qualified Data.Text as T-import qualified Data.Vector as V------------------------------------------------------------------------------------type Id = T.Text------------------------------------------------------------------------------------data CostCentre = CostCentre- { ccName :: !T.Text- , ccModule :: !T.Text- , ccSrc :: !T.Text- , ccId :: !Id- , ccEntries :: !Int- , ccIndividualTime :: !Double- , ccIndividualAlloc :: !Double- , ccInheritedTime :: !Double- , ccInheritedAlloc :: !Double- , ccChildren :: !(V.Vector CostCentre)- } deriving (Show)------------------------------------------------------------------------------------data Node = Node- { nId :: !Id- , nName :: !T.Text- , nModule :: !T.Text- , nSrc :: !T.Text- , nEntries :: !Int- , nTime :: !Double- , nAlloc :: !Double- , nChildren :: !(V.Vector Id)- } deriving (Show)-------------------------------------------------------------------------------------- | Returns the node and its (transitive) children.-nodesFromCostCentre :: CostCentre -> Maybe (Node, [Node])-nodesFromCostCentre cc- | V.null (ccChildren cc), Just indiv' <- indiv =- Just (indiv' {nId = ccId cc, nName = ccName cc}, [])- | otherwise = do- guard $ ccInheritedTime cc > 0 || ccInheritedAlloc cc > 0-- let (children, grandChildren) = unzip $- mapMaybe nodesFromCostCentre (V.toList $ ccChildren cc)-- let allChildren = maybeToList indiv ++ children ++ concat grandChildren-- let self = Node- { nId = ccId cc- , nName = ccName cc- , nModule = ccModule cc- , nSrc = ccSrc cc- , nEntries = ccEntries cc- , nTime = ccInheritedTime cc- , nAlloc = ccInheritedAlloc cc- , nChildren = V.fromList $ map nId $- maybeToList indiv ++ children- }-- return (self, allChildren)- where- indiv = do- guard $ ccIndividualTime cc > 0 || ccIndividualAlloc cc > 0- return Node- { nId = ccId cc <> ".indiv"- , nName = ccName cc <> " (indiv)"- , nModule = ccModule cc- , nSrc = ccSrc cc- , nEntries = ccEntries cc- , nTime = ccIndividualTime cc- , nAlloc = ccIndividualAlloc cc- , nChildren = V.empty- }------------------------------------------------------------------------------------instance A.ToJSON Node where- toJSON Node {..} = A.toJSON- [ A.toJSON nName- , A.toJSON nModule- , A.toJSON nSrc- , A.toJSON nEntries- , A.toJSON nTime- , A.toJSON nAlloc- , A.toJSON nChildren- ]------------------------------------------------------------------------------------data NodeMap = NodeMap- { nmNodes :: !(HMS.HashMap Id Node)- , nmRoot :: !Id- } deriving (Show)------------------------------------------------------------------------------------instance A.ToJSON NodeMap where- toJSON NodeMap {..} = A.toJSON- [ A.toJSON nmNodes- , A.toJSON nmRoot- ]------------------------------------------------------------------------------------nodeMapFromNodes :: Id -> [Node] -> NodeMap-nodeMapFromNodes root nodes = NodeMap- { nmNodes = foldl' (\acc n -> HMS.insert (nId n) n acc) HMS.empty nodes- , nmRoot = root- }------------------------------------------------------------------------------------nodeMapFromCostCentre :: CostCentre -> NodeMap-nodeMapFromCostCentre root =- nodeMapFromNodes (ccId root) nodes- where- nodes = case nodesFromCostCentre root of- Nothing -> []- Just (n, ns) -> n : ns
− src/Profiteur/DataFile/Internal.hs
@@ -1,8 +0,0 @@-module Profiteur.DataFile.Internal where--import Data.String--data DataType = JQueryFile | DataFile FilePath deriving (Show)--instance IsString DataType where- fromString = DataFile
− src/Profiteur/Parser.hs
@@ -1,70 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}-module Profiteur.Parser- ( decode- ) where------------------------------------------------------------------------------------import qualified Data.IntMap as IM-import qualified Data.Scientific as Scientific-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as V-import qualified GHC.Prof as Prof-import qualified GHC.Prof.Types as Prof--import Data.Maybe (fromMaybe)-----------------------------------------------------------------------------------import Profiteur.Core-----------------------------------------------------------------------------------decode :: TL.Text -> Either String CostCentre-decode txt = Prof.decode txt >>= profileToCostCentre------------------------------------------------------------------------------------profileToCostCentre :: Prof.Profile -> Either String CostCentre-profileToCostCentre prof = do- rootNo <- findRoot- toCostCentreByNo rootNo- where- tree :: Prof.CostCentreTree- tree = Prof.profileCostCentreTree prof-- findRoot :: Either String Prof.CostCentreNo- findRoot = case IM.toList (Prof.costCentreParents tree) of- [] -> Left "Could not find root node"- ((_, no) : _) -> go no- where- go no = case IM.lookup no (Prof.costCentreParents tree) of- Nothing -> Right no- Just par -> go par-- toCostCentreByNo :: Prof.CostCentreNo -> Either String CostCentre- toCostCentreByNo no = do- cc <- maybe (Left $ "Could not find CCN " ++ show no) Right $- IM.lookup no (Prof.costCentreNodes tree)- toCostCentreByNode cc-- toCostCentreByNode :: Prof.CostCentre -> Either String CostCentre- toCostCentreByNode cc = do- let no = Prof.costCentreNo cc- childrenNodes = maybe [] Set.toList $- IM.lookup no (Prof.costCentreChildren tree)- children <- V.mapM toCostCentreByNode (V.fromList childrenNodes)-- return CostCentre- { ccName = Prof.costCentreName cc- , ccModule = Prof.costCentreModule cc- , ccSrc = fromMaybe mempty $ Prof.costCentreSrc cc- , ccId = T.pack (show $ no)- , ccEntries = fromIntegral (Prof.costCentreEntries cc)- , ccIndividualTime = Scientific.toRealFloat (Prof.costCentreIndTime cc)- , ccIndividualAlloc = Scientific.toRealFloat (Prof.costCentreIndAlloc cc)- , ccInheritedTime = Scientific.toRealFloat (Prof.costCentreInhTime cc)- , ccInheritedAlloc = Scientific.toRealFloat (Prof.costCentreInhAlloc cc)- , ccChildren = children- }
− src/embed/Profiteur/DataFile.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Profiteur.DataFile (- includeFile,- module Profiteur.DataFile.Internal- ) where--import Profiteur.DataFile.Internal-import System.IO (Handle)-import qualified Data.ByteString as B-import Data.FileEmbed-import Control.Arrow-import qualified Language.Javascript.JQuery as JQuery-import Language.Haskell.TH (runIO)-import Data.Maybe--includeFile :: Handle -> DataType -> IO ()-includeFile h filePath = B.hPutStr h $ data' filePath- where- data' JQueryFile = $(embedFile =<< runIO JQuery.file)- data' (DataFile fp) =- fromMaybe (error $ "No such datafile: " ++ fp) $ lookup fp dataDirContents- dataDirContents = map (first ("data/" ++)) $(embedDir "data")
− src/noembed/Profiteur/DataFile.hs
@@ -1,16 +0,0 @@-module Profiteur.DataFile (- includeFile,- module Profiteur.DataFile.Internal- ) where--import Paths_profiteur (getDataFileName)-import System.IO (Handle)-import qualified Data.ByteString.Lazy as BL-import qualified Language.Javascript.JQuery as JQuery-import Profiteur.DataFile.Internal--includeFile :: Handle -> DataType -> IO ()-includeFile h JQueryFile =- BL.hPutStr h =<< BL.readFile =<< JQuery.file-includeFile h (DataFile filePath) =- BL.hPutStr h =<< BL.readFile =<< getDataFileName filePath