Initial

5 files changed, 292 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c33954f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..a6b45e8
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Main where
+
+import Prelude hiding (splitAt)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Short as BSS
+import qualified Data.Sequence as Seq
+import Data.Sequence (Seq, (<|), pattern (:<|))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import System.Environment
+import System.Exit
+
+import Brick
+import Brick.Widgets.List
+import Graphics.Vty.Attributes
+import Graphics.Vty.Input.Events (Event(..), Key(..))
+
+import Parse
+import Prof
+
+
+data Name = NList
+  deriving (Show, Eq, Ord)
+
+-- Row indent subtree
+data Row = Row Int (ProfTree Bool)
+
+data AppState
+    = AppState { aList :: GenericList Name Seq Row }
+
+initAppState :: Prof () -> AppState
+initAppState doc =
+    let Prof tree = fmap (const False) doc
+    in AppState (list NList (Seq.singleton (Row 0 tree)) 1)
+
+rowEntry :: Row -> Entry
+rowEntry (Row _ (Node e _ _)) = e
+rowEntry (Row _ (Leaf e)) = e
+
+buildSubtree :: Int -> ProfTree Bool -> [Row]
+buildSubtree indent tree@(Leaf _) = [Row indent tree]
+buildSubtree indent tree@(Node _ False _) = [Row indent tree]
+buildSubtree indent tree@(Node _ True ch) =
+    Row indent tree : concatMap (buildSubtree (indent + 1)) ch
+
+draw :: AppState -> [Widget Name]
+draw app = [renderList func True (aList app)]
+  where func selected row@(Row indent _) =
+          let selfunc1 = if selected then withAttr (attrName "selectedRow") else id
+              selfunc2 = if selected then withAttr (attrName "selected") else id
+              entry = rowEntry row
+              TimeShare inhTime inhAlloc = eInherited entry
+          in selfunc1 $
+              hBox [txt (T.replicate indent (T.singleton ' '))
+                   ,selfunc2 (txt (mconcat
+                       [T.decodeUtf8 (BSS.fromShort (eCS entry))
+                       ,T.pack "  "
+                       ,T.decodeUtf8 (BSS.fromShort (eModule entry))]))
+                   ,vLimit 1 (fill ' ')
+                   ,txt (T.pack (show inhTime ++ " " ++ show inhAlloc))]
+
+handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState)
+handleEvent app (VtyEvent (EvKey (KChar 'q') _)) = halt app
+handleEvent app (VtyEvent event) = do
+    list' <- handleListEventVi fallback event (aList app)
+    continue (app { aList = list' })
+  where
+    fallback (EvKey (KChar ' ') []) l =
+        case listSelectedElement l of
+          Just (_, Row _ (Leaf _)) -> return l
+          Just (index, Row indent (Node entry False ch)) ->
+              let (preelts, _ :<| postelts) = splitAt index (listElements l)
+                  mid = Seq.fromList (buildSubtree indent (Node entry True ch))
+              in return (listReplace (preelts <> mid <> postelts) (Just index) l)
+          Just (index, Row indent (Node entry True ch)) ->
+              let (preelts, elts) = splitAt index (listElements l)
+                  sublen = length (buildSubtree indent (Node entry True ch))
+                  postelts = Seq.drop sublen elts
+              in return (listReplace (preelts <> (Row indent (Node entry False ch) <| postelts)) (Just index) l)
+          Nothing -> return l
+    fallback e l = handleListEvent e l
+handleEvent app _ = continue app
+
+main :: IO ()
+main = do
+    args <- getArgs
+    inputFile <- case args of
+      ["-v"] -> do
+          putStrLn "ghc-prof-reader by Tom Smeding"
+          putStrLn "Usage: ghc-prof-reader <file.prof>"
+          exitSuccess
+      [fname] -> BS.readFile fname
+      _ -> die "Usage: ghc-prof-reader <file.prof>"
+
+    putStrLn "Reading..."
+    doc <- case parseProf inputFile of
+      Right doc -> return doc
+      Left err -> die err
+    doc `seq` putStrLn "Imported"
+
+    _ <- defaultMain
+        (App { appDraw = draw
+             , appChooseCursor = \_ l -> if null l then Nothing else Just (head l)
+             , appHandleEvent = handleEvent
+             , appStartEvent = return
+             , appAttrMap = \_ -> attrMap defAttr
+                    [(attrName "selected", withStyle defAttr standout)
+                    ,(attrName "selectedRow", withStyle defAttr underline)] })
+        (initAppState doc)
+    return ()
diff --git a/Parse.hs b/Parse.hs
new file mode 100644
index 0000000..0ee5004
--- /dev/null
+++ b/Parse.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+module Parse (parseProf) where
+
+import Control.Applicative ((<|>))
+import Control.Monad (guard)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Short as BSS
+import Data.ByteString (ByteString)
+import Data.Char
+import Data.List (unfoldr)
+
+import Prof
+
+
+data Columns
+    = Columns { cMod :: Int
+              , cSrc :: Int
+              , cNo  :: Int
+              , cCnt :: Int
+              , cIvT :: Int  -- individual time/alloc
+              , cIvA :: Int
+              , cIhT :: Int  -- inherited time/alloc
+              , cIhA :: Int }
+  deriving (Show)
+
+parseProf :: ByteString -> Either String (Prof ())
+parseProf input = do
+    (cols, lns) <- maybe (Left "Did not find tree header") Right (findTree (BS.split 10 input))
+    lns' <- concat <$> mapM (parseLine cols) lns
+    case buildTree lns' of
+      Just (tree, []) -> return (Prof tree)
+      Just (_, l) -> Left ("Found " ++ show (length l) ++ " unexpected lines after tree")
+      Nothing -> Left "Empty tree found"
+
+parseLine :: Columns -> ByteString -> Either String [(Int, Entry)]
+parseLine _ line | BS.null line = Right []
+parseLine cols line = either (\err -> Left (err ++ ": <" ++ BS8.unpack line ++ ">")) Right $ do
+    let indent = BS.length (BS.takeWhile (== 32) line)
+        scs  = getCol 0 (cMod cols)
+        smod = getCol (cMod cols) (cSrc cols)
+        ssrc = getCol (cSrc cols) (cNo  cols)
+        scnt = getCol (cCnt cols) (cIvT cols)
+        sivt = getCol (cIvT cols) (cIvA cols)
+        siva = getCol (cIvA cols) (cIhT cols)
+        siht = getCol (cIhT cols) (cIhA cols)
+        siha = getCol (cIhA cols) (BS.length line)
+    smod' <- nonEmpty smod "module"
+    ssrc' <- nonEmpty ssrc "src"
+    ncnt <- parseInt scnt "entries"
+    fivt <- parseFloat sivt "individual %time"
+    fiva <- parseFloat siva "individual %alloc"
+    fiht <- parseFloat siht "inherited %time"
+    fiha <- parseFloat siha "inherited %alloc"
+    return [(indent, Entry { eCS = BSS.toShort scs
+                           , eModule = BSS.toShort smod'
+                           , eSrc = BSS.toShort ssrc'
+                           , eCount = ncnt
+                           , eIndividual = TimeShare fivt fiva
+                           , eInherited = TimeShare fiht fiha })]
+  where
+    getCol :: Int -> Int -> ByteString
+    getCol from to =
+        let part = BS.drop from (BS.take to line)
+        in BS.dropWhile (== 32) (BS.dropWhileEnd (== 32) part)
+
+    nonEmpty bs descr = if BS.null bs then Left ("Unexpected empty " ++ descr ++ " field") else Right bs
+
+    parseInt bs descr = case BS8.readInt bs of
+                          Just (n, rest) | BS.null rest -> Right n
+                          _ -> Left ("Cannot parse integer from '" ++ BS8.unpack bs ++ "' in " ++ descr ++ " field: <" ++ BS8.unpack bs ++ ">")
+
+    parseFloat bs descr =
+        let mres = do
+                (whole, bs1) <- BS8.readInt bs
+                guard (not (BS.null bs1) && BS.head bs1 == fromIntegral (ord '.'))
+                let sfract = BS.tail bs1
+                (fract, bs2) <- BS8.readInt sfract
+                guard (BS.null bs2)
+                return (fromIntegral whole + fromIntegral fract / 10 ^ BS.length sfract)
+        in case mres of
+             Just f -> Right f
+             Nothing -> Left ("Cannot parse float from '" ++ BS8.unpack bs ++ "' in " ++ descr ++ " field: <" ++ BS8.unpack bs ++ ">")
+
+findTree :: [ByteString] -> Maybe (Columns, [ByteString])
+findTree [] = Nothing
+findTree (ln:lns) = fmap (,lns) (parseLeadingTreeLine ln) <|> findTree lns
+
+parseLeadingTreeLine :: ByteString -> Maybe Columns
+parseLeadingTreeLine bs = do
+    (0,      bs1) <- findCol "COST CENTRE" 0 bs
+    (cmod,   bs2) <- findCol "MODULE"      11 bs1
+    (csrc,   bs3) <- findCol "SRC"         (cmod+6) bs2
+    (cno,    bs4) <- findCol "no."         (csrc+3) bs3
+    (centr,  bs5) <- findCol "entries"     (cno+3) bs4
+    (civt,   bs6) <- findCol "%time"       (centr+7) bs5
+    (civa,   bs7) <- findCol "%alloc"      (civt+5) bs6
+    (ciht,   bs8) <- findCol "%time"       (civa+6) bs7
+    (_ciha, _bs9) <- findCol "%alloc"      (ciht+5) bs8
+    return $ Columns { cMod = cmod
+                     , cSrc = csrc
+                     , cNo = cno
+                     , cCnt = cno + 5
+                     , cIvT = centr + 6
+                     , cIvA = civt + 4
+                     , cIhT = civa + 5
+                     , cIhA = ciht + 4 }
+  where
+    findCol :: String -> Int -> ByteString -> Maybe (Int, ByteString)
+    findCol stag from = \line ->
+        case go 0 line of
+          Nothing -> Nothing
+          Just (col, rest) -> Just (from + col, rest)
+      where
+        tag :: ByteString
+        tag = BS.pack (map (fromIntegral . ord) stag)
+
+        go :: Int -> ByteString -> Maybe (Int, ByteString)
+        go !idx line
+          | BS.length line < BS.length tag = Nothing
+          | BS.take (BS.length tag) line == tag = Just (idx, BS.drop (BS.length tag) line)
+          | otherwise = go (idx + 1) (BS.tail line)
+
+buildTree :: [(Int, Entry)] -> Maybe (ProfTree (), [(Int, Entry)])
+buildTree [] = Nothing
+buildTree ((depth, entry) : items) =
+    let (below, after) = span ((> depth) . fst) items
+        subs = unfoldr buildTree below
+    in Just (Node entry () subs, after)
diff --git a/Prof.hs b/Prof.hs
new file mode 100644
index 0000000..28bfaca
--- /dev/null
+++ b/Prof.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveFunctor #-}
+module Prof where
+
+import Data.ByteString.Short (ShortByteString)
+
+
+data Prof a
+    = Prof { pTree :: ProfTree a }
+  deriving (Show, Functor)
+
+data ProfTree a
+    = Leaf Entry
+    | Node Entry a [ProfTree a]
+  deriving (Show, Functor)
+
+data Entry
+    = Entry { eCS :: ShortByteString
+            , eModule :: ShortByteString
+            , eSrc :: ShortByteString
+            , eCount :: Int
+            , eIndividual :: TimeShare
+            , eInherited :: TimeShare }
+  deriving (Show)
+
+data TimeShare
+    = TimeShare { tsTime :: Double
+                , tsAlloc :: Double }
+  deriving (Show)
diff --git a/ghc-prof-reader.cabal b/ghc-prof-reader.cabal
new file mode 100644
index 0000000..ee2bae2
--- /dev/null
+++ b/ghc-prof-reader.cabal
@@ -0,0 +1,21 @@
+cabal-version:       >=1.10
+name:                ghc-prof-reader
+synopsis:            Tree traversal app for GHC profiling output
+version:             0.0.1.0
+license:             MIT
+author:              Tom Smeding
+maintainer:          tom.smeding@gmail.com
+build-type:          Simple
+
+executable ghc-prof-reader
+  main-is:             Main.hs
+  other-modules:       Parse, Prof
+  build-depends:       base >= 4.13 && < 4.15,
+                       containers >= 0.6.4 && < 0.7,
+                       bytestring >= 0.10.12 && < 0.11,
+                       brick >= 0.57 && < 0.58,
+                       vty,
+                       text >= 1.2.4 && < 1.3
+  hs-source-dirs:      .
+  default-language:    Haskell2010
+  ghc-options:         -Wall -O2 -threaded