profiteur 0.4.1.0 → 0.4.2.0
raw patch · 4 files changed
+61/−70 lines, 4 filesdep +containersdep +ghc-profdep +scientificdep −attoparsecdep ~aesondep ~vector
Dependencies added: containers, ghc-prof, scientific
Dependencies removed: attoparsec
Dependency ranges changed: aeson, vector
Files
- CHANGELOG.md +5/−0
- profiteur.cabal +6/−4
- src/Main.hs +2/−3
- src/Profiteur/Parser.hs +48/−63
CHANGELOG.md view
@@ -1,3 +1,8 @@+- 0.4.2.0+ * Use the new `ghc-prof` instead of our own hacky prof parser+ * Bump `aeson` dependency to 1.1+ * Bump `vector` dependency to 0.12+ - 0.4.1.0 * Format numbers in "Details" to have 3 decimal places * Move name below controls in "Details"
profiteur.cabal view
@@ -1,5 +1,5 @@ Name: profiteur-Version: 0.4.1.0+Version: 0.4.2.0 Synopsis: Treemap visualiser for GHC prof files Description: Treemap visualiser for GHC prof files Homepage: http://github.com/jaspervdj/profiteur@@ -45,12 +45,14 @@ Profiteur.Parser Build-depends:- aeson >= 0.6 && < 1.1,- attoparsec >= 0.10 && < 0.14,+ aeson >= 0.6 && < 1.2, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11,+ containers >= 0.5 && < 0.6, filepath >= 1.3 && < 1.5,+ ghc-prof >= 1.3 && < 1.4, js-jquery >= 3.1 && < 3.2,+ scientific >= 0.3 && < 0.4, text >= 0.11 && < 1.3, unordered-containers >= 0.2 && < 0.3,- vector >= 0.10 && < 0.12+ vector >= 0.10 && < 0.13
src/Main.hs view
@@ -7,12 +7,11 @@ -------------------------------------------------------------------------------- import qualified Data.Aeson as Aeson-import qualified Data.Attoparsec.ByteString as AP-import qualified Data.ByteString as B 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 qualified Language.Javascript.JQuery as JQuery import System.Environment (getArgs, getProgName) import System.Exit (exitFailure)@@ -89,7 +88,7 @@ args <- getArgs case args of [profFile] -> do- profOrErr <- AP.parseOnly parseFile <$> B.readFile profFile+ profOrErr <- decode <$> TL.readFile profFile case profOrErr of Right prof -> writeReport profFile $ nodeMapFromCostCentre prof
src/Profiteur/Parser.hs view
@@ -1,18 +1,19 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Profiteur.Parser- ( parseFile+ ( decode ) where ---------------------------------------------------------------------------------import Control.Monad (replicateM_)-import Data.Attoparsec.ByteString as AP-import Data.Attoparsec.ByteString.Char8 as AP8-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vector as V+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 --------------------------------------------------------------------------------@@ -20,65 +21,49 @@ ---------------------------------------------------------------------------------parseFile :: AP.Parser CostCentre-parseFile = do- -- Hacky stuff.- _ <- AP.manyTill AP8.anyChar (AP.try $ AP8.string "COST CENTRE")- _ <- AP.manyTill AP8.anyChar (AP.try $ AP8.string "COST CENTRE")- _ <- AP.skipWhile (not . AP8.isEndOfLine)- _ <- AP8.skipSpace- paresCostCentre 0------------------------------------------------------------------------------------paresCostCentre :: Int -> AP.Parser CostCentre-paresCostCentre indent = do- replicateM_ indent $ AP8.char8 ' '- canonical <- identifier- skipHorizontalSpace- module' <- identifier- skipHorizontalSpace- id' <- T.pack . show <$> (AP8.decimal :: AP.Parser Int)-- skipHorizontalSpace- entries <- AP8.decimal- skipHorizontalSpace- individualTime <- AP8.double- skipHorizontalSpace- individualAlloc <- AP8.double- skipHorizontalSpace- inheritedTime <- AP8.double- skipHorizontalSpace- inheritedAlloc <- AP8.double- skipToEol-- children <- AP.many' $ paresCostCentre (indent + 1)-- return CostCentre- { ccName = canonical- , ccModule = module'- , ccId = id'- , ccEntries = entries- , ccIndividualTime = individualTime- , ccIndividualAlloc = individualAlloc- , ccInheritedTime = inheritedTime- , ccInheritedAlloc = inheritedAlloc- , ccChildren = V.fromList children- }+decode :: TL.Text -> Either String CostCentre+decode txt = Prof.decode txt >>= profileToCostCentre ---------------------------------------------------------------------------------identifier :: AP.Parser Text-identifier = T.decodeUtf8 <$> AP8.takeWhile (not . AP8.isSpace)+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 ----------------------------------------------------------------------------------skipHorizontalSpace :: AP.Parser ()-skipHorizontalSpace = AP.skipWhile AP8.isHorizontalSpace+ 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) ----------------------------------------------------------------------------------skipToEol :: AP.Parser ()-skipToEol = do- AP.skipWhile (not . AP8.isEndOfLine)- AP8.endOfLine+ return CostCentre+ { ccName = Prof.costCentreName cc+ , ccModule = Prof.costCentreModule 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+ }