Main.hs

{-# LANGUAGE PatternGuards #-}
module Main where

import NoSlow.Analyse.Table
import NoSlow.Util.Tag
import qualified NoSlow.Util.Opts as O

import Criterion.Measurement ( secs )
import Text.Read
import System.Console.GetOpt
import System.Environment ( getArgs, getProgName )
import Data.Version ( showVersion )
import Control.Monad ( liftM, foldM )
import Text.Printf ( printf )
import System.IO

import Paths_NoSlow

main = do
         args <- getArgs
         case args of
           arg : args' | arg == "-d" || arg == "--diff" -> doDiff args'
           _                                            -> doTable args

data Opts = Opts {
              optOutputFile :: FilePath
            , optOutput     :: FilePath -> Table -> IO ()
            , optTransTable :: Table -> Table
            }

defaultTableOpts = Opts { optOutputFile = ""
                        , optOutput     = outputHTML
                        , optTransTable = id }

type OptM = O.OptM Opts

tbl :: (Table -> Table) -> Opts -> Opts
tbl f opts@(Opts { optTransTable = g }) = opts { optTransTable = f . g }

raw :: Table -> Table
raw t = t { tShowCell = printf "%f" }

commonOptions :: [OptDescr OptM]
commonOptions = [
    Option ['b'] ["bench"]
           (O.listArg return (tbl . sel_rows) "LIST")
           "only process some benchmarks"
  , Option ['l'] ["lib"]
           (O.selArg O.matchLib (tbl . filterTags) "LIST")
           "only process the specified libraries"
  , Option ['g'] ["group"]
           (O.selArg O.matchGroup (tbl . filterTags) "LIST")
           "only process benchmarks from the specified group"
  , Option ['o'] ["output"]
           (O.reqArg (\s opt -> opt { optOutputFile = s }) "FILE")
           "store the output in this file"
  , Option [] ["raw"]
           (O.noArg $ tbl raw)
           "output the raw data"
  , Option [] ["html"]
           (O.noArg $ \opt -> opt { optOutput = outputHTML })
           "output a HTML table"
  , Option [] ["csv"]
           (O.noArg $ \opt -> opt { optOutput = outputCSV })
           "output a CSV table"
  , Option ['V'] ["version"]
           (O.helpArg printVersion)
           "output version, then exit"
  , Option ['h','?'] ["help"]
           (O.helpArg printUsage)
           "output help"
  ]
  where
    sel_rows ss = filterRows (\s -> s `elem` ss)

printVersion :: IO ()
printVersion = putStrLn (showVersion version)

printUsage :: IO ()
printUsage = do
  p <- getProgName
  putStrLn (usageInfo ("Usage: " ++ p ++ " [OPTION | FILE] ...\n" ++
                       "       " ++ p ++ " [-d | --diff] FILE1 FILE2 [OPTIONS]") 
                      commonOptions)


doTable args
  = do
      (opts, rest) <- O.parse defaultTableOpts commonOptions args
      ts <- mapM readLog $ if null rest then ["-"] else rest
      output opts $ optTransTable opts $ foldr1 union ts

doDiff args
  = do
      (opts, rest) <- O.parse defaultTableOpts commonOptions args
      case rest of
        [file1,file2] -> do
                           t1 <- readLog file1
                           t2 <- readLog file2
                           output opts $ optTransTable opts
                                       $ intersect ratio cmp t1 t2

        _ | length rest > 2 -> O.printError "too many arguments"
          | otherwise       -> O.printError "not enough arguments"
  where
    ratio d = printf "%.3f" d

    cmp d1 d2 = d1 / d2


output :: Opts -> Table -> IO ()
output o = optOutput o (optOutputFile o)

outputHTML :: FilePath -> Table -> IO ()
outputHTML file t
  = with_file file $ \h ->
    do
      hPutStrLn h "<html><body>"
      hPutStrLn h (html $ prune t)
      hPutStrLn h "</body></html>"
  where
    with_file ""   f = f stdout
    with_file file f = withFile file WriteMode f 

outputCSV :: FilePath -> Table -> IO ()
outputCSV file t
  = with_file file $ \h ->
    hPutStrLn h (csv $ prune t)
  where
    with_file ""   f = f stdout
    with_file file f = withFile file WriteMode f 

newtype Benchmark = Benchmark { unBenchmark :: (Tag, Double) }

readLog :: FilePath -> IO Table
readLog file = (table secs . proc_lines . lines) `liftM` read_file file
  where
    proc_lines (h : r)
      | h == header = map (unBenchmark . read) r
      | otherwise = error "Invalid file"

    header = "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB"

    read_file "-"  = getContents
    read_file file = readFile file


instance Read Benchmark where
  readPrec = do
               tag <- readPrec
               comma
               mean <- readPrec
               comma
               readPrec :: ReadPrec Double -- meanlb
               comma
               readPrec :: ReadPrec Double -- meanub
               comma
               readPrec :: ReadPrec Double -- stddev
               comma
               readPrec :: ReadPrec Double -- stddevlb
               comma
               readPrec :: ReadPrec Double -- stddevub
               case reads tag of
                 [(t, "")] 
                    -> return $ Benchmark (t, mean)
    where
      comma = do
                c <- get
                if c == ',' then return () else pfail