diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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" diff --git a/profiteur.cabal b/profiteur.cabal --- a/profiteur.cabal +++ b/profiteur.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Profiteur/Parser.hs b/src/Profiteur/Parser.hs --- a/src/Profiteur/Parser.hs +++ b/src/Profiteur/Parser.hs @@ -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 + }