Merge pull request #8 from sergv/master

Automatically invoke flamegraph.pl and bundle it together with executable

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "FlameGraph"]
+        path = FlameGraph
+        url = https://github.com/brendangregg/FlameGraph.git

README.md

@@ -12,15 +12,23 @@ understandable by the
 
 ## Usage
 
-First convert a `.prof` file into the flame graph format using
-`ghc-prof-flamegraph`:
+First convert a `.prof` file into the flame graph svg:
 
-    $ cat ~/src/packdeps/packdeps.prof | ghc-prof-flamegraph > packdeps.prof.folded
+    $ cat ~/src/packdeps/packdeps.prof | ghc-prof-flamegraph > packdeps.prof.svg
 
-Then you can use the file to produce an svg image, using the
-[`flamegraph.pl`](https://github.com/brendangregg/FlameGraph) script:
+Or, alternatively, just pass the `.prof` file as an argument. The tool will
+then create corresponing `.svg` file:
 
-    $ cat packdeps.prof.folded | ~/src/FlameGraph/flamegraph.pl > packdeps.prof.svg
+    $ ghc-prof-flamegraph ~/src/packdeps/packdeps.prof
+    Output written to ~/src/packdeps/packdeps.svg
+
+The previous command will produce `~/src/packdeps/packdeps.svg` file.
+
+You can customize the behavior of the underlying `flamegraph.pl` by passing
+options via `–framegraph-option`. For example, you can customize the title:
+
+    $ ghc-prof-flamegraph ~/src/packdeps/packdeps.prof '--flamegraph-option=--title=Package dependencies'
+    Output written to ~/src/packdeps/packdeps.svg
 
 You can also generate a flamegraph using the allocation measurements,
 using the `--alloc` flag.

ghc-prof-flamegraph.cabal

@@ -29,20 +29,19 @@ description:
   bytes allocated using @--bytes@. In order to use @--bytes@ or @--ticks@ flag one
   have to run program with @+RTS -P -RTS@ in order to get those measurements.
 
+data-files:
+  FlameGraph/flamegraph.pl
+
 source-repository head
   type:     git
   location: https://github.com/fpco/ghc-prof-flamegraph
 
-library
-  build-depends:       base >=4 && <5
-  exposed-modules:     ProfFile
-  ghc-options:         -Wall
-  default-language:    Haskell2010
-
 executable ghc-prof-flamegraph
   main-is:             ghc-prof-flamegraph.hs
   build-depends:       base >=4.6 && <5
-                     , ghc-prof-flamegraph
+                     , filepath
                      , optparse-applicative
+                     , process
+  other-modules:       ProfFile
   default-language:    Haskell2010
   ghc-options:         -Wall

ghc-prof-flamegraph.hs

@@ -1,20 +1,29 @@
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-module Main where
 
-import           Control.Applicative ((<*>), (<|>))
+module Main (main) where
+
+import           Control.Applicative ((<*>), (<|>), optional, many, pure)
+import           Data.Foldable (traverse_)
 import           Data.Functor ((<$>))
 import           Data.List (intercalate)
 import           Data.Monoid ((<>))
 import qualified Options.Applicative as Opts
-import           System.Exit (exitFailure)
-import           System.IO (stderr, hPutStrLn)
 import qualified ProfFile as Prof
+import           System.Exit (ExitCode(..), exitFailure)
+import           System.FilePath ((</>), replaceExtension)
+import           System.IO (stderr, stdout, hPutStrLn, hPutStr, hGetContents, IOMode(..), hClose, openFile)
+import           System.Process (proc, createProcess, CreateProcess(..), StdStream(..), waitForProcess)
+
+import Paths_ghc_prof_flamegraph (getDataDir)
 
 data Options = Options
-  { optionsReportType :: ReportType
+  { optionsReportType      :: ReportType
+  , optionsProfFile        :: Maybe FilePath
+  , optionsOutputFile      :: Maybe FilePath
+  , optionsFlamegraphFlags :: [String]
   } deriving (Eq, Show)
 
-
 data ReportType = Alloc   -- ^ Report allocations, percent
                 | Entries -- ^ Report entries, number
                 | Time    -- ^ Report time spent in closure, percent
@@ -29,6 +38,21 @@ optionsParser = Options
        <|> Opts.flag' Bytes   (Opts.long "bytes" <> Opts.help "Memory measurements in bytes (+RTS -P -RTS)")
        <|> Opts.flag' Ticks (Opts.long "ticks" <> Opts.help "Time measurements in ticks (+RTS -P -RTS)")
        <|> Opts.flag  Time Time (Opts.long "time" <> Opts.help "Uses time measurements"))
+  <*> optional
+        (Opts.strArgument
+          (Opts.metavar "PROF-FILE" <>
+           Opts.help "Profiling output to format as flame graph"))
+  <*> optional
+        (Opts.strOption
+          (Opts.short 'o' <>
+           Opts.long "output" <>
+           Opts.metavar "SVG-FILE" <>
+           Opts.help "Optional output file"))
+  <*> many
+        (Opts.strOption
+          (Opts.long "flamegraph-option" <>
+           Opts.metavar "STR" <>
+           Opts.help "Options to pass to flamegraph.pl"))
 
 checkNames :: ReportType -> [String] -> Maybe String
 checkNames Alloc   _ = Nothing
@@ -84,11 +108,43 @@ main :: IO ()
 main = do
   options <- Opts.execParser $
     Opts.info (Opts.helper <*> optionsParser) Opts.fullDesc
-  s <- getContents
+  s <- maybe getContents readFile $ optionsProfFile options
   case Prof.parse s of
     Left err -> error err
     Right (names, ls) ->
       case checkNames (optionsReportType options) names of
-        Just problem -> do hPutStrLn stderr problem
-                           exitFailure
-        Nothing ->  putStr $ unlines $ generateFrames options ls
+        Just problem -> do
+          hPutStrLn stderr problem
+          exitFailure
+        Nothing      -> do
+          dataDir <- getDataDir
+          let flamegraphPath = dataDir </> "FlameGraph" </> "flamegraph.pl"
+              flamegraphProc = (proc "perl" (flamegraphPath : optionsFlamegraphFlags options))
+                { std_in  = CreatePipe
+                , std_out = CreatePipe
+                , std_err = Inherit
+                }
+          (outputHandle, outputFileName, closeOutputHandle) <-
+            case (optionsOutputFile options, optionsProfFile options) of
+              (Just path, _)         -> do
+                h <- openFile path WriteMode
+                pure (h, Just path, hClose h)
+              (Nothing,   Just path) -> do
+                let path' = path `replaceExtension` "svg"
+                h <- openFile path' WriteMode
+                pure (h, Just path', hClose h)
+              _                      ->
+                pure (stdout, Nothing, pure ())
+          (Just input, Just flamegraphResult, Nothing, procHandle) <- createProcess flamegraphProc
+          traverse_ (hPutStrLn input) $ generateFrames options ls
+          hClose input
+          hGetContents flamegraphResult >>= hPutStr outputHandle
+          exitCode <- waitForProcess procHandle
+          closeOutputHandle
+          case exitCode of
+            ExitSuccess   ->
+              case outputFileName of
+                Nothing   -> pure ()
+                Just path -> putStrLn $ "Output written to " <> path
+            ExitFailure{} ->
+              hPutStrLn stderr $ "Call to flamegraph.pl at " <> flamegraphPath <> " failed"