nano-ui-0.1.0.0: benchmark/IdBench.hs

module Main (main) where

import Control.Monad (forM_, replicateM_, void, when)
import GHC.Stats (RTSStats (..), getRTSStats)
import NanoUI
import NanoUI.Testing (newContext, runFrame)
import System.Exit (exitFailure)
import System.Mem (performGC)
import Test.Tasty.Bench

benchInput :: Input
benchInput = emptyInput {inputWindowSize = Size 100 100}

-- A layout root is required or runFrame overflows.
idBurst :: NanoUI ()
idBurst = column (burstNextIds 4096)

scopedWidgets :: NanoUI ()
scopedWidgets =
  columnWith (gap 2)
    $ replicateM_ 32
    $ rowWith (gap 2)
    $ replicateM_ 32 (void nextId)

measureFrameAlloc :: NanoUI a -> IO Integer
measureFrameAlloc ui = do
  ctx <- newContext
  _ <- runFrame ctx benchInput (column (void nextId))
  performGC
  before <- getRTSStats
  _ <- runFrame ctx benchInput ui
  after <- getRTSStats
  pure (fromIntegral (allocated_bytes after - allocated_bytes before) :: Integer)

main :: IO ()
main = do
  let scenes = [("burst4096", idBurst), ("scopedWidgets", scopedWidgets)]
  forM_ scenes $ \(name, ui) -> do
    alloc <- measureFrameAlloc ui
    when (alloc > 0) $ do
      putStrLn ("FAIL: " ++ name ++ " allocated " ++ show alloc ++ " bytes during runFrame")
      exitFailure
  defaultMain
    [ bgroup
        "id/nextId"
        [ bench name $ whnfIO $ do
            ctx <- newContext
            void (runFrame ctx benchInput ui)
        | (name, ui) <- scenes
        ]
    ]