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)

-- A "benchmark blueprint" sum type, that captures the basic shape of a benchmark, which is either "in memory" (i.e.
-- defined with 'function' or 'action', to be run live), or read from a file (and thus static).
data B a b
  = MemoryBenchmark a
  | FileBenchmark b

------------------------------------------------------------------------------------------------------------------------

-- Here we walk through the livecycle of a benchmark. It starts out "unresolved", because we (may) have a file paths
-- from a user from which we want to parse some previously-saved estimate(s).
--
-- If anything goes wrong (file doesn't exist, data doesn't parse, etc) we just map that to Nothing and keep going.

-- | A single benchmark.
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))
  -- FIXME try reading file
  FileBenchmark FilePath
_path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- Next, we slightly munge the data by flattening each file (each containing 1+ benchmarks) into a flat list. Each
-- element in this flattened list corresponds to one benchmark (either "live" / to-be-run, or "dead" / parsed-from-a-
-- file), so each has a name, so we can pull the Named type wrapper out of the type.

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

-- And finally, we "activate" a benchmark, which means (in the case of a "live" / to-be-run benchmark) just turning our
-- 'Benchable ()' into a 'LiveBenchmark RtsStats'. This makes it ready to be tugged on and updated.
--
-- Activating a "dead" / parsed-from-a-file benchmark does nothing.

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)

-- Whew! Benchmark lifecycle walkthrough over.

------------------------------------------------------------------------------------------------------------------------

-- | Run a collection of benchmarks.
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 -- impossible: no live or file benchmarks?

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

-- | Benchmark a function. The result is evaluated to weak head normal form.
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)))

-- | Benchmark an @IO@ action. The result is evaluated to weak head normal form.
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)