#!/usr/bin/runhaskell

(C) Susumu Katayama

prof2xdu -- short program for visualizing time profiling results of Haskell programs 

This program converts a .prof file into the format that the xdu command understands, and invokes xdu.
(So requires xdu.)

\begin{code}
import System.Console.GetOpt
import System.Process(runProcess, waitForProcess)
import System.IO
import System.Directory(removeFile)
import System
import List(isSuffixOf)

data Flag = Time | Alloc | Output String | Qualify | Unqualify
options :: [OptDescr Flag]
options = [ Option ['t'] ["time"]                (NoArg Time) "extract time profiling results (default)"
          , Option ['a'] ["alloc","allocation"] (NoArg Alloc) "extract allocation profiling results"
          , Option ['o'] []            (ReqArg Output "FILE") "output to FILE. If FILE=='-' stdout is chosen."
          , Option ['q'] ["qualify"]          (NoArg Qualify) "qualify variable names shown." 
          , Option ['u'] ["unqualify"]       (NoArg Unqualify) "unqualify variable names shown. This is useful if you are using a small display, though it does not work correctly when there are remarkable cost centers with the same name in different modules." 
          ]
readOpts :: IO ([Flag], [String])
readOpts = do progname <- getProgName
	      argv     <- getArgs
	      case (getOpt Permute options argv) of
			    (o,n,[]  ) -> return (o,n)
			    (_,_,errs) -> do hPutStrLn stderr (concat errs)
                                             usage
                                             exitFailure
usage :: IO ()
usage = do progname <- getProgName
           hPutStrLn stderr $ usageInfo ("Usage: "++progname++" [OPTION...]") options

data Stat = St {extAlloc :: Bool, toFile :: Maybe String, qual :: Bool}
defaultStat = St {extAlloc=False, toFile=Nothing, qual=True}
procFlags :: [Flag] -> Stat
procFlags = foldl procFlag defaultStat
procFlag :: Stat -> Flag -> Stat
procFlag st Time         = st{extAlloc=False}
procFlag st Alloc        = st{extAlloc=True}
procFlag st (Output str) = st{toFile=Just str}
procFlag st Qualify      = st{qual=True}
procFlag st Unqualify    = st{qual=False}

main = do (flags,args) <- readOpts
          let stat = procFlags flags
          str <- case args of []      -> getContents
                              ("-":_) -> getContents
                              (fn:_)  -> readFile (if ".prof" `isSuffixOf` fn then fn else fn++".prof")
          let result = unlines $ reverse $ convert stat $ removeHeader $ lines str
          case toFile stat of Nothing -> do (filepath,handle) <- openTempFile "." "p2x.tmp"
                                            hPutStr handle result
                                            hClose handle
                                            handle <- openFile filepath ReadMode
                                            ph <- runProcess "xdu" [] Nothing Nothing (Just handle) Nothing Nothing
                                            waitForProcess ph
                                            removeFile filepath
                              Just "-" -> putStr result
                              Just fn  -> writeFile fn result

removeHeader = tail . tail . tailMb . dropWhile (not . (==["individual","inherited"]) . words)
tailMb []     = error "Parse error. (Or maybe the format of .prof has changed?)"
tailMb (_:xs) = xs

convert :: Stat -> [String] -> [String]
convert st = cvt st []
cvt :: Stat -> [String] -> [String] -> [String]
cvt st context []       = []
cvt st context (cs:css) = let indents = length $ takeWhile (==' ') cs
                              [costCenter, modName, _no, _entries, _indt, _inda, time, alloc] = words cs
                              varName = if qual st || costCenter == "CAF" then modName++'.':costCenter else costCenter
                              cxt     = take indents context ++ [varName]
                              amount  = filter (/='.') (if extAlloc st then alloc else time) -- assumes fixed point values
                          in if amount == "00" then cvt st cxt css else (amount ++ '\t' : foldr (\a b->a++'/':b) "" cxt) : cvt st cxt css
\end{code}