diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for chronos + +## 0.1.0.0 -- 2019-03-09 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Florian Knupfer + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Florian Knupfer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,105 @@ +# Chronos + +`chronos` performs lazy benchmarking of shell commands with continuous feedback and improving precision. + +Please look at the documentation of the module for an overview of the api: +[Html](https://hackage.haskell.org/package/chronos-bench/docs/Chronos.html) + +## How does it work? + +`chronos` will benchmark the specified commands until you abort it +with ctrl-c or it reaches some termination criterion specified by the +command line. It updates every iteration the measurements of the +benchmarks so you can terminate it when you're satisfied with the +presented precision. It will intersperse all benchmarks for fastest +possible overview and to distribute any external load over all +benchmarks to improve precision. + +![chronos](https://user-images.githubusercontent.com/5609565/54072918-5ec9ab00-4281-11e9-851a-7a4bde1295b2.png) + +## Options + +`chronos` presents rich command line options. + +![options](https://user-images.githubusercontent.com/5609565/54072912-55d8d980-4281-11e9-909e-ea7c06a17d6a.png) + +You can as well use autocomplete of your shell with following command: +```bash +source <(chronos --bash-completion-script `which chronos`) +``` + +Normally, the output of `--bash-completion-script` should be coppied in the appropriate directory. + +## Library + +You can use `chronos` as a haskell library to benchmark pure or impure functions or shell commands. + +```haskell +module Main where + +import Chronos + +main :: IO () +main = defaultMain + [ bench "fib 1" fib 1 + , bench "fib 2" fib 2 + , bench "fib 4" fib 4 + , bench "fib 8" fib 8 + ] + +fib :: Int -> Int +fib 1 = 1 +fib 2 = 1 +fib n = fib (n-1) + fib (n-2) +``` + +```haskell +module Main where + +import Chronos + +import Control.Concurrent +import Data.IORef + +main :: IO () +main = defaultMain + [ benchIO "ioref" (newIORef True) + , benchIO "mvar" (newMVar True) + , benchIO "qsem" (newQSem 5) + , benchIO "chan" (newChan :: IO (Chan Int)) + ] +``` + +```haskell +module Main where + +import Chronos + +main :: IO () +main = defaultMain + [ benchShell "sleep is slow" "sleep 0" + , benchShell "echo is fast" "echo" + , benchShell "true is faster" "true" + ] +``` + +## Comparision + +Comparing `chronos` to `bench` and `hyperfine`: + +`chronos` +- intersperses all benchmarks, therefore allowing you fast comparisions +- uses scientific notation +- is more robust to external loads because ouf the interspersing (it will affect all benchmarks and not only some) +- uses a number of significant digits according to the current standard error (so with time more digits are presented and not always 4 which is often the wrong thing to do) +- uses bars with confidence intervals on the command line for easy comparision + +Comparing `chronos` to `criterion`: + +`chronos` +- has got a much simpler api +- can be used in testsuites +- has got much simpler internals +- has got less dependencies +- doesn't measure allocations +- doesn't measure cpu time diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Chronos + +main :: IO () +main = defaultMain $ map (\n -> bench ("fib " ++ show n) fib n) [1..10] + +fib :: Int -> Int +fib 1 = 1 +fib 2 = 1 +fib n = fib (n-1) + fib (n-2) diff --git a/bin/Main.hs b/bin/Main.hs new file mode 100644 --- /dev/null +++ b/bin/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import Chronos +import Parser + +import Control.Applicative +import Options.Applicative + +type Arguments = (Config, [String]) + +main :: IO () +main = uncurry defaultMainWith . fmap (map (benchShell <*> id)) =<< execParser opts + where + opts = info (arguments <**> helper) + ( fullDesc <> header "chronos - a tool to comparatively benchmark programs with lazy precision" ) + +arguments :: Parser Arguments +arguments + = liftA2 (,) (configParser Config) + $ liftA2 (:) + ( argument str (metavar "COMMAND")) + ( many (argument str (metavar "COMMAND"))) diff --git a/chronos-bench.cabal b/chronos-bench.cabal new file mode 100644 --- /dev/null +++ b/chronos-bench.cabal @@ -0,0 +1,58 @@ +cabal-version: 2.2 + +name: chronos-bench +version: 0.1.0.1 +synopsis: Benchmarking tool with focus on comparing results. +description: This tool performs lazy benchmarking of functions and shell commands with continuous feedback and improving precision. +license: BSD-3-Clause +license-file: LICENSE +author: Florian Knupfer +maintainer: fknupfer@gmail.com +homepage: https://github.com/knupfer/chronos +tested-with: GHC == 8.4.4 + , GHC == 8.6.3 + , GHC == 8.6.4 +copyright: 2019, Florian Knupfer +category: Development, Performance, Testing, Benchmarking +extra-source-files: CHANGELOG.md + , README.md +source-repository head + Type: git + Location: https://github.com/knupfer/chronos + +library + exposed-modules: Chronos + other-modules: Parser + build-depends: base >= 4 && < 5 + , time + , ansi-terminal + , process + , deepseq + , containers + , terminal-size + , bytestring + , optparse-applicative + hs-source-dirs: src + , common + default-language: Haskell2010 + ghc-options: -Wall -O2 + +executable chronos + main-is: Main.hs + other-modules: Parser + build-depends: base >= 4 && < 5 + , chronos-bench + , optparse-applicative + hs-source-dirs: bin + , common + default-language: Haskell2010 + ghc-options: -Wall -O2 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: chronos-bench + , base >= 4 + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall diff --git a/common/Parser.hs b/common/Parser.hs new file mode 100644 --- /dev/null +++ b/common/Parser.hs @@ -0,0 +1,45 @@ +module Parser where + +import Control.Applicative +import Options.Applicative + +configParser + :: ( Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Double -> + Maybe Double -> + Maybe Double -> + config + ) -> Parser config +configParser f = f + <$> switch ( long "hide-bar" <> help "Hide the bar indicating relative performance." ) + <*> switch ( long "same-line" <> help "Print the analysis on the same line as the command." ) + <*> switch ( long "hide-details" <> help "Hide standard deviation and number of samples." ) + <*> switch ( long "print-once" <> help "Print only once the analysis. This is will print the analysis on timeout, maximal relative error or ctrl-c." ) + <*> switch ( long "sort" <> help "Sort benchmarks by mean duration." ) + <*> switch ( long "simple" <> help "Don't colorize output and don't use unicode." ) + <*> option auto + ( long "confidence" + <> help "Factor by which the standard error will be multiplied for calculating confidence intervals (default is 6)." + <> value 6 + <> metavar "DOUBLE" + ) + <*> optional + ( option auto + ( long "timeout" + <> help "Timeout after which the program is terminated. It finishes the currently running benchmark." + <> metavar "DOUBLE" + ) + ) + <*> optional + ( option auto + ( long "relative-error" + <> help "After every benchmark has got a relative error (calculated via confidence interval) below DOUBLE the program is terminated." + <> metavar "DOUBLE" + ) + ) + diff --git a/src/Chronos.hs b/src/Chronos.hs new file mode 100644 --- /dev/null +++ b/src/Chronos.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Library to comparatively benchmark pure functions, impure +-- functions and shell commands with lazy precision. + +module Chronos + ( + -- * Benchmark + defaultMain + , bench + , benchIO + , benchShell + -- * Configuration + , defaultMainWith + , defaultConfig + , Config(..) + -- * Testing + , isEqualTo + , isFasterThan + -- * Analysis + , standardDeviation + , standardError + , variance + , step + , Benchmark(..) + , Analysis(..) + ) where + +import Parser + +import Control.Arrow +import Control.Applicative +import Control.Concurrent +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Function +import Data.IORef +import Data.List +import Data.String +import Data.Time.Clock.System +import Numeric +import Numeric.Natural +import Options.Applicative +import System.Console.ANSI +import System.Console.ANSI.Codes +import System.Console.Terminal.Size +import System.IO +import System.Mem +import System.Process + +import qualified Data.ByteString.Builder as B +import qualified Data.Set as S + +data BenchmarkMeta + = BenchmarkMeta + { information :: Double + , maxDuration :: Rational + , position :: Int + , benchmark :: Benchmark + } + +instance Eq BenchmarkMeta where + (==) = (==) `on` position &&& analysis . benchmark + +instance Ord BenchmarkMeta where + compare = compare `on` information &&& negate . position &&& analysis . benchmark + +-- | Options wich can be specified on the command line or with defaultMainWith. +data Config + = Config + { hideBar :: Bool -- ^ Hide the bar indicating relative performance. + , sameLine :: Bool -- ^ Print the analysis on the same line as the command. + , hideDetails :: Bool -- ^ Hide standard deviation and number of samples. + , printOnce :: Bool -- ^ Print only once the analysis. This is will print the analysis on timeout, maximal relative error or ctrl-c. + , sortByMean :: Bool -- ^ Sort benchmarks by mean duration. + , simple :: Bool -- ^ Don't colorize output and don't use unicode. + , confidence :: Double -- ^ Factor by which the standard error will be multiplied for calculating confidence intervals (default is 6). + , timeout :: Maybe Double -- ^ Timeout after which the program is terminated. It finishes the currently running benchmark. + , relativeError :: Maybe Double -- ^ After every benchmark has got a relative error (calculated via confidence interval) below DOUBLE the program is terminated. + } deriving (Show, Read, Eq, Ord) + +-- | Name, current analysis and function of a benchmark. +data Benchmark + = Benchmark + { name :: String + , analysis :: Analysis + , runner :: Analysis -> IO Analysis + } + +-- | Collected data from benchmark runs. +data Analysis + = Analysis + { samples :: Natural + , squaredWeights :: Natural + , mean :: Rational + , qFactor :: Rational + } deriving (Eq, Ord, Show, Read) + +-- | Main function for running a list of benchmarks. It also allows +-- to specify options via commandline. +-- +-- > defaultMain [bench "not True" not True, bench "id True" id True] +defaultMain :: [Benchmark] -> IO () +defaultMain bs = flip defaultMainWith bs =<< execParser opts + where + opts = info (configParser Config <**> helper) fullDesc + +-- | Construct a benchmark of a name, a pure function and an argument. +-- +-- > bench "reverse abc" reverse "abc" +bench :: NFData b => String -> (a -> b) -> a -> Benchmark +bench label f x = Benchmark label (Analysis 0 0 0 0) $ \ana -> newIORef x >>= \io -> measure (\n -> replicateM_ n $ (return$!) . force . f =<< readIORef io) ana + +-- | Construct a benchmark of a name and an impure function. +-- +-- > benchIO "ioref" (newIORef () >>= readIORef) +benchIO :: String -> IO a -> Benchmark +benchIO label io = Benchmark label (Analysis 0 0 0 0) (measure (`replicateM_` io)) + +-- | Construct a benchmark of a name and a shell command. +-- +-- > benchShell "sleep is slow" "sleep 0" +benchShell :: String -> String -> Benchmark +benchShell label cmd = Benchmark label (Analysis 0 0 0 0) $ measure go + where go n = uncurry (>>) $ ((`replicateM_` f 10000) *** f) (n `divMod` 10000) + f x = withCreateProcess (shell (intercalate ";" $ replicate x cmd)) {std_out = CreatePipe, std_err = CreatePipe} $ \_ _ _ p -> + waitForProcess p >> threadDelay 0 -- this is needed to let UserInterrupt be handled + +-- | Configurable main function for running a list of benchmarks. +-- +-- > defaultMainWith defaultConfig {hideBar = True} [bench "id ()" id ()] +defaultMainWith :: Config -> [Benchmark] -> IO () +defaultMainWith _ [] = pure () +defaultMainWith cfg bs | printOnce cfg = go (pure ()) + | otherwise = bracket_ hideCursor showCursor + . go . B.hPutBuilder stdout . fromString $ replicate (printHeight cfg*length bs) '\n' + where go mkSpace = hSetEcho stdin False *> mkSpace *> warmup *> runMain cfg (S.fromList . zipWith (BenchmarkMeta 0 0) [1..] $ reverse pad) + pad | sameLine cfg = let len = maximum (map (length . name) bs) in map (\x -> x{name = take len $ name x ++ repeat ' '}) bs + | otherwise = bs + +-- | Default configuration. Use this combined with record updates to +-- ensure compatibility with future releases. +defaultConfig :: Config +defaultConfig = Config + { hideBar = False + , sameLine = False + , hideDetails = False + , printOnce = False + , sortByMean = False + , simple = False + , confidence = 6 + , timeout = Nothing + , relativeError = Nothing + } + +-- | Determine whether two benchmarks have got the same performance. +-- It runs each benchmark until their confidence intervals don't +-- overlap - in which case False is returned - or are no bigger than +-- 1% of the mean - in which case True is returned. +-- +-- This function is meant to be used in test suites as infix function. +-- +-- > benchShell "echo" "echo" `isEqualTo` benchShell "sleep 0" "sleep 0" +isEqualTo :: Benchmark -> Benchmark -> IO Bool +isEqualTo b1 b2 = (EQ==) <$> compareBench defaultConfig 0.01 b1 b2 + +-- | Determine whether a benchmark is faster than another. It runs +-- each benchmark until their confidence intervals don't overlap or +-- are no bigger than 1% of the mean. If the confidence intervals +-- don't overlap and the mean of the first is lower True will be +-- returned. Otherwise False. +-- +-- This function is meant to be used in test suites as infix function. +-- +-- > benchShell "echo" "echo" `isFasterThan` benchShell "sleep 0" "sleep 0" +isFasterThan :: Benchmark -> Benchmark -> IO Bool +isFasterThan b1 b2 = (LT==) <$> compareBench defaultConfig 0.01 b1 b2 + +-- | Calculate the standard deviation of an Analysis. +standardDeviation :: Analysis -> Double +standardDeviation a = sqrt (fromRational $ variance a) / biasCorrection + where biasCorrection + = 1 + - 1/(4*fromIntegral (samples a)) + - 7/(32*fromIntegral (samples a)**2) + - 19/(128*fromIntegral (samples a)**3) + +-- | Calculate the standard error of an Analysis. +standardError :: Analysis -> Double +standardError a | samples a == 1 = fromRational (mean a) + | otherwise = standardDeviation a * sqrt (fromIntegral $ squaredWeights a) / fromIntegral (samples a) + +-- | Calculate the variance of an Analysis. +variance :: Analysis -> Rational +variance a | samples a > 1 = qFactor a / fromIntegral (samples a - 1) + | otherwise = 0 + +-- | Run the benchmark once and update its analysis. For functions +-- with very low runtimes multiple runs will be executed. +step :: Benchmark -> IO Benchmark +step (Benchmark n a f) = flip (Benchmark n) f <$> f a + +-- * Internal functions. + +printBenchmark :: Config -> BenchmarkMeta -> IO () +printBenchmark cfg b = do + w <- maybe 60 width <$> size + B.hPutBuilder stdout . mv $ renderBenchmark cfg w (maxDuration b) (benchmark b) + where mv x | sortByMean cfg || printOnce cfg = x + | otherwise = linesUp (printHeight cfg*position b) <> x <> linesDown (printHeight cfg*(position b-1)) + +linesUp :: Int -> B.Builder +linesUp n | n > 0 = csi' [n] 'F' + | n < 0 = csi' [abs n] 'E' + | otherwise = mempty + +linesDown :: Int -> B.Builder +linesDown = linesUp . negate + +clear :: Config -> B.Builder +clear cfg | printOnce cfg = mempty + | otherwise = csi' [0] 'K' + +mUnless :: Monoid m => Bool -> m -> m +mUnless t = mWhen (not t) + +mWhen :: Monoid m => Bool -> m -> m +mWhen t x = if t then x else mempty + +renderBenchmark :: Config -> Int -> Rational -> Benchmark -> B.Builder +renderBenchmark cfg w maxDuration Benchmark{..} + = mUnless (simple cfg) (sgrBuilder $ SetColor Foreground Vivid Cyan) + <> fromString name + <> mUnless (simple cfg) (sgrBuilder Reset) + <> mUnless (sameLine cfg) (clear cfg <> B.char7 '\n' <> B.char7 ' ') + <> B.char7 ' ' + <> renderAnalysis cfg analysis + <> clear cfg + <> B.char7 '\n' + <> mUnless (hideBar cfg) + ( mUnless (samples analysis <= 1) + ( barBuilder cfg w (mean analysis / maxDuration) (min 1 $ confidence cfg * standardError analysis / fromRational (mean analysis)) (min 1 $ standardDeviation analysis / fromRational (mean analysis)) + <> clear cfg + ) <> B.char7 '\n' + ) + +printHeight :: Config -> Int +printHeight cfg = 3 - fromEnum (hideBar cfg) - fromEnum (sameLine cfg) + +runMain :: Config -> S.Set BenchmarkMeta -> IO () +runMain cfg = printAll <=< go . (,) 0 + where + go (m, s) = handleJust (\e -> if e == UserInterrupt then Just s else Nothing) pure $ + let (BenchmarkMeta{..}, s') = S.deleteFindMin s in do + ana <- analysis <$> step benchmark + let newMax | m == mean (analysis benchmark) = mean ana + | otherwise = max m $ mean ana + new = BenchmarkMeta (informationOf ana) newMax position benchmark{analysis = ana} + set = S.insert new s' + mask_ $ pp new set + + if terminates set + then pure set + else go (newMax, set) + + f | sortByMean cfg = sortOn (negate . mean . analysis . benchmark) + | otherwise = sortOn (negate . position) + + printAll set = do + when (sortByMean cfg && not (printOnce cfg)) . B.hPutBuilder stdout . linesUp $ printHeight cfg*length set + mapM_ (printBenchmark cfg) . f $ S.toList set + + terminates set = let as = map (analysis . benchmark) $ S.toList set + in maybe False (<= fromRational (sum $ map (uncurry (*) . (mean &&& fromIntegral . samples)) as)) (timeout cfg) + || maybe False (>= maximum (map (uncurry (/) . ((confidence cfg*) . standardError &&& fromRational . mean)) as)) (relativeError cfg) + + pp n set + | printOnce cfg = pure () + | sortByMean cfg = printAll set + | otherwise = printBenchmark cfg n + +measure :: (Int -> IO a) -> Analysis -> IO Analysis +measure cmd ana + = performMinorGC + >> refineAnalysis ana + <$> getSystemTime + <* cmd (fromIntegral $ weightOf ana) + <*> getSystemTime + +renderAnalysis :: Config -> Analysis -> B.Builder +renderAnalysis cfg a@Analysis{..} + = mUnless (samples == 0) $ B.char7 't' <> B.char7 '=' + <> prettyScientific (simple cfg) (fromRational mean) (Just $ confidence cfg * standardError a) + <> B.char7 's' + <> mUnless (hideDetails cfg) + ( B.char7 ' ' + <> mUnless (samples <= 1) + ( (if simple cfg then fromString "SD" else B.charUtf8 'σ') + <> B.char7 '=' + <> prettyScientific (simple cfg) (100 * standardDeviation a / fromRational mean) Nothing + <> B.char7 '%' <> B.char7 ' ' + ) + <> B.char7 'n' <> B.char7 '=' + <> prettyNatural samples + ) + +warmup :: IO () +warmup = void . foldr1 (>=>) (replicate 10 step) . benchIO "warmup" $ pure () + +compareBench :: Config -> Double -> Benchmark -> Benchmark -> IO Ordering +compareBench cfg d x1 x2 = warmup *> fix go x1 x2 + where go h b1 b2 | oneOf ((<3) . samples) || oneOf ((<1) . informationOf) = next + | otherwise = case compareMeans cfg (analysis b1) (analysis b2) of + EQ | oneOf (relativeErrorAbove cfg (d/2)) -> next + r -> pure r + where next | ((<=) `on` informationOf . analysis) b1 b2 = (`h` b2) =<< step b1 + | otherwise = h b1 =<< step b2 + oneOf f = f (analysis b1) || f (analysis b2) + +relativeErrorAbove :: Config -> Double -> Analysis -> Bool +relativeErrorAbove cfg d a = d < confidence cfg * standardError a / fromRational (mean a) + +compareMeans :: Config -> Analysis -> Analysis -> Ordering +compareMeans cfg a1 a2 + | f a1 a2 = LT + | f a2 a1 = GT + | otherwise = EQ + where f x y = fromRational (mean x) + confidence cfg*standardError x < fromRational (mean y) - confidence cfg*standardError y + +prettyNatural :: Natural -> B.Builder +prettyNatural = go . fromIntegral + where + go x = case divMod x 1000 of + (a,b) | a == 0 -> B.wordDec b + | b > 99 -> go a <> B.char7 ',' <> B.wordDec b + | b > 9 -> go a <> B.char7 ',' <> B.char7 '0' <> B.wordDec b + | otherwise -> go a <> B.char7 ',' <> B.char7 '0' <> B.char7 '0' <> B.wordDec b + +prettyScientific :: Bool -> Double -> Maybe Double -> B.Builder +prettyScientific ascii x b = case floatToDigits 10 . min x <$> b of + Just (errSig,errExpo) | errSig /= [0] && valLen errExpo > 0 -> mantissa (take (valLen errExpo) $ sig ++ repeat 0) <> showError errSig <> f expo + _ | x == 0 -> B.char7 '0' + _ -> mantissa (take 2 $ sig ++ repeat 0) <> f expo + where + showError err = B.char7 '(' <> foldMap B.intDec (take 2 $ err ++ repeat 0) <> B.char7 ')' + (sig,expo) = floatToDigits 10 x + valLen e = expo - e + 2 + mantissa [d] = B.intDec d + mantissa (d:ds) = B.intDec d <> B.char7 '.' <> foldMap B.intDec ds + mantissa [] = mempty + f 1 = mempty + f e | ascii = B.char7 '*' <> B.intDec 10 <> mWhen (e/=2) (B.char7 '^' <> B.intDec (e-1)) + | otherwise = B.charUtf8 '·' <> B.intDec 10 <> mWhen (e/=2) (showE (e-1)) + +showE :: Integral a => a -> B.Builder +showE = fix go + where go f n | n < 0 = B.charUtf8 '⁻' <> f (abs n) + | n < 10 = B.charUtf8 $ "⁰¹²³⁴⁵⁶⁷⁸⁹" !! fromIntegral n + | otherwise = uncurry ((<>) `on` f) $ divMod n 10 + +informationOf :: Analysis -> Double +informationOf Analysis{..} = fromRational mean ** 0.7 * fromIntegral samples + +weightOf :: Analysis -> Natural +weightOf Analysis{..} = fromIntegral . max 1 . min samples . round . recip $ (fromRational mean :: Double) ** 0.7 + +refineAnalysis :: Analysis -> SystemTime -> SystemTime -> Analysis +refineAnalysis ana@Analysis{..} begin end = Analysis newSamples newSquaredWeights newMean newQFactor + where + newSamples = samples + weightOf ana + newSquaredWeights = squaredWeights + weightOf ana*weightOf ana + newMean = mean + diffWeight / fromIntegral newSamples + newQFactor = qFactor + diffWeight * (time - newMean) + diffWeight = fromIntegral (weightOf ana) * (time - mean) + time = (toSeconds end - toSeconds begin) / fromIntegral (weightOf ana) + toSeconds t = fromIntegral (systemSeconds t) + fromIntegral (systemNanoseconds t) / 1e9 + +sgrBuilder :: SGR -> B.Builder +sgrBuilder = (`csi'` 'm') . sgrToCode + +csi' :: [Int] -> Char -> B.Builder +csi' (x:xs) b = B.char7 '\ESC' <> B.char7 '[' <> B.intDec x <> foldMap (\n -> B.char7 ';' <> B.intDec n) xs <> B.char7 b +csi' [] b = B.char7 '\ESC' <> B.char7 '[' <> B.char7 b + +barBuilder :: Config -> Int -> Rational -> Double -> Double -> B.Builder +barBuilder cfg width m stdErr sd | simple cfg = + B.char7 ' ' <> B.char7 ' ' <> B.string7 (replicate (pred valueLength) '=') + <> B.string7 (replicate errorLength '<') + <> mWhen (len * stdErr >= 0.20) (B.char7 '+') + <> B.string7 (replicate errorLength '>') + <> B.string7 (replicate sigmaLength '-') + | otherwise = + B.char7 ' ' <> B.char7 ' ' <> B.stringUtf8 (replicate (pred valueLength) '▀') + <> sgrBuilder (SetColor Foreground Dull Magenta) + <> B.stringUtf8 (replicate errorLength '▀') + <> mWhen (len * stdErr >= 0.20) + (sgrBuilder (SetColor Foreground Vivid Magenta) <> B.charUtf8 '▀') + <> sgrBuilder (SetColor Foreground Dull Magenta) + <> B.stringUtf8 (replicate errorLength '▀') + <> sgrBuilder (SetColor Foreground Vivid Black) + <> B.stringUtf8 (replicate sigmaLength '▔') + <> sgrBuilder Reset + where + len = fromRational m * fromIntegral (width - 6) / 2 + valueLength = round len - errorLength + errorLength = round $ len * stdErr + sigmaLength = round (len * sd) - errorLength