Commit 795869f7 authored by Ben Gamari's avatar Ben Gamari 🐢

Add compare utility

parent f2a24e7d
import Data.Align
import Data.Maybe
import Data.These
import Data.List (intercalate)
import Data.Foldable
import Numeric
import qualified Data.Tree as Tree
import Data.Tree (Tree)
import qualified Data.Map.Strict as M
import System.FilePath
import Text.Tabular
import Text.Tabular.AsciiArt
import Options.Applicative
import qualified MeasurementTree as MTree
import MeasurementTree (MeasurementTree')
args :: Parser [FilePath]
args = some $ argument str (metavar "FILE" <> help "results.json file")
-- | Hackily align decimal numbers.
padDecimal :: RealFloat a
=> Int -- ^ how many columns before the point
-> Int -- ^ how many digits after the point
-> a -> String
padDecimal before after x =
let s = showGFloat (Just after) x ""
pad = before - length (takeWhile (/= '.') s)
in replicate pad ' ' ++ s
main :: IO ()
main = do
files <- execParser $ info (helper <*> args) mempty
mtrees <- mapM (fmap fromJust . MTree.readFile) files
let aligned = alignMany $ M.fromList $ zip (map takeFileName files) mtrees
putStrLn
$ unlines
[ unlines
[ ""
, intercalate "/" $ map MTree.getLabel path
, replicate 20 '='
, ""
, render MTree.getLabel id (maybe "-" (\x -> showGFloat (Just 3) x "")) table
]
| (path, table) <- Tree.flatten $ toTables aligned
, Table _ _ (_:_) <- pure table
]
alignMany :: Ord k => M.Map k (MeasurementTree' a) -> MeasurementTree' (M.Map k a)
alignMany mtrees =
foldl1 (alignWith (mergeThese M.union))
[ fmap (M.singleton label) mtree
| (label, mtree) <- M.toList mtrees
]
toGroupTree :: MeasurementTree' (M.Map k a)
-> Maybe (Tree ([MTree.Label], M.Map MTree.Label (M.Map k a)))
toGroupTree = toTree []
where
toTree :: [MTree.Label]
-> MeasurementTree' (M.Map k a)
-> Maybe (Tree ([MTree.Label], M.Map MTree.Label (M.Map k a)))
toTree path (MTree.Group children) =
Just $ Tree.Node (reverse path, samples) subgroups
where
samples = M.mapMaybe MTree.isSample children
subgroups = mapMaybe (\(k, xs) -> toTree (k:path) xs) (M.toList children)
toTree path _ = Nothing
toTables
:: Ord k
=> MeasurementTree' (M.Map k a)
-> Tree ([MTree.Label], Table MTree.Label k (Maybe a))
toTables mtree
| Just tree <- toGroupTree mtree = fmap (fmap toTable) tree
| otherwise = error "empty measurement tree"
toTable :: (Ord r, Ord c)
=> M.Map r (M.Map c a)
-> Table r c (Maybe a)
toTable xs =
Table
(Group NoLine $ map Header $ M.keys xs)
(Group NoLine $ map Header allKeys)
[ [ M.lookup k ys
| k <- allKeys
]
| ys <- M.elems xs
]
where
allKeys = toList $ foldMap M.keysSet xs
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module MeasurementTree where
import Control.Applicative
import Control.Monad
import Data.Aeson
import qualified Data.Map.Strict as M
import GHC.Generics
import qualified Data.ByteString.Lazy as BSL
type MeasurementTree = MeasurementTree' Double
data MeasurementTree' a = Sample a
-- ^ A measurement result
| Group (M.Map String (MeasurementTree' a))
-- ^ A group of related measurements.
deriving (Functor, Generic)
instance ToJSON a => ToJSON (MeasurementTree' a) where
toJSON (Sample x) = toJSON x
toJSON (Group x) = object [ "type" .= ("group" :: String)
, "children" .= x
]
instance FromJSON a => FromJSON (MeasurementTree' a) where
parseJSON v = parseGroup v <|> fmap Sample (parseJSON v)
where
parseGroup = withObject "group" $ \o -> do
typ <- o .: "type"
guard $ typ == ("group" :: String)
Group <$> o .: "children"
--instance ToJSON a => ToJSON (MeasurementTree' a)
--instance FromJSON a => FromJSON (MeasurementTree' a)
singleton :: String -> MeasurementTree' a -> MeasurementTree' a
singleton name = Group . M.singleton name
singletonSample :: String -> a -> MeasurementTree' a
singletonSample name = singleton name . Sample
writeFile' :: ToJSON a => FilePath -> MeasurementTree' a -> IO ()
writeFile' fname = BSL.writeFile fname . encode
writeFile :: FilePath -> MeasurementTree -> IO ()
writeFile = writeFile'
readFile' :: FromJSON a => FilePath -> IO (Maybe (MeasurementTree' a))
readFile' fname = decode <$> BSL.readFile fname
readFile :: FilePath -> IO (Maybe MeasurementTree)
readFile = readFile'
group :: [(String, MeasurementTree' a)] -> MeasurementTree' a
group = Group . M.fromList
collect :: RealFrac a => [MeasurementTree' a] -> MeasurementTree' [a]
collect = go [""]
where
isSample (Sample _) = True
isSample _ = False
isGroup = not . isSample
go path trees
| all isSample trees = Sample [ x | Sample x <- trees ]
| all isGroup trees =
Group $ M.mapWithKey (\k ts -> go (k:path) ts) $ M.fromListWith (<>)
[ (k,[t])
| Group xs <- trees
, (k,t) <- M.toList xs
]
| otherwise = error $ "Measurement tree type mismatch at " ++ show path
mean :: RealFrac a => [a] -> a
mean xs = sum xs / realToFrac (length xs)
geomMean :: RealFloat a => [a] -> a
geomMean = exp . mean . map log
stdDev :: RealFloat a => [a] -> a
stdDev xs = sqrt $ mean $ map (\x -> (x-m)^(2::Int)) xs
where m = mean xs
cabal-version: >=1.10
name: nofib-run
name: nofib
version: 0.1.0.0
-- synopsis:
-- description:
......@@ -12,9 +12,19 @@ maintainer: ben@smart-cactus.org
-- category:
build-type: Simple
library
exposed-modules: MeasurementTree
hs-source-dirs: src
build-depends: base >=4.10 && <4.13,
aeson,
these >= 0.8,
containers,
bytestring
default-language: Haskell2010
executable nofib-run
main-is: Main.hs
other-modules: CachegrindParse, ParseResults, MeasurementTree
other-modules: CachegrindParse, ParseResults
other-extensions: RecordWildCards, DeriveDataTypeable
build-depends: base >=4.10 && <4.13,
time >=1.8 && <1.9,
......@@ -22,7 +32,22 @@ executable nofib-run
bytestring,
directory >=1.3 && <1.4,
process >=1.6 && <1.7,
aeson,
cmdargs,
shake
shake,
nofib
default-language: Haskell2010
executable nofib-compare
main-is: Compare.hs
other-modules:
other-extensions: RecordWildCards, DeriveDataTypeable
build-depends: base >=4.10 && <4.13,
these,
containers,
filepath,
aeson,
ansi-wl-pprint,
tabular,
optparse-applicative,
nofib
default-language: Haskell2010
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment