viewprof (empty) → 0.0.0
raw patch · 5 files changed
+423/−0 lines, 5 filesdep +basedep +brickdep +containerssetup-changed
Dependencies added: base, brick, containers, ghc-prof, lens, scientific, text, vector, vector-algorithms, vty
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- bin/viewprof.hs +354/−0
- viewprof.cabal +32/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for viewprof++## 0.0.0 (2017-01-20)++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Mitsutoshi Aoe++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Mitsutoshi Aoe nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bin/viewprof.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where+import Control.Arrow ((&&&))+import Control.Monad+import Data.Foldable+import Data.Function (on)+import Data.List.NonEmpty+import Data.Maybe+import System.Environment+import Text.Printf+import qualified Data.List.NonEmpty as NE++import Brick hiding (on)+import Control.Lens hiding (views)+import Data.Set (Set)+import Graphics.Vty+import qualified Brick+import qualified Brick.Widgets.Border as Brick+import qualified Brick.Widgets.Center as Brick+import qualified Data.Scientific as Sci+import qualified Data.Set as Set+import qualified Data.Text.Lazy.IO as TL+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Merge as Merge+import qualified GHC.Prof as Prof++data Profile = Profile+ { _report :: Prof.Profile+ , _views :: NonEmpty View+ , _modalView :: Maybe ModalView+ , _lastKeyEvent :: !(Maybe (Key, [Modifier]))+ }++data View+ = AggregatesView+ { _costCentres :: !(V.Vector Prof.AggregateCostCentre)+ , _focus :: !Int+ }+ | CallSitesView+ { _callee :: !Prof.AggregateCostCentre+ , _callSites :: !(V.Vector (Prof.CallSite Prof.AggregateCostCentre))+ , _focus :: !Int+ , _expanded :: !(Set Int)+ }+ | ModulesView+ { _modules :: !(V.Vector Prof.AggregateModule)+ , _focus :: !Int+ }++data ModalView+ = InfoView+ | HelpView++makeLenses ''Profile+makeLenses ''View++data Name+ = AggregatesViewport+ | CallSitesViewport+ | ModulesViewport+ | AggregatesCache !Int+ | CallSitesCache !Int+ | ModulesCache !Int+ deriving (Eq, Ord, Show)++main :: IO ()+main = do+ path:_ <- getArgs+ profile <- parseProfile path+ void $ defaultMain app profile++parseProfile :: FilePath -> IO Profile+parseProfile path = do+ contents <- TL.readFile path+ case Prof.decode contents of+ Left reason -> fail reason+ Right prof -> return Profile+ { _report = prof+ , _views = AggregatesView+ { _costCentres = V.fromList (Prof.aggregateCostCentres prof)+ , _focus = 0+ } :| []+ , _modalView = Nothing+ , _lastKeyEvent = Nothing+ }++app :: App Profile e Name+app = App+ { appDraw = drawProfile+ , appChooseCursor = neverShowCursor+ , appHandleEvent = handleProfileEvent+ , appStartEvent = return+ , appAttrMap = const $ attrMap defAttr+ [ (selectedAttr, black `Brick.on` white)+ ]+ }++handleProfileEvent :: Profile -> BrickEvent Name e -> EventM Name (Next Profile)+handleProfileEvent prof@Profile {..} ev = case ev of+ VtyEvent vtyEv -> case vtyEv of+ EvResize {} -> do+ invalidateCache+ continue prof+ EvKey key []+ | key `elem` [KEsc, KChar 'q'] -> if+ | Just _ <- prof ^. modalView -> do+ invalidateCache+ continue $! prof & modalView .~ Nothing+ | null (NE.tail (prof ^. views)) -> halt prof+ | otherwise -> do+ invalidateCache+ continue $! popView prof+ | key `elem` [KUp, KChar 'k'] -> do+ let !pos = prof ^. currentFocus+ for_ [pos, pos-1] $ invalidateCacheEntry . currentCacheEntry prof+ continue $! moveUp prof+ | key `elem` [KDown, KChar 'j'] -> do+ let !pos = prof ^. currentFocus+ for_ [pos, pos+1] $ invalidateCacheEntry . currentCacheEntry prof+ continue $! moveDown prof+ | key `elem` [KChar 'C'] -> do+ invalidateCache+ continue $! displayCostCentres prof+ | key `elem` [KChar 'M'] -> do+ invalidateCache+ continue $! displayModules prof+ | key `elem` [KChar 'g'] ->+ if prof ^. lastKeyEvent == Just (KChar 'g', [])+ then do+ invalidateCache+ continue $! moveToTop $ prof & lastKeyEvent .~ Nothing+ else+ continue $! prof & lastKeyEvent .~ Just (key, [])+ | key `elem` [KChar 'G'] -> do+ invalidateCache+ continue $! moveToEnd prof+ | key `elem` [KChar 'i'] ->+ continue $! prof & modalView ?~ InfoView+ | key `elem` [KChar 'h', KChar '?'] ->+ continue $! prof & modalView ?~ HelpView+ _ -> case NE.head _views of+ AggregatesView {} -> case vtyEv of+ EvKey (KChar 't') [] -> do+ invalidateCache+ continue $! sortCostCentresBy+ (Prof.aggregateCostCentreTime &&& Prof.aggregateCostCentreAlloc)+ prof+ EvKey (KChar 'a') [] -> do+ invalidateCache+ continue $! sortCostCentresBy+ (Prof.aggregateCostCentreAlloc &&& Prof.aggregateCostCentreTime)+ prof+ EvKey (KChar 'e') [] -> do+ invalidateCache+ continue $! sortCostCentresBy+ Prof.aggregateCostCentreEntries+ prof+ EvKey key []+ | key `elem` [KEnter] -> do+ invalidateCache+ continue $! displayCallers prof+ _ -> continue prof+ CallSitesView {} -> case vtyEv of+ EvKey (KChar 't') [] -> do+ invalidateCache+ continue $! sortCallSitesBy+ (Prof.callSiteContribTime &&& Prof.callSiteContribAlloc)+ prof+ EvKey (KChar 'a') [] -> do+ invalidateCache+ continue $! sortCallSitesBy+ (Prof.callSiteContribAlloc &&& Prof.callSiteContribTime)+ prof+ EvKey (KChar 'e') [] -> do+ invalidateCache+ continue $! sortCallSitesBy+ Prof.callSiteContribEntries+ prof+ _ -> continue prof+ ModulesView {} -> continue prof+ _ -> continue prof+ where+ popView p = case NE.nonEmpty (NE.tail _views) of+ Nothing -> p+ Just xs -> p & views .~ xs+ moveUp p = p & currentFocus %~ (\i -> max 0 (i - 1))+ moveDown p = p & currentFocus %~ (\i -> min (focusLen p - 1) (i + 1))+ moveToTop p = p & currentFocus .~ 0+ moveToEnd p = p & currentFocus .~ focusLen p - 1+ focusLen p = case p ^. topView of+ AggregatesView {_costCentres} -> V.length _costCentres+ CallSitesView {_callSites} -> V.length _callSites+ ModulesView {_modules} -> V.length _modules+ sortCostCentresBy key p = p & topView . costCentres+ %~ V.modify (Merge.sortBy (flip compare `on` key))+ sortCallSitesBy key p = p & topView . callSites+ %~ V.modify (Merge.sortBy (flip compare `on` key))+ displayCostCentres p = p & views .~ AggregatesView+ { _costCentres = V.fromList $ Prof.aggregateCostCentres $ p ^. report+ , _focus = 0+ } NE.:| []+ displayCallers p = fromMaybe p $ do+ let !model = p ^. topView . costCentres+ !idx = p ^. currentFocus+ Prof.AggregateCostCentre {..} <- model V.!? idx+ (_callee, callers) <- Prof.aggregateCallSites+ aggregateCostCentreName+ aggregateCostCentreModule+ (p ^. report)+ return $! p & views %~ NE.cons CallSitesView+ { _callee+ , _callSites = V.fromList callers+ , _focus = 0+ , _expanded = Set.empty+ }+ displayModules p = p & views .~ ModulesView+ { _modules = V.fromList $ Prof.aggregateModules $ p ^. report+ , _focus = 0+ } NE.:| []++topView :: Lens' Profile View+topView = views . lens NE.head (\(_ NE.:| xs) x -> x NE.:| xs)+{-# INLINE topView #-}++currentFocus :: Lens' Profile Int+currentFocus = topView . focus+{-# INLINE currentFocus #-}++currentViewport :: Profile -> Name+currentViewport p = case p ^. topView of+ AggregatesView {} -> AggregatesViewport+ CallSitesView {} -> CallSitesViewport+ ModulesView {} -> ModulesViewport++currentCacheEntry :: Profile -> Int -> Name+currentCacheEntry p n = case p ^. topView of+ AggregatesView {} -> AggregatesCache n+ CallSitesView {} -> CallSitesCache n+ ModulesView {} -> ModulesCache n++profileAttr :: AttrName+profileAttr = "profile"++selectedAttr :: AttrName+selectedAttr = "selected"++drawProfile :: Profile -> [Widget Name]+drawProfile prof =+ [ maybe emptyWidget (Brick.centerLayer . drawModalView) (prof ^. modalView)+ , drawView $ NE.head $ prof ^. views+ ]+ where+ drawModalView = \case+ InfoView -> Brick.border $ vBox+ [ txt $ prof ^. report . to Prof.profileCommandLine+ -- TODO: add more+ ]+ HelpView -> Brick.borderWithLabel (txt "Help") $ vBox+ [ txt "Keyboard shortcuts"+ , txt "q quit current view"+ , txt "j,down move down"+ , txt "k,up move up"+ , txt "gg move to the top"+ , txt "G move to the bottom"+ , txt "C switch to aggregate cost centre view"+ , txt "enter switch to call site view"+ , txt "M switch to module level breakdown"+ , txt "i display profiling info"+ , txt "h display help message"+ , txt "t sort by time"+ , txt "a sort by allocation"+ , txt "e sort by number of entries"+ ]+ drawView = \case+ AggregatesView {..} -> viewport AggregatesViewport Vertical $+ vBox $ V.toList $+ flip V.imap _costCentres $ \i row -> cached (AggregatesCache i) $+ let widget = drawAggregateCostCentre row+ in if i == _focus+ then withAttr selectedAttr (visible widget)+ else widget+ CallSitesView {..} -> viewport CallSitesViewport Vertical $+ vBox+ [ drawAggregateCostCentre _callee+ , vBox $ V.toList $ flip V.imap _callSites $ \i row ->+ cached (CallSitesCache i) $+ let widget = drawCallSite _callee row+ in if i == _focus+ then withAttr selectedAttr (visible widget)+ else widget+ ]+ ModulesView {..} -> viewport ModulesViewport Vertical $+ vBox $ V.toList $+ flip V.imap _modules $ \i row -> cached (ModulesCache i) $+ let widget = drawAggregateModule row+ in if i == _focus+ then withAttr selectedAttr (visible widget)+ else widget++drawAggregateCostCentre :: Prof.AggregateCostCentre -> Widget n+drawAggregateCostCentre Prof.AggregateCostCentre {..} = hBox+ [ txt aggregateCostCentreModule+ , txt "."+ , padRight Max $ txt aggregateCostCentreName+ , maybe emptyWidget (padRight (Pad 1) . str . show) aggregateCostCentreEntries+ , padRight (Pad 1) $ str (formatPercentage aggregateCostCentreTime)+ , str (formatPercentage aggregateCostCentreAlloc)+ ]++drawCallSite+ :: Prof.AggregateCostCentre+ -> Prof.CallSite Prof.AggregateCostCentre+ -> Widget n+drawCallSite Prof.AggregateCostCentre {..} Prof.CallSite {..} = hBox+ [ txt $ Prof.aggregateCostCentreModule callSiteCostCentre+ , txt "."+ , padRight Max $ txt $ Prof.aggregateCostCentreName callSiteCostCentre+ , padRight (Pad 1) $ str $ show callSiteContribEntries+ , padRight (Pad 1) $ hBox+ [ str $ contribution callSiteContribTime aggregateCostCentreTime+ , txt " ("+ , str $ formatPercentage callSiteContribTime+ , txt ")"+ ]+ , hBox+ [ str $ contribution callSiteContribAlloc aggregateCostCentreAlloc+ , txt " ("+ , str $ formatPercentage callSiteContribAlloc+ , txt ")"+ ]+ ]+ where+ contribution part whole+ | whole == 0 = formatPercentage 0+ | otherwise = formatPercentage $ Sci.fromFloatDigits $+ 100 * (Sci.toRealFloat part / Sci.toRealFloat whole :: Double)++drawAggregateModule :: Prof.AggregateModule -> Widget n+drawAggregateModule Prof.AggregateModule {..} = hBox+ [ txt aggregateModuleName+ , padLeft Max $ str (formatPercentage aggregateModuleTime)+ , padLeft (Pad 1) $ str (formatPercentage aggregateModuleAlloc)+ ]++formatPercentage :: Sci.Scientific -> String+formatPercentage = printf "%5s%%" . Sci.formatScientific Sci.Fixed (Just 1)
+ viewprof.cabal view
@@ -0,0 +1,32 @@+name: viewprof+version: 0.0.0+synopsis: Text-based interactive GHC .prof viewer+-- description:+license: BSD3+license-file: LICENSE+author: Mitsutoshi Aoe+maintainer: Mitsutoshi Aoe <maoe@foldr.in>+copyright: Copyright (C) 2016 Mitsutoshi Aoe+category: Development+build-type: Simple+extra-source-files: CHANGELOG.md+cabal-version: >= 1.10+tested-with: GHC == 8.0.2++executable viewprof+ main-is: viewprof.hs+ -- other-extensions:+ build-depends:+ base >= 4.9 && < 4.10+ , brick >= 0.16 && < 0.17+ , containers >= 0.5.7 && < 0.6+ , ghc-prof >= 1.3.0 && < 1.4+ , lens >= 4.14 && < 4.16+ , scientific >= 0.3.4.4 && < 0.4+ , text >= 1.2.2.0 && < 1.3+ , vector >= 0.10.12.3 && < 0.13+ , vector-algorithms >= 0.6.0.4 && < 0.8+ , vty >= 5.13 && < 5.15+ hs-source-dirs: bin+ default-language: Haskell2010+ ghc-options: -Wall -threaded