{-# LANGUAGE PatternGuards #-}
module Main where
import Criterion.Measurement ( secs )
import qualified Data.Map as M
import Data.List ( nub, intersect, sort, groupBy )
import Text.Read
import System.Environment ( getArgs )
import Control.Monad ( liftM, foldM )
import Text.Printf ( printf )
main = do
(arg : args) <- getArgs
if arg == "--diff"
then doDiff args
else doTable arg args
doTable file args
= do
bs <- readLog file
table <- foldM procArg (mkTable secs bs) args
outputHTML table
doDiff (file1 : file2 : args)
= do
bs1 <- readLog file1
bs2 <- readLog file2
let t = intersectTable ratio cmp (mkTable secs bs1) (mkTable secs bs2)
table <- foldM procArg t args
outputHTML table
where
ratio d = printf "%.3f" d
cmp d1 d2 = d1 / d2
dropPrefix :: String -> String -> Maybe String
dropPrefix "" cs = Just cs
dropPrefix (p : ps) (c : cs)
| p == c = dropPrefix ps cs
| otherwise = Nothing
procArg t arg
| Just s <- dropPrefix "--type=" arg
= return $ filterColumns (\cfg -> cfgDatatype cfg == s) t
data Cfg = Cfg {
cfgLibrary :: String
, cfgSubsystem :: String
, cfgDatatype :: String
}
deriving ( Eq, Ord )
data Library = Library String Int [Subsystem]
data Subsystem = Subsystem String Int [String]
on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g x y = f (g x) (g y)
eqOn :: Eq b => (a -> b) -> a -> a -> Bool
eqOn = on (==)
groupCfgs :: [Cfg] -> [Library]
groupCfgs = map mk_library . groupBy (eqOn cfgLibrary)
where
mk_library cfgs@(c:_)
= let subs = map mk_subsystem $ groupBy (eqOn cfgSubsystem) cfgs
in
Library (cfgLibrary c) (sum [n | Subsystem _ n _ <- subs]) subs
mk_subsystem cfgs@(c:_)
= let cols = map cfgDatatype cfgs
in
Subsystem (cfgSubsystem c) (length cols) cols
instance Show Cfg where
showsPrec _ cfg = showString (cfgLibrary cfg)
. sub (cfgSubsystem cfg)
. showChar '.' . showString (cfgDatatype cfg)
where
sub "" = id
sub s = showChar '.' . showString s
data Entry a = Entry {
eCfg :: Cfg
, eName :: String
, eData :: a
}
data Table = Table {
tRows :: [String]
, tColumns :: [Cfg]
, tCells :: M.Map String Row
, tShowCell :: Double -> String
}
type Row = M.Map Cfg Double
mkTable :: (Double -> String) -> [Entry Double] -> Table
mkTable show es
= Table {
tRows = nub $ map eName es
, tColumns = sort $ nub $ map eCfg es
, tCells = M.fromListWith M.union [(eName e, unit e) | e <- es]
, tShowCell = show
}
where
unit e = M.singleton (eCfg e) (eData e)
structure :: Table -> [Library]
structure = groupCfgs . tColumns
cells :: Table -> [(String, [Maybe Double])]
cells (Table { tRows = names
, tColumns = cfgs
, tCells = t }) = concatMap row_cells names
where
row_cells name = case M.lookup name t of
Just row -> [(name, map (cell row) cfgs)]
Nothing -> []
cell row cfg = M.lookup cfg row
outputHTML :: Table -> IO ()
outputHTML t
= do
putStrLn ""
putStrLn $ htmlTable t
putStrLn ""
htmlTable :: Table -> String
htmlTable t = unlines
[ ""
, header (structure t) -- tr $ concatMap th ("" : map show (tColumns t))
, unlines $ map (tr . row) (cells t)
, "
"
]
where
row (s, cs) = th (concatMap escape s) ++ concatMap cell cs
cell Nothing = td ""
cell (Just s) = td (tShowCell t s)
tr s = "" ++ s ++ "
"
th s = "" ++ s ++ " | "
td s = "" ++ s ++ " | "
th' n s = "" ++ s ++ " | "
header :: [Library] -> String
header libs = unlines [
tr $ th "" ++ concat [th' n lib | Library lib n _ <- libs]
, tr $ th "" ++ concat [th' n sub | Library _ _ subs <- libs
, Subsystem sub n _ <- subs]
, types [s | Library _ _ subs <- libs
, Subsystem _ _ ss <- subs
, s <- ss]
]
types (s : ss)
| all (s==) ss = ""
| otherwise = tr $ th "" ++ concatMap th (s:ss)
escape '<' = "<"
escape '>' = ">"
escape '&' = "&"
escape c = [c]
filterRows :: (String -> Bool) -> Table -> Table
filterRows f t@(Table { tRows = tRows, tCells = tCells })
= t { tRows = filter f tRows
, tCells = M.filterWithKey (\s _ -> f s) tCells }
filterColumns :: (Cfg -> Bool) -> Table -> Table
filterColumns f t@(Table { tColumns = tColumns, tCells = tCells })
= t { tColumns = filter f tColumns
, tCells = M.map (M.filterWithKey (\cfg _ -> f cfg)) tCells
}
intersectTable :: (Double -> String) -> (Double -> Double -> Double)
-> Table -> Table -> Table
intersectTable show f t1 t2
= Table { tRows = intersect (tRows t1) (tRows t2)
, tColumns = intersect (tColumns t1) (tColumns t2)
, tCells = M.intersectionWith (M.intersectionWith f)
(tCells t1) (tCells t2)
, tShowCell = show
}
{-
data State = State {
stOriginal :: Table Double
, stResult :: Table Double
}
mapOriginal :: (Table Double -> Table Double) -> State -> State
mapOriginal f st@(State { stOriginal = t }) = st { stOriginal = f t }
mapResult :: (Table Double -> Table Double) -> State -> State
mapResult f st@(State { stResult = t }) = st { stResult = f t }
-}
newtype Benchmark = Benchmark { unBenchmark :: Entry Double }
readLog :: FilePath -> IO [Entry Double]
readLog file = (proc_lines . lines) `liftM` readFile file
where
proc_lines (h : r)
| h == header = map (unBenchmark . read) r
| otherwise = error "Invalid file"
header = "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB"
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 split_tag tag of
(library, subsystem, datatype, name)
-> return $ Benchmark
$ Entry {
eCfg = Cfg { cfgLibrary = library
, cfgSubsystem = subsystem
, cfgDatatype = datatype
}
, eName = name
, eData = mean
}
where
comma = do
c <- get
if c == ',' then return () else pfail
split_tag s = case split '/' s of
[library,subsystem,datatype,benchmark]
-> (library,subsystem,datatype,benchmark)
[library,datatype,benchmark]
-> (library,"",datatype,benchmark)
split c xs = case span (/= c) xs of
(ys,[]) -> [ys]
(ys, _ : zs) -> ys : split c zs