module ParkBench
( Benchmark,
benchmark,
function,
action,
file,
)
where
import Control.Concurrent (threadDelay)
import Data.Function ((&))
import qualified Data.List.NonEmpty as List1
import Data.Maybe (catMaybes)
import qualified Data.Text as Text (pack)
import ParkBench.Internal.Array1 (Array1)
import qualified ParkBench.Internal.Array1 as Array1
import ParkBench.Internal.Benchable (Benchable)
import qualified ParkBench.Internal.Benchable as Benchable
import ParkBench.Internal.Config (Config (Config))
import qualified ParkBench.Internal.Config as Config
import qualified ParkBench.Internal.Driver as Driver
import qualified ParkBench.Internal.Measure as Measure
import ParkBench.Internal.Named (Named (Named))
import ParkBench.Internal.Prelude
import ParkBench.Internal.Pretty (renderTable)
import ParkBench.Internal.Render (estimatesToTable)
import ParkBench.Internal.RtsStats (RtsStats)
import ParkBench.Internal.Statistics (Estimate)
import ParkBench.Internal.Terminal (renderToTerminal, withTerminal)
data B a b
= MemoryBenchmark a
| FileBenchmark b
newtype Benchmark
= Benchmark UnresolvedBenchmarks
type UnresolvedBenchmarks =
B (Named (Benchable ())) FilePath
type ResolvedBenchmarks =
B (Named (Benchable ())) (Array1 (Named (Estimate RtsStats)))
type ResolvedBenchmark =
B (Benchable ()) (Estimate RtsStats)
type ActivatedBenchmark =
B (Driver.LiveBenchmark RtsStats) (Estimate RtsStats)
resolveBenchmarks :: UnresolvedBenchmarks -> IO (Maybe ResolvedBenchmarks)
resolveBenchmarks :: UnresolvedBenchmarks -> IO (Maybe ResolvedBenchmarks)
resolveBenchmarks = \case
MemoryBenchmark Named (Benchable ())
benchable -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall a b. a -> B a b
MemoryBenchmark Named (Benchable ())
benchable))
FileBenchmark FilePath
_path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
flattenResolvedBenchmarks :: ResolvedBenchmarks -> [Named ResolvedBenchmark]
flattenResolvedBenchmarks :: ResolvedBenchmarks -> [Named ResolvedBenchmark]
flattenResolvedBenchmarks = \case
MemoryBenchmark Named (Benchable ())
benchable -> [forall a b. a -> B a b
MemoryBenchmark forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Named (Benchable ())
benchable]
FileBenchmark Array1 (Named (Estimate RtsStats))
estimates -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> B a b
FileBenchmark forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Array1 a -> [a]
Array1.toList Array1 (Named (Estimate RtsStats))
estimates
activateBenchmark :: Driver.BenchmarkConfig -> ResolvedBenchmark -> IO ActivatedBenchmark
activateBenchmark :: BenchmarkConfig -> ResolvedBenchmark -> IO ActivatedBenchmark
activateBenchmark BenchmarkConfig
config = \case
MemoryBenchmark Benchable ()
benchable ->
forall a b. a -> B a b
MemoryBenchmark forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Roll a =>
BenchmarkConfig -> Benchable (Timed a) -> IO (LiveBenchmark a)
Driver.benchmark BenchmarkConfig
config (forall a b. (IO a -> IO b) -> Benchable a -> Benchable b
Benchable.mapIO forall a. IO a -> IO (Timed RtsStats)
Measure.measure Benchable ()
benchable)
FileBenchmark Estimate RtsStats
estimate -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> B a b
FileBenchmark Estimate RtsStats
estimate)
benchmark ::
[Benchmark] ->
IO void
benchmark :: forall void. [Benchmark] -> IO void
benchmark (coerce :: forall a b. Coercible a b => a -> b
coerce @[Benchmark] @[UnresolvedBenchmarks] -> [UnresolvedBenchmarks]
benchmarks0) = do
[ResolvedBenchmarks]
benchmarks <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UnresolvedBenchmarks -> IO (Maybe ResolvedBenchmarks)
resolveBenchmarks [UnresolvedBenchmarks]
benchmarks0
case forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [ResolvedBenchmarks]
benchmarks of
Maybe (NonEmpty ResolvedBenchmarks)
Nothing -> forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound)
Just NonEmpty ResolvedBenchmarks
resolvedBenchmarks0 ->
NonEmpty ResolvedBenchmarks
resolvedBenchmarks0
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResolvedBenchmarks -> [Named ResolvedBenchmark]
flattenResolvedBenchmarks
forall a b. a -> (a -> b) -> b
& forall a. [a] -> Array1 a
Array1.unsafeFromList
forall a b. a -> (a -> b) -> b
& forall void. Array1 (Named ResolvedBenchmark) -> IO void
benchmark_
benchmark_ :: Array1 (Named ResolvedBenchmark) -> IO void
benchmark_ :: forall void. Array1 (Named ResolvedBenchmark) -> IO void
benchmark_ Array1 (Named ResolvedBenchmark)
resolvedBenchmarks = do
Config
config <- IO Config
Config.getFromEnv
forall a.
((Array1 (Named (Estimate RtsStats)) -> IO ()) -> IO a) -> IO a
withRenderEstimatesToTerminal \Array1 (Named (Estimate RtsStats)) -> IO ()
renderEstimatesToTerminal -> do
Array1 (Named ActivatedBenchmark)
activatedBenchmarks <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (BenchmarkConfig -> ResolvedBenchmark -> IO ActivatedBenchmark
activateBenchmark (Config -> BenchmarkConfig
makeBenchmarkConfig Config
config))) Array1 (Named ResolvedBenchmark)
resolvedBenchmarks
let maybeLiveBenchmarks :: Maybe (Array1 (LiveBenchmark RtsStats))
maybeLiveBenchmarks =
Array1 (Named ActivatedBenchmark)
activatedBenchmarks
forall a b. a -> (a -> b) -> b
& forall a b. (a -> Maybe b) -> Array1 a -> Maybe (Array1 b)
Array1.mapMaybe \case
Named Text
_name (MemoryBenchmark LiveBenchmark RtsStats
liveBenchmark) -> forall a. a -> Maybe a
Just LiveBenchmark RtsStats
liveBenchmark
Named Text
_name (FileBenchmark Estimate RtsStats
_) -> forall a. Maybe a
Nothing
let maybeFileBenchmarks :: Maybe (Array1 (Named (Estimate RtsStats)))
maybeFileBenchmarks =
Array1 (Named ActivatedBenchmark)
activatedBenchmarks
forall a b. a -> (a -> b) -> b
& forall a b. (a -> Maybe b) -> Array1 a -> Maybe (Array1 b)
Array1.mapMaybe \case
Named Text
_name (MemoryBenchmark LiveBenchmark RtsStats
_) -> forall a. Maybe a
Nothing
Named Text
name (FileBenchmark Estimate RtsStats
estimate) -> forall a. a -> Maybe a
Just (forall a. Text -> a -> Named a
Named Text
name Estimate RtsStats
estimate)
case (Maybe (Array1 (LiveBenchmark RtsStats))
maybeLiveBenchmarks, Maybe (Array1 (Named (Estimate RtsStats)))
maybeFileBenchmarks) of
(Just Array1 (LiveBenchmark RtsStats)
liveBenchmarks0, Maybe (Array1 (Named (Estimate RtsStats)))
_) ->
forall a void. a -> (a -> IO a) -> IO void
loopForever (forall a. Array1 (LiveBenchmark a) -> LiveBenchmarks a
Driver.makeLiveBenchmarks Array1 (LiveBenchmark RtsStats)
liveBenchmarks0) \LiveBenchmarks RtsStats
liveBenchmarks -> do
Array1 (Named (Estimate RtsStats))
estimates <-
Array1 (Named ActivatedBenchmark)
activatedBenchmarks
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
( forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse \case
MemoryBenchmark LiveBenchmark RtsStats
liveBenchmark -> forall a. LiveBenchmark a -> IO (Estimate a)
Driver.sampleLiveBenchmark LiveBenchmark RtsStats
liveBenchmark
FileBenchmark Estimate RtsStats
estimate -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Estimate RtsStats
estimate
)
Array1 (Named (Estimate RtsStats)) -> IO ()
renderEstimatesToTerminal Array1 (Named (Estimate RtsStats))
estimates
forall a. LiveBenchmarks a -> IO (LiveBenchmarks a)
Driver.stepLiveBenchmarks LiveBenchmarks RtsStats
liveBenchmarks
(Maybe (Array1 (LiveBenchmark RtsStats))
Nothing, Just Array1 (Named (Estimate RtsStats))
estimates) -> do
Array1 (Named (Estimate RtsStats)) -> IO ()
renderEstimatesToTerminal Array1 (Named (Estimate RtsStats))
estimates
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound)
(Maybe (Array1 (LiveBenchmark RtsStats))
Nothing, Maybe (Array1 (Named (Estimate RtsStats)))
Nothing) -> forall a. HasCallStack => a
undefined
makeBenchmarkConfig :: Config -> Driver.BenchmarkConfig
makeBenchmarkConfig :: Config -> BenchmarkConfig
makeBenchmarkConfig Config {Rational
$sel:runlen:Config :: Config -> Rational
runlen :: Rational
runlen} =
Driver.BenchmarkConfig {Rational
$sel:runlen:BenchmarkConfig :: Rational
runlen :: Rational
runlen}
withRenderEstimatesToTerminal :: ((Array1 (Named (Estimate RtsStats)) -> IO ()) -> IO a) -> IO a
withRenderEstimatesToTerminal :: forall a.
((Array1 (Named (Estimate RtsStats)) -> IO ()) -> IO a) -> IO a
withRenderEstimatesToTerminal (Array1 (Named (Estimate RtsStats)) -> IO ()) -> IO a
f =
forall a. (Terminal -> IO a) -> IO a
withTerminal \Terminal
terminal ->
(Array1 (Named (Estimate RtsStats)) -> IO ()) -> IO a
f (Terminal -> Builder -> IO ()
renderToTerminal Terminal
terminal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> Builder
renderTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array1 (Named (Estimate RtsStats)) -> Table
estimatesToTable)
loopForever :: forall a void. a -> (a -> IO a) -> IO void
loopForever :: forall a void. a -> (a -> IO a) -> IO void
loopForever a
x0 a -> IO a
once =
let loop :: a -> IO void
loop :: a -> IO void
loop a
x = do
a
y <- a -> IO a
once a
x
a -> IO void
loop a
y
in a -> IO void
loop a
x0
function ::
String ->
(a -> b) ->
a ->
Benchmark
function :: forall a b. FilePath -> (a -> b) -> a -> Benchmark
function FilePath
name a -> b
f a
x =
UnresolvedBenchmarks -> Benchmark
Benchmark (forall a b. a -> B a b
MemoryBenchmark (forall a. Text -> a -> Named a
Named (FilePath -> Text
Text.pack FilePath
name) (forall a b. (a -> b) -> a -> Benchable ()
Benchable.function a -> b
f a
x)))
action ::
String ->
IO a ->
Benchmark
action :: forall a. FilePath -> IO a -> Benchmark
action FilePath
name IO a
x =
UnresolvedBenchmarks -> Benchmark
Benchmark (forall a b. a -> B a b
MemoryBenchmark (forall a. Text -> a -> Named a
Named (FilePath -> Text
Text.pack FilePath
name) (forall a. IO a -> Benchable ()
Benchable.action IO a
x)))
file ::
FilePath ->
Benchmark
file :: FilePath -> Benchmark
file FilePath
path =
UnresolvedBenchmarks -> Benchmark
Benchmark (forall a b. b -> B a b
FileBenchmark FilePath
path)