diff --git a/Test/Tasty/Bench.hs b/Test/Tasty/Bench.hs index 27694e8..aded02e 100644 --- a/Test/Tasty/Bench.hs +++ b/Test/Tasty/Bench.hs @@ -499,6 +499,7 @@ module Test.Tasty.Bench , benchIngredients , consoleBenchReporter , csvReporter + , svgReporter , RelStDev(..) , FailIfSlower(..) , FailIfFaster(..) @@ -515,7 +516,8 @@ import Data.Foldable (foldMap, traverse_) import Data.Int (Int64) import Data.IntMap (IntMap) import qualified Data.IntMap as IM -import Data.List (intercalate, stripPrefix, isPrefixOf) +import Data.IORef +import Data.List (intercalate, stripPrefix, isPrefixOf, foldl', genericLength, genericDrop) import Data.Monoid (All(..), Any(..)) import Data.Proxy import Data.Sequence (Seq, (<|)) @@ -840,7 +842,7 @@ defaultMain = Test.Tasty.defaultMainWithIngredients benchIngredients . testGroup -- | List of default benchmark ingredients. This is what 'defaultMain' runs. -- benchIngredients :: [Ingredient] -benchIngredients = [listingTests, composeReporters consoleBenchReporter csvReporter] +benchIngredients = [listingTests, composeReporters consoleBenchReporter (composeReporters csvReporter svgReporter)] funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable funcToBench frc = (Benchmarkable .) . go @@ -1166,6 +1168,123 @@ encodeCsv xs = '"' : concatMap (\x -> if x == '"' then "\"\"" else [x]) xs ++ "\"" | otherwise = xs +newtype SvgPath = SvgPath { _unSvgPath :: FilePath } + deriving (Typeable) + +instance IsOption (Maybe SvgPath) where + defaultValue = Nothing + parseValue = Just . Just . SvgPath + optionName = pure "svg" + optionHelp = pure "File to plot results in SVG format" + +-- | Run benchmarks and plot results in SVG format. +-- It activates when @--svg@ @FILE@ command line option is specified. +-- +svgReporter :: Ingredient +svgReporter = TestReporter [Option (Proxy :: Proxy (Maybe SvgPath))] $ + \opts tree -> do + SvgPath path <- lookupOption opts + let names = testsNames opts tree + namesMap = IM.fromDistinctAscList $ zip [0..] names + pure $ \smap -> do + ref <- newIORef [] + svgCollect ref (IM.intersectionWith (,) namesMap smap) + res <- readIORef ref + writeFile path (svgRender (reverse res)) + pure $ const ((== 0) . statFailures <$> computeStatistics smap) + +svgCollect :: IORef [(TestName, Estimate)] -> IntMap (TestName, TVar Status) -> IO () +svgCollect ref = traverse_ $ \(name, tv) -> do + r <- atomically $ readTVar tv >>= \s -> case s of Done r -> pure r; _ -> retry + case safeRead (resultDescription r) of + Nothing -> pure () + Just (Response est _ _) -> modifyIORef ref ((name, est) :) + +svgRender :: [(TestName, Estimate)] -> String +svgRender [] = "" +svgRender pairs = header ++ concat (zipWith + (\i (name, est) -> svgRenderItem i l xMax (dropAllPrefix name) est) + [0..] + pairs) ++ footer + where + dropAllPrefix + | all ("All." `isPrefixOf`) (map fst pairs) = drop 4 + | otherwise = id + + l = genericLength pairs + findMaxX (Estimate m stdev) = measTime m + 2 * stdev + xMax = fromIntegral $ maximum $ minBound : map (findMaxX . snd) pairs + header = printf "\n\n" (svgItemOffset l - 15) svgCanvasWidth svgFontSize svgCanvasMargin + footer = "\n\n" + +svgCanvasWidth :: Double +svgCanvasWidth = 960 + +svgCanvasMargin :: Double +svgCanvasMargin = 10 + +svgItemOffset :: Word64 -> Word64 +svgItemOffset i = 22 + 55 * fromIntegral i + +svgFontSize :: Word64 +svgFontSize = 16 + +svgRenderItem :: Word64 -> Word64 -> Double -> TestName -> Estimate -> String +svgRenderItem i iMax xMax name est@(Estimate m stdev) = + (if genericLength shortTextContent * glyphWidth < boxWidth then longText else shortText) ++ box + where + y = svgItemOffset i + y' = y + (svgFontSize * 3) `quot` 8 + y1 = y' + whiskerMargin + y2 = y' + boxHeight `quot` 2 + y3 = y' + boxHeight - whiskerMargin + x1 = boxWidth - whiskerWidth + x2 = boxWidth + whiskerWidth + deg = (i * 360) `quot` iMax + glyphWidth = fromIntegral svgFontSize / 2 + + scale w = fromIntegral w * (svgCanvasWidth - 2 * svgCanvasMargin) / xMax + boxWidth = scale (measTime m) + whiskerWidth = scale (2 * stdev) + boxHeight = 22 + whiskerMargin = 5 + + box = printf boxTemplate + (prettyEstimate est) + y' boxHeight boxWidth deg deg + deg + x1 x2 y2 y2 + x1 x1 y1 y3 + x2 x2 y1 y3 + boxTemplate + = "\n%s\n" + ++ "\n" + ++ "" + ++ "\n" + ++ "\n" + ++ "\n" + ++ "\n\n" + + longText = printf longTextTemplate + deg + y (encodeSvg name) + y boxWidth (showPicos (measTime m)) + longTextTemplate + = "\n" + ++ "%s\n" + ++ "%s\n" + ++ "\n" + + shortTextContent = encodeSvg name ++ " " ++ showPicos (measTime m) + shortText = printf shortTextTemplate deg y shortTextContent + shortTextTemplate = "%s\n" + +encodeSvg :: String -> String +encodeSvg = concatMap $ \x -> case x of + '<' -> "<" + '&' -> "&" + _ -> [x] + newtype BaselinePath = BaselinePath { _unBaselinePath :: FilePath } deriving (Typeable) diff --git a/tasty-bench.cabal b/tasty-bench.cabal index 7c167e1..f31150c 100644 --- a/tasty-bench.cabal +++ b/tasty-bench.cabal @@ -32,6 +32,8 @@ library hs-source-dirs: . default-language: Haskell2010 ghc-options: -O2 -Wall -fno-warn-unused-imports + if impl(ghc < 7.10) + ghc-options: -fcontext-stack=30 build-depends: base >= 4.3 && < 5,