diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -7,7 +7,11 @@
------------
cabal install profiteur
+
+Installation via nix
+ nix-shell -p haskellPackages.profiteur
+
Usage
-----
diff --git a/data/js/main.js b/data/js/main.js
--- a/data/js/main.js
+++ b/data/js/main.js
@@ -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 () {
diff --git a/data/js/tree-browser.js b/data/js/tree-browser.js
--- a/data/js/tree-browser.js
+++ b/data/js/tree-browser.js
@@ -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);
diff --git a/data/js/tree-map.js b/data/js/tree-map.js
--- a/data/js/tree-map.js
+++ b/data/js/tree-map.js
@@ -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) {
diff --git a/lib/Profiteur/Core.hs b/lib/Profiteur/Core.hs
new file mode 100644
--- /dev/null
+++ b/lib/Profiteur/Core.hs
@@ -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
diff --git a/lib/Profiteur/DataFile/Internal.hs b/lib/Profiteur/DataFile/Internal.hs
new file mode 100644
--- /dev/null
+++ b/lib/Profiteur/DataFile/Internal.hs
@@ -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
diff --git a/lib/Profiteur/Main.hs b/lib/Profiteur/Main.hs
new file mode 100644
--- /dev/null
+++ b/lib/Profiteur/Main.hs
@@ -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 $
+ "\n\
+ \\n\
+ \ \n\
+ \ \n\
+ \ " `mappend` T.encodeUtf8 title `mappend` ""
+
+ BC8.hPutStr h ""
+
+ BC8.hPutStrLn h ""
+
+ 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
+ " \n\
+ \ "
+ includeFile h "data/html/body.html"
+ BC8.hPutStrLn h
+ " \
+ \"
+ where
+ title = T.pack $ takeBaseName profFile
+
+ includeJs file = do
+ BC8.hPutStrLn h ""
+
+--------------------------------------------------------------------------------
+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 ++ " [