{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}

-- |
-- Module: Censor.Runner.Report
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Uniform report rendering and suite scaffolding for censor
-- executables. Three concentric layers:
--
-- * The lowest layer is a header\/case\/footer data model streamed
--   through a 'Renderer'. Three renderers are provided —
--   'pretty' (the ppad terminal aesthetic: bold brand line, dim
--   key column, middle-dot separators, ANSI-colored verdicts on a
--   TTY), 'json' (one @censor\/report-v3@ object per run,
--   deterministic key order, per-case trace arrays when present),
--   and 'plain' (ASCII-only, grep-safe).
-- * 'withReport' streams cases through the chosen renderer and
--   returns the accumulated list so callers can drive exit codes.
-- * At the top, t'TraceSuite' packages up the entire censor
--   test-suite shape (arg parse, meter selection, header assembly,
--   per-case calibration and attribution, trace record, JSON
--   artefact write) into one call, so a suite's @Main.hs@ contains
--   only the hypotheses and case list.

module Censor.Runner.Report (
    -- * Report config
    ReportCfg(..)
  , initReportCfg

    -- * Data model
  , ReportHeader(..)
  , CaseReport(..)
  , ChannelReport(..)
  , BatteryTail(..)

    -- * Renderers
  , Renderer(..)
  , pretty
  , json
  , plain

    -- * Driver
  , withReport

    -- * Format flags
  , Format(..)
  , parseFormat
  , rendererFor
  , takeFormatArg
  , resolveFormat

    -- * Standard suite arg surface
  , SuiteArgs(..)
  , parseSuiteArgs

    -- * Host environment (re-exports)
  , Env(..)
  , captureEnv

    -- * Suite scaffolds
  , BatchPolicy(..)
  , TraceCase(..)
  , TraceSuite(..)
  , runTraceSuite

    -- * JSON serialisation
  , reportJSON
  , resultToJSON
  ) where

import Control.Monad (forM_)
import Data.IORef (newIORef, modifyIORef', readIORef)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Version (showVersion)
import Data.Word (Word64)
import Numeric (showHex)
import qualified System.Environment as Env
import System.Exit (die)
import System.IO (BufferMode(..), hIsTerminalDevice, hSetBuffering, stdout)
import Text.Printf (printf)

import Censor hiding (crBatch, crNoise)
import qualified Censor as C
import Censor.Runner
  ( traceResult, traceFrames, record, thin
  , verdictName, shapeName, clipText, withMeterArg
  , splitMeterName, withSplitMeterArg
  )
import Censor.Runner.Env (Env(..), captureEnv)
import qualified Paths_ppad_censor as Paths

-- | Package name used in the report brand line (@ppad censor@) and
--   the @tool@ field of the JSON envelope. All censor executables
--   render as this string — individual suites do not carry their own
--   brand.
brand :: String
brand :: String
brand = String
"censor"

-- | Package version, sourced from the autogen'd @Paths_ppad_censor@
--   module so it always tracks the cabal file.
brandVersion :: String
brandVersion :: String
brandVersion = Version -> String
showVersion Version
Paths.version

-- report config -------------------------------------------------------------

-- | Runtime knobs for the renderer.
--
--   'rcColor' is set once at startup based on whether stdout is a
--   terminal. All ANSI helpers short-circuit to identity when it is
--   'False'.
data ReportCfg = ReportCfg
  { ReportCfg -> Bool
rcColor :: !Bool
  } deriving (ReportCfg -> ReportCfg -> Bool
(ReportCfg -> ReportCfg -> Bool)
-> (ReportCfg -> ReportCfg -> Bool) -> Eq ReportCfg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReportCfg -> ReportCfg -> Bool
== :: ReportCfg -> ReportCfg -> Bool
$c/= :: ReportCfg -> ReportCfg -> Bool
/= :: ReportCfg -> ReportCfg -> Bool
Eq, Int -> ReportCfg -> String -> String
[ReportCfg] -> String -> String
ReportCfg -> String
(Int -> ReportCfg -> String -> String)
-> (ReportCfg -> String)
-> ([ReportCfg] -> String -> String)
-> Show ReportCfg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReportCfg -> String -> String
showsPrec :: Int -> ReportCfg -> String -> String
$cshow :: ReportCfg -> String
show :: ReportCfg -> String
$cshowList :: [ReportCfg] -> String -> String
showList :: [ReportCfg] -> String -> String
Show)

-- | Initialise a 'ReportCfg' by probing whether stdout is a TTY.
--   Call once at the start of @main@ and thread the result through
--   the renderer callbacks.
initReportCfg :: IO ReportCfg
initReportCfg :: IO ReportCfg
initReportCfg = do
  !isTty <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
  pure ReportCfg { rcColor = isTty }

-- data model ---------------------------------------------------------------

-- | Static header emitted once, before any case row. Populate this
--   at 'main' entry with the run's own metadata; the brand line
--   (@ppad censor v\<VER\>@) is fixed and does not appear here.
data ReportHeader = ReportHeader
  { ReportHeader -> String
rhMeter     :: !String
    -- ^ meter name (@wall@ \/ @instructions@ \/ ...).
  , ReportHeader -> Config
rhConfig    :: !Config
    -- ^ the driver 'Config' the run used (surfaced on the header line).
  , ReportHeader -> Maybe Word64
rhSeed      :: !(Maybe Word64)
    -- ^ user-facing sampler seed (distinct from 'cfgSeed', which
    --   only seeds the per-pair A\/B order bit).
  , ReportHeader -> Maybe String
rhTarget    :: !(Maybe String)
    -- ^ short target description, e.g. @\"Poly1305 MAC ==\"@.
  , ReportHeader -> Maybe String
rhNote      :: !(Maybe String)
    -- ^ optional one-line caveat under the header block.
  , ReportHeader -> Maybe Env
rhEnv       :: !(Maybe Env)
    -- ^ host-environment snapshot taken at run start. 'runTraceSuite'
    --   always populates it; 'Nothing' when the caller assembled the
    --   header by hand without capturing one.
  , ReportHeader -> Bool
rhPerCaseBatch :: !Bool
    -- ^ 'True' when each case picks its own 'cfgBatch' from its
    --   'BatchPolicy' (see 'runTraceSuite'). Header renders
    --   @batch=per-case@ and the config JSON emits
    --   @\"batch\":\"per-case\"@; the resolved batch for each case
    --   appears on that case's row via 'crBatch'. 'False' means the
    --   run used a single 'cfgBatch' from 'rhConfig' throughout,
    --   rendered as usual.
  } deriving Int -> ReportHeader -> String -> String
[ReportHeader] -> String -> String
ReportHeader -> String
(Int -> ReportHeader -> String -> String)
-> (ReportHeader -> String)
-> ([ReportHeader] -> String -> String)
-> Show ReportHeader
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReportHeader -> String -> String
showsPrec :: Int -> ReportHeader -> String -> String
$cshow :: ReportHeader -> String
show :: ReportHeader -> String
$cshowList :: [ReportHeader] -> String -> String
showList :: [ReportHeader] -> String -> String
Show

-- | A single case row.
data CaseReport = CaseReport
  { CaseReport -> String
crName        :: !String
    -- ^ case name displayed on the row.
  , CaseReport -> Result
crResult      :: !Result
    -- ^ the driver's verdict + evidence.
  , CaseReport -> Maybe Attribution
crAttribution :: !(Maybe Attribution)
    -- ^ optional A\/A + B\/B attribution result, surfaced under the
    --   case row on 'Reject'. 'Nothing' when the tool did not run
    --   attribution.
  , CaseReport -> Maybe Int
crBatch       :: !(Maybe Int)
    -- ^ the 'cfgBatch' the case actually ran under. Populated by
    --   'runTraceSuite' from per-case 'calibrateBatch'; 'Nothing'
    --   when the case ran under a shared 'rhConfig' batch.
  , CaseReport -> Maybe Noise
crNoise       :: !(Maybe Noise)
    -- ^ the meter's noise floor at the calibrated batch, from the
    --   case's t'CalibReport'. 'Nothing' when the case was not
    --   calibrated per-case.
  , CaseReport -> Maybe Noise
crBaseline    :: !(Maybe Noise)
    -- ^ baseline cost of the target on fresh class-A draws at the
    --   case's batch, from 'baselineReading': median and IQR in
    --   per-batch meter units, the scale of 'resEffect'. 'Nothing'
    --   when the tool did not probe one.
  , CaseReport -> Maybe [Frame]
crTrace       :: !(Maybe [Frame])
    -- ^ per-pair 'Frame' trajectory, when the runner recorded one
    --   (via 'record'). Surfaces in the JSON artefact as a thinned
    --   array; the human renderers ignore it.
  , CaseReport -> [ChannelReport]
crChannels    :: ![ChannelReport]
    -- ^ further channels read on the case's own pairs and reported
    --   beside its verdict: the period and wall channels of a split
    --   run ('Censor.runSplitWith'), whose 'crResult' is the cycles
    --   channel. Empty under a single meter.
  } deriving Int -> CaseReport -> String -> String
[CaseReport] -> String -> String
CaseReport -> String
(Int -> CaseReport -> String -> String)
-> (CaseReport -> String)
-> ([CaseReport] -> String -> String)
-> Show CaseReport
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CaseReport -> String -> String
showsPrec :: Int -> CaseReport -> String -> String
$cshow :: CaseReport -> String
show :: CaseReport -> String
$cshowList :: [CaseReport] -> String -> String
showList :: [CaseReport] -> String -> String
Show

-- | A channel reported beside a case's verdict.
data ChannelReport = ChannelReport
  { ChannelReport -> String
chName        :: !String
    -- ^ channel name (@period@, @wall@).
  , ChannelReport -> String
chUnit        :: !String
    -- ^ the unit of its readings (@fs@ per cycle, @ns@).
  , ChannelReport -> Result
chResult      :: !Result
    -- ^ the channel's own test over the case's pairs.
  , ChannelReport -> Maybe Attribution
chAttribution :: !(Maybe Attribution)
    -- ^ the channel's A\/A + B\/B controls, on a rejection.
  } deriving Int -> ChannelReport -> String -> String
[ChannelReport] -> String -> String
ChannelReport -> String
(Int -> ChannelReport -> String -> String)
-> (ChannelReport -> String)
-> ([ChannelReport] -> String -> String)
-> Show ChannelReport
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ChannelReport -> String -> String
showsPrec :: Int -> ChannelReport -> String -> String
$cshow :: ChannelReport -> String
show :: ChannelReport -> String
$cshowList :: [ChannelReport] -> String -> String
showList :: [ChannelReport] -> String -> String
Show

-- | The tail passed to a renderer's 'rndClose'. Carries the
--   accumulated case list and, optionally, the path to a companion
--   artefact (a trace JSON, a log) that the tool wrote alongside.
data BatteryTail = BatteryTail
  { BatteryTail -> [CaseReport]
btCases  :: ![CaseReport]
  , BatteryTail -> Maybe String
btOutput :: !(Maybe FilePath)
  } deriving Int -> BatteryTail -> String -> String
[BatteryTail] -> String -> String
BatteryTail -> String
(Int -> BatteryTail -> String -> String)
-> (BatteryTail -> String)
-> ([BatteryTail] -> String -> String)
-> Show BatteryTail
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BatteryTail -> String -> String
showsPrec :: Int -> BatteryTail -> String -> String
$cshow :: BatteryTail -> String
show :: BatteryTail -> String
$cshowList :: [BatteryTail] -> String -> String
showList :: [BatteryTail] -> String -> String
Show

-- renderer interface -------------------------------------------------------

-- | A rendering strategy: one callback per lifecycle event.
--
--   The lifecycle is @rndOpen@ (once), then @rndCase@ per case (in
--   order), then @rndClose@ (once). Streaming renderers ('pretty',
--   'plain') emit at each callback; buffered renderers ('json') use
--   the case callback as a no-op and emit the full object at close.
data Renderer = Renderer
  { Renderer -> ReportCfg -> ReportHeader -> IO ()
rndOpen  :: ReportCfg -> ReportHeader -> IO ()
  , Renderer -> ReportCfg -> CaseReport -> IO ()
rndCase  :: ReportCfg -> CaseReport   -> IO ()
  , Renderer -> ReportCfg -> ReportHeader -> BatteryTail -> IO ()
rndClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
  }

-- format flag --------------------------------------------------------------

-- | Selectable output format.
data Format = FmtPretty | FmtJson | FmtPlain
  deriving (Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
/= :: Format -> Format -> Bool
Eq, Int -> Format -> String -> String
[Format] -> String -> String
Format -> String
(Int -> Format -> String -> String)
-> (Format -> String)
-> ([Format] -> String -> String)
-> Show Format
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Format -> String -> String
showsPrec :: Int -> Format -> String -> String
$cshow :: Format -> String
show :: Format -> String
$cshowList :: [Format] -> String -> String
showList :: [Format] -> String -> String
Show)

-- | Parse a @--format@ argument: @pretty@, @json@, or @plain@.
parseFormat :: String -> Maybe Format
parseFormat :: String -> Maybe Format
parseFormat String
s = case String
s of
  String
"pretty" -> Format -> Maybe Format
forall a. a -> Maybe a
Just Format
FmtPretty
  String
"json"   -> Format -> Maybe Format
forall a. a -> Maybe a
Just Format
FmtJson
  String
"plain"  -> Format -> Maybe Format
forall a. a -> Maybe a
Just Format
FmtPlain
  String
_        -> Maybe Format
forall a. Maybe a
Nothing

-- | The 'Renderer' for a 'Format'.
rendererFor :: Format -> Renderer
rendererFor :: Format -> Renderer
rendererFor Format
FmtPretty = Renderer
pretty
rendererFor Format
FmtJson   = Renderer
json
rendererFor Format
FmtPlain  = Renderer
plain

-- | Position-insensitively pluck a @--format FMT@ pair out of an
--   argv list. Returns the format token if present and the argv with
--   that pair removed.
takeFormatArg :: [String] -> (Maybe String, [String])
takeFormatArg :: [String] -> (Maybe String, [String])
takeFormatArg = String -> [String] -> (Maybe String, [String])
takeFlagArg String
"--format"

-- pluck a @FLAG VALUE@ pair out of an argv list, wherever it sits.
takeFlagArg :: String -> [String] -> (Maybe String, [String])
takeFlagArg :: String -> [String] -> (Maybe String, [String])
takeFlagArg String
flag = [String] -> [String] -> (Maybe String, [String])
go []
  where
    go :: [String] -> [String] -> (Maybe String, [String])
go [String]
pre (String
x:String
v:[String]
rest) | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
flag = (String -> Maybe String
forall a. a -> Maybe a
Just String
v, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
pre [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rest)
    go [String]
pre (String
x:[String]
xs)                 = [String] -> [String] -> (Maybe String, [String])
go (String
xString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
pre) [String]
xs
    go [String]
pre []                     = (Maybe String
forall a. Maybe a
Nothing, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
pre)

-- | Resolve an optional format token to a 'Renderer', dying with a
--   clear message on unknown values. Defaults to 'pretty' when the
--   token is absent.
resolveFormat :: Maybe String -> IO Renderer
resolveFormat :: Maybe String -> IO Renderer
resolveFormat Maybe String
Nothing  = Renderer -> IO Renderer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Renderer
pretty
resolveFormat (Just String
s) = case String -> Maybe Format
parseFormat String
s of
  Just Format
f  -> Renderer -> IO Renderer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> Renderer
rendererFor Format
f)
  Maybe Format
Nothing -> String -> IO Renderer
forall a. String -> IO a
die (String -> IO Renderer) -> String -> IO Renderer
forall a b. (a -> b) -> a -> b
$ String
"unknown --format " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (expected pretty|json|plain)"

-- driver -------------------------------------------------------------------

-- | Stream a battery through a renderer.
--
--   The body callback is handed an @emit@ action that records one
--   case row; call it after each hypothesis completes. The body may
--   return the path of a companion artefact (e.g. a trace JSON) to
--   surface in the footer. The accumulated case list is returned so
--   callers can drive an exit code off the verdicts.
withReport
  :: ReportCfg
  -> Renderer
  -> ReportHeader
  -> ((CaseReport -> IO ()) -> IO (Maybe FilePath))
  -> IO [CaseReport]
withReport :: ReportCfg
-> Renderer
-> ReportHeader
-> ((CaseReport -> IO ()) -> IO (Maybe String))
-> IO [CaseReport]
withReport ReportCfg
rc Renderer
rnd ReportHeader
hdr (CaseReport -> IO ()) -> IO (Maybe String)
body = do
  ref <- [CaseReport] -> IO (IORef [CaseReport])
forall a. a -> IO (IORef a)
newIORef ([] :: [CaseReport])
  rndOpen rnd rc hdr
  out <- body $ \CaseReport
cr -> do
    Renderer -> ReportCfg -> CaseReport -> IO ()
rndCase Renderer
rnd ReportCfg
rc CaseReport
cr
    IORef [CaseReport] -> ([CaseReport] -> [CaseReport]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [CaseReport]
ref (CaseReport
cr CaseReport -> [CaseReport] -> [CaseReport]
forall a. a -> [a] -> [a]
:)
  cases <- fmap reverse (readIORef ref)
  rndClose rnd rc hdr (BatteryTail cases out)
  pure cases

-- ANSI helpers -------------------------------------------------------------

ansiReset, ansiBold, ansiDim, ansiRed, ansiGreen :: String
ansiReset :: String
ansiReset  = String
"\ESC[0m"
ansiBold :: String
ansiBold   = String
"\ESC[1m"
ansiDim :: String
ansiDim    = String
"\ESC[2m"
ansiRed :: String
ansiRed    = String
"\ESC[31m"
ansiGreen :: String
ansiGreen  = String
"\ESC[32m"

withColor :: Bool -> String -> String -> String
withColor :: Bool -> String -> String -> String
withColor Bool
False String
_    String
t = String
t
withColor Bool
True  String
code String
t = String
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ansiReset

cBold, cDim, cRed, cGreen :: ReportCfg -> String -> String
cBold :: ReportCfg -> String -> String
cBold  ReportCfg
c = Bool -> String -> String -> String
withColor (ReportCfg -> Bool
rcColor ReportCfg
c) String
ansiBold
cDim :: ReportCfg -> String -> String
cDim   ReportCfg
c = Bool -> String -> String -> String
withColor (ReportCfg -> Bool
rcColor ReportCfg
c) String
ansiDim
cRed :: ReportCfg -> String -> String
cRed   ReportCfg
c = Bool -> String -> String -> String
withColor (ReportCfg -> Bool
rcColor ReportCfg
c) String
ansiRed
cGreen :: ReportCfg -> String -> String
cGreen ReportCfg
c = Bool -> String -> String -> String
withColor (ReportCfg -> Bool
rcColor ReportCfg
c) String
ansiGreen

-- pretty renderer ----------------------------------------------------------

-- | The ppad terminal aesthetic: bold brand line, a dim key column,
--   middle-dot (@·@) separators, ANSI-colored verdicts on a TTY.
pretty :: Renderer
pretty :: Renderer
pretty = Renderer
  { rndOpen :: ReportCfg -> ReportHeader -> IO ()
rndOpen  = ReportCfg -> ReportHeader -> IO ()
prettyOpen
  , rndCase :: ReportCfg -> CaseReport -> IO ()
rndCase  = ReportCfg -> CaseReport -> IO ()
prettyCase
  , rndClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
rndClose = ReportCfg -> ReportHeader -> BatteryTail -> IO ()
prettyClose
  }

prettyOpen :: ReportCfg -> ReportHeader -> IO ()
prettyOpen :: ReportCfg -> ReportHeader -> IO ()
prettyOpen ReportCfg
rc ReportHeader
hdr = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportCfg -> String -> String
cBold ReportCfg
rc (String
"ppad " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
brand)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportCfg -> String -> String
cDim ReportCfg
rc (String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
brandVersion)
  String -> IO ()
putStr (ReportCfg -> ReportHeader -> String
prettyHeaderBlock ReportCfg
rc ReportHeader
hdr)
  String -> IO ()
putStrLn String
""

prettyHeaderBlock :: ReportCfg -> ReportHeader -> String
prettyHeaderBlock :: ReportCfg -> ReportHeader -> String
prettyHeaderBlock ReportCfg
rc ReportHeader
hdr =
  let entries :: [(String, String)]
entries = String -> ReportHeader -> [(String, String)]
headerEntries String
" \183 " ReportHeader
hdr
      keyW :: Int
keyW = [(String, String)] -> Int
keyWidth [(String, String)]
entries
      row :: (String, String) -> String
row (String
k, String
v) = String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportCfg -> String -> String
cDim ReportCfg
rc (Int -> String -> String
padR Int
keyW String
k) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  in  ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
row [(String, String)]
entries

-- the header block's key/value rows, joining multi-part values with
-- the given separator.
headerEntries :: String -> ReportHeader -> [(String, String)]
headerEntries :: String -> ReportHeader -> [(String, String)]
headerEntries String
sep ReportHeader
hdr = [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [(String
"meter", String -> ReportHeader -> String
meterLine String
sep ReportHeader
hdr)]
  , [(String, String)]
-> (String -> [(String, String)])
-> Maybe String
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
t -> [(String
"target", String
t)]) (ReportHeader -> Maybe String
rhTarget ReportHeader
hdr)
  , [(String, String)]
-> (Word64 -> [(String, String)])
-> Maybe Word64
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Word64
w -> [(String
"sampler seed", Word64 -> String
seedHex Word64
w)]) (ReportHeader -> Maybe Word64
rhSeed ReportHeader
hdr)
  , [(String, String)]
-> (Env -> [(String, String)]) -> Maybe Env -> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (String -> Env -> [(String, String)]
envEntries String
sep) (ReportHeader -> Maybe Env
rhEnv ReportHeader
hdr)
  , [(String, String)]
-> (String -> [(String, String)])
-> Maybe String
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
n -> [(String
"note", String
n)]) (ReportHeader -> Maybe String
rhNote ReportHeader
hdr)
  ]

keyWidth :: [(String, String)] -> Int
keyWidth :: [(String, String)] -> Int
keyWidth [(String, String)]
entries = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((String, String) -> Int) -> [(String, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, String) -> String) -> (String, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
entries)

-- header rows for a host-environment snapshot: a system line
-- (os/kernel/arch, CPU model, cores), a knob line when any Linux
-- tuning knob resolved, the load average, and the capture time.
envEntries :: String -> Env -> [(String, String)]
envEntries :: String -> Env -> [(String, String)]
envEntries String
sep Env
e = [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [(String
"system", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
sep (Env -> [String]
systemSegs Env
e))]
  , case Env -> [String]
knobSegs Env
e of
      [] -> []
      [String]
ks -> [(String
"env", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
sep [String]
ks)]
  , [(String, String)]
-> ((Double, Double, Double) -> [(String, String)])
-> Maybe (Double, Double, Double)
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(Double
l1, Double
l5, Double
l15) ->
      [(String
"load", String -> Double -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f %.2f %.2f" Double
l1 Double
l5 Double
l15)]) (Env -> Maybe (Double, Double, Double)
envLoad Env
e)
  , [(String, String)]
-> (String -> [(String, String)])
-> Maybe String
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
t -> [(String
"time", String
t)]) (Env -> Maybe String
envTime Env
e)
  ]

systemSegs :: Env -> [String]
systemSegs :: Env -> [String]
systemSegs Env
e = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [[String] -> String
unwords ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Env -> String
envOs Env
e], [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> Maybe String
envKernel Env
e), [Env -> String
envArch Env
e] ])]
  , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> Maybe String
envCpu Env
e)
  , [Int -> String
forall a. Show a => a -> String
show (Env -> Int
envCores Env
e) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" cores"]
  ]

knobSegs :: Env -> [String]
knobSegs :: Env -> [String]
knobSegs Env
e = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
v -> [String
"governor=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v]) (Env -> Maybe String
envGovernor Env
e)
  , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> Maybe String
envBoost Env
e)  -- already key=value
  , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
v -> [String
"smt="      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v]) (Env -> Maybe String
envSmt Env
e)
  , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
v -> [String
"paranoid=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v]) (Env -> Maybe String
envParanoid Env
e)
  ]

meterLine :: String -> ReportHeader -> String
meterLine :: String -> ReportHeader -> String
meterLine String
sep ReportHeader
hdr =
  let c :: Config
c = ReportHeader -> Config
rhConfig ReportHeader
hdr
  in  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
sep ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        [ ReportHeader -> String
rhMeter ReportHeader
hdr
        , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"alpha=%.1g"       (Config -> Double
cfgAlpha Config
c) :: String
        , String
"warmup=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Config -> Int
cfgWarmup Config
c)
        , String
"budget=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Config -> Int
cfgBudget Config
c)
        , String
"batch="  String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportHeader -> String
batchText ReportHeader
hdr
        ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Config -> [String]
marginSeg Config
c

-- the relative interval-null margin, when the run tests one. The
-- resolved absolute margin is per-case ('resMargin') and appears
-- on each case's metadata line.
marginSeg :: Config -> [String]
marginSeg :: Config -> [String]
marginSeg Config
c =
  [String] -> (Double -> [String]) -> Maybe Double -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Double
m -> [String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"margin=%.1g" Double
m]) (Config -> Maybe Double
cfgMargin Config
c)

batchText :: ReportHeader -> String
batchText :: ReportHeader -> String
batchText ReportHeader
hdr
  | ReportHeader -> Bool
rhPerCaseBatch ReportHeader
hdr = String
"per-case"
  | Bool
otherwise          = Int -> String
forall a. Show a => a -> String
show (Config -> Int
cfgBatch (ReportHeader -> Config
rhConfig ReportHeader
hdr))

-- Row layout: verdict + pairs + driver in fixed-width columns on the
-- left, evidence in the middle, case name after a dim separator on
-- the right. Case-name column being last (unbounded) means the
-- numeric columns align across arbitrarily long names.
prettyCase :: ReportCfg -> CaseReport -> IO ()
prettyCase :: ReportCfg -> CaseReport -> IO ()
prettyCase ReportCfg
rc CaseReport
cr = do
  let r :: Result
r       = CaseReport -> Result
crResult CaseReport
cr
      verdict :: String
verdict = case Result
r of
        Reject{} -> ReportCfg -> String -> String
cRed   ReportCfg
rc String
"REJECT"
        Pass{}   -> ReportCfg -> String -> String
cGreen ReportCfg
rc String
"PASS  "
      pairs :: String
pairs   = Int -> String -> String
padL Int
8 (Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs Result
r))
      driver :: String
driver  = Int -> String -> String
padR Int
6 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case Result
r of
        Reject{} -> LeakShape -> String
shapeName (Result -> LeakShape
leakShape Result
r)
        Pass{}   -> String
""
      evid :: String
evid    = String -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf String
"peakLogW=%5.2f  p=%.2g"
                  (Result -> Double
resPeakLogW Result
r) (Result -> Double
resPValue Result
r) :: String
      sep :: String
sep     = ReportCfg -> String -> String
cDim ReportCfg
rc String
"\183"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
verdict
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportCfg -> String -> String
cDim ReportCfg
rc String
pairs
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
driver
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
evid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sep
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CaseReport -> String
crName CaseReport
cr
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
l -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
detailIndent Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportCfg -> String -> String
cDim ReportCfg
rc String
l)
    (String -> CaseReport -> [String]
detailLines String
"  " CaseReport
cr)

-- the lines under a case row: on 'Reject' the effect interval and
-- clipping (joined by the given gap), then the run metadata, then
-- the controls when they ran.
detailLines :: String -> CaseReport -> [String]
detailLines :: String -> CaseReport -> [String]
detailLines String
gap CaseReport
cr = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ case Result
r of
      Reject{} ->
        let (Double
elo, Double
ehi) = Result -> (Double, Double)
resEffect Result
r
        in  [String -> Double -> Double -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"effect=[%.1f,%.1f]%s%s" Double
elo Double
ehi String
gap (Result -> String
clipText Result
r)]
      Pass{} -> []
  , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CaseReport -> Maybe String
calibText CaseReport
cr)
  , [String]
-> (Attribution -> [String]) -> Maybe Attribution -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String])
-> (Attribution -> String) -> Attribution -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribution -> String
attributionText) (CaseReport -> Maybe Attribution
crAttribution CaseReport
cr)
  , (ChannelReport -> [String]) -> [ChannelReport] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ChannelReport -> [String]
channelLines (CaseReport -> [ChannelReport]
crChannels CaseReport
cr)
  ]
  where
    r :: Result
r = CaseReport -> Result
crResult CaseReport
cr

-- a reported-beside channel's lines: its verdict, evidence, and
-- effect interval in its own unit, the driver on a rejection, and
-- its controls when they ran.
channelLines :: ChannelReport -> [String]
channelLines :: ChannelReport -> [String]
channelLines ChannelReport
ch =
  String
-> String
-> String
-> Double
-> Double
-> Double
-> Double
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%s %s peakLogW=%.2f p=%.2g effect=[%.1f,%.1f] %s%s"
    (ChannelReport -> String
chName ChannelReport
ch) (Result -> String
verdictName Result
r) (Result -> Double
resPeakLogW Result
r) (Result -> Double
resPValue Result
r)
    Double
elo Double
ehi (ChannelReport -> String
chUnit ChannelReport
ch) String
drv
  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
-> (Attribution -> [String]) -> Maybe Attribution -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String])
-> (Attribution -> String) -> Attribution -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ChannelReport -> String
chName ChannelReport
ch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (Attribution -> String) -> Attribution -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribution -> String
attributionText)
      (ChannelReport -> Maybe Attribution
chAttribution ChannelReport
ch)
  where
    r :: Result
r = ChannelReport -> Result
chResult ChannelReport
ch
    (Double
elo, Double
ehi) = Result -> (Double, Double)
resEffect Result
r
    drv :: String
drv = case Result
r of
      Reject{} -> String
" driver=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LeakShape -> String
shapeName (Result -> LeakShape
leakShape Result
r)
      Pass{}   -> String
""

-- the run-metadata line under a case row: resolved batch, the
-- meter's noise floor at that batch when recorded, the target's
-- baseline cost when probed, and the order seed the run resolved
-- to. The seed is unconditional -- it is what replays the case,
-- and a reader should not have to reach for the JSON to find it.
calibText :: CaseReport -> Maybe String
calibText :: CaseReport -> Maybe String
calibText CaseReport
cr = case [String]
segs of
  [] -> Maybe String
forall a. Maybe a
Nothing
  [String]
xs -> String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
unwords [String]
xs)
  where
    segs :: [String]
segs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [String] -> (Int -> [String]) -> Maybe Int -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Int
b -> [String
"batch=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b]) (CaseReport -> Maybe Int
crBatch CaseReport
cr)
      , [String] -> (Noise -> [String]) -> Maybe Noise -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Noise
n -> [ String -> Word64 -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"noise med=%d iqr=%d"
                            (Noise -> Word64
nsMedian Noise
n) (Noise -> Word64
nsIqr Noise
n) ])
          (CaseReport -> Maybe Noise
crNoise CaseReport
cr)
      , [String] -> (Noise -> [String]) -> Maybe Noise -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Noise
n -> [ String -> Word64 -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"baseline med=%d iqr=%d"
                            (Noise -> Word64
nsMedian Noise
n) (Noise -> Word64
nsIqr Noise
n) ])
          (CaseReport -> Maybe Noise
crBaseline CaseReport
cr)
      , [String] -> (Double -> [String]) -> Maybe Double -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Double
m -> [ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"margin=%.1f" Double
m ])
          (Result -> Maybe Double
resMargin (CaseReport -> Result
crResult CaseReport
cr))
      , [String
"orderSeed=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
seedHex (Result -> Word64
resSeed (CaseReport -> Result
crResult CaseReport
cr))]
      ]

-- Indent under the evidence column: 4 (row indent) + 6 (verdict)
-- + 2 + 8 (pairs) + 2 + 6 (driver) + 2 = 30.
detailIndent :: Int
detailIndent :: Int
detailIndent = Int
30

prettyClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
prettyClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
prettyClose ReportCfg
rc ReportHeader
hdr BatteryTail
tl = do
  let cs :: [CaseReport]
cs   = BatteryTail -> [CaseReport]
btCases BatteryTail
tl
      (Int
nrej, Int
npas, Int
pairs) = [CaseReport] -> (Int, Int, Int)
tally [CaseReport]
cs
      parts :: [String]
parts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ (ReportCfg -> String -> String)
-> ReportCfg -> Int -> String -> String
colorCount ReportCfg -> String -> String
cRed   ReportCfg
rc Int
nrej String
" reject"
          , (ReportCfg -> String -> String)
-> ReportCfg -> Int -> String -> String
colorCount ReportCfg -> String -> String
cGreen ReportCfg
rc Int
npas String
" pass"
          , Int -> String
forall a. Show a => a -> String
show Int
pairs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" pairs" ]
        , ReportHeader -> [CaseReport] -> [String]
familySeg ReportHeader
hdr [CaseReport]
cs
        , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
p -> [String
"wrote " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p]) (BatteryTail -> Maybe String
btOutput BatteryTail
tl)
        ]
  String -> IO ()
putStrLn String
""
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ReportCfg -> String -> String
cDim ReportCfg
rc (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" \183 " [String]
parts)

-- Family-wise alpha, shown only for multi-case batteries (for a
-- single case it is just alpha, and saying so adds noise).
familySeg :: ReportHeader -> [CaseReport] -> [String]
familySeg :: ReportHeader -> [CaseReport] -> [String]
familySeg ReportHeader
hdr [CaseReport]
cs
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1    = []
  | Bool
otherwise = [String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"family alpha<=%.1g" (Double -> Int -> Double
familyAlpha Double
alpha Int
n)]
  where
    n :: Int
n     = [CaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CaseReport]
cs
    alpha :: Double
alpha = Config -> Double
cfgAlpha (ReportHeader -> Config
rhConfig ReportHeader
hdr)

colorCount
  :: (ReportCfg -> String -> String) -> ReportCfg -> Int -> String -> String
colorCount :: (ReportCfg -> String -> String)
-> ReportCfg -> Int -> String -> String
colorCount ReportCfg -> String -> String
col ReportCfg
rc Int
n String
suf
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     = ReportCfg -> String -> String
col ReportCfg
rc (Int -> String
forall a. Show a => a -> String
show Int
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf
  | Bool
otherwise = Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf

-- json renderer ------------------------------------------------------------

-- | Emit one @censor\/report-v3@ JSON object per battery,
--   deterministic key order. Header and per-case callbacks are
--   no-ops; the whole object materialises at close, exactly as
--   'reportJSON' would render it.
json :: Renderer
json :: Renderer
json = Renderer
  { rndOpen :: ReportCfg -> ReportHeader -> IO ()
rndOpen  = \ReportCfg
_ ReportHeader
_   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , rndCase :: ReportCfg -> CaseReport -> IO ()
rndCase  = \ReportCfg
_ CaseReport
_   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , rndClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
rndClose = ReportCfg -> ReportHeader -> BatteryTail -> IO ()
jsonClose
  }

jsonClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
jsonClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
jsonClose ReportCfg
_ ReportHeader
hdr BatteryTail
tl = String -> IO ()
putStrLn (ReportHeader -> [CaseReport] -> String
reportJSON ReportHeader
hdr (BatteryTail -> [CaseReport]
btCases BatteryTail
tl))

-- | Serialise a header + case list as the canonical
--   @censor\/report-v3@ JSON object. Deterministic key order; the
--   per-case block carries 'crBatch' and 'crTrace' as optional
--   fields, present exactly when the runner recorded them.
--
--   The two seeds are named apart: @samplerSeed@ at the top level
--   is the harness-wide seed behind the input samplers, and
--   @orderSeed@ inside each case result is the resolved per-run
--   A\/B order seed that replays that case.
--
--   A split run's case carries a @channels@ array: the period and
--   wall channels read on its own pairs, each with its name, unit,
--   result, and controls on a rejection. The case's @result@ is the
--   cycles channel, which carries the verdict.
--
--   The 'json' renderer and 'runTraceSuite' both call this so
--   stdout output and the on-disk artefact are byte-identical.
reportJSON :: ReportHeader -> [CaseReport] -> String
reportJSON :: ReportHeader -> [CaseReport] -> String
reportJSON ReportHeader
hdr [CaseReport]
cases = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"{\"schema\":\"censor/report-v3\""
  , String
",\"tool\":",    String -> String
jstr String
brand
  , String
",\"version\":", String -> String
jstr String
brandVersion
  , String
",\"meter\":",   String -> String
jstr (ReportHeader -> String
rhMeter ReportHeader
hdr)
  , String
",\"config\":",  ReportHeader -> String
configJSON ReportHeader
hdr
  , String -> (Env -> String) -> Maybe Env -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Env
e -> String
",\"env\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Env -> String
envJSON Env
e) (ReportHeader -> Maybe Env
rhEnv ReportHeader
hdr)
  , String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Word64
w -> String
",\"samplerSeed\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr (Word64 -> String
seedHex Word64
w))
      (ReportHeader -> Maybe Word64
rhSeed ReportHeader
hdr)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
t -> String
",\"target\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
t)           (ReportHeader -> Maybe String
rhTarget ReportHeader
hdr)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
n -> String
",\"note\":"   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
n)           (ReportHeader -> Maybe String
rhNote ReportHeader
hdr)
  , String
",\"cases\":["
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((CaseReport -> String) -> [CaseReport] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CaseReport -> String
caseJSON [CaseReport]
cases)
  , String
"]"
  , String
",\"totals\":", Double -> [CaseReport] -> String
totalsJSON (Config -> Double
cfgAlpha (ReportHeader -> Config
rhConfig ReportHeader
hdr)) [CaseReport]
cases
  , String
"}"
  ]

configJSON :: ReportHeader -> String
configJSON :: ReportHeader -> String
configJSON ReportHeader
hdr =
  let c :: Config
c = ReportHeader -> Config
rhConfig ReportHeader
hdr
      batchField :: String
batchField
        | ReportHeader -> Bool
rhPerCaseBatch ReportHeader
hdr = String
",\"batch\":\"per-case\""
        | Bool
otherwise          = String
",\"batch\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Config -> Int
cfgBatch Config
c)
  in  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"{\"alpha\":",  Double -> String
showF (Config -> Double
cfgAlpha Config
c)
        , String
",\"budget\":", Int -> String
forall a. Show a => a -> String
show (Config -> Int
cfgBudget Config
c)
        , String
",\"warmup\":", Int -> String
forall a. Show a => a -> String
show (Config -> Int
cfgWarmup Config
c)
        , String
batchField
        -- the *relative* margin; each case result carries the
        -- absolute value it resolved to.
        , String -> (Double -> String) -> Maybe Double -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Double
m -> String
",\"margin\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
showF Double
m) (Config -> Maybe Double
cfgMargin Config
c)
        -- the *requested* order seed; absent when the runner left
        -- it to per-run OS entropy. Each case result carries the
        -- value it actually resolved to.
        , String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Word64
w -> String
",\"orderSeed\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr (Word64 -> String
seedHex Word64
w))
            (Config -> Maybe Word64
cfgSeed Config
c)
        , String
"}"
        ]

-- optional keys are omitted (rather than emitted null) when the
-- corresponding Env field did not resolve on the host.
envJSON :: Env -> String
envJSON :: Env -> String
envJSON Env
e = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"{\"os\":",    String -> String
jstr (Env -> String
envOs Env
e)
  , String
",\"arch\":",  String -> String
jstr (Env -> String
envArch Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"kernel\":"   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envKernel Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"cpu\":"      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envCpu Env
e)
  , String
",\"cores\":", Int -> String
forall a. Show a => a -> String
show (Env -> Int
envCores Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"governor\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envGovernor Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"boost\":"    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envBoost Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"smt\":"      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envSmt Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"paranoid\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envParanoid Env
e)
  , String
-> ((Double, Double, Double) -> String)
-> Maybe (Double, Double, Double)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\(Double
l1, Double
l5, Double
l15) -> String
",\"load\":["
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Double -> String) -> [Double] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Double -> String
showF [Double
l1, Double
l5, Double
l15]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")
      (Env -> Maybe (Double, Double, Double)
envLoad Env
e)
  , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
v -> String
",\"time\":"     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
jstr String
v) (Env -> Maybe String
envTime Env
e)
  , String
"}"
  ]

caseJSON :: CaseReport -> String
caseJSON :: CaseReport -> String
caseJSON CaseReport
cr = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"{\"name\":",   String -> String
jstr (CaseReport -> String
crName CaseReport
cr)
  , String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Int
b -> String
",\"batch\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b) (CaseReport -> Maybe Int
crBatch CaseReport
cr)
  , String -> (Noise -> String) -> Maybe Noise -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Noise
n -> String
",\"noise\":{\"med\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Noise -> Word64
nsMedian Noise
n)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",\"iqr\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Noise -> Word64
nsIqr Noise
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}") (CaseReport -> Maybe Noise
crNoise CaseReport
cr)
  , String -> (Noise -> String) -> Maybe Noise -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Noise
n -> String
",\"baseline\":{\"med\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Noise -> Word64
nsMedian Noise
n)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",\"iqr\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Noise -> Word64
nsIqr Noise
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}") (CaseReport -> Maybe Noise
crBaseline CaseReport
cr)
  , String
",\"result\":", Result -> String
resultToJSON (CaseReport -> Result
crResult CaseReport
cr)
  , String -> (Attribution -> String) -> Maybe Attribution -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Attribution
a -> String
",\"controls\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attribution -> String
controlsJSON Attribution
a)
      (CaseReport -> Maybe Attribution
crAttribution CaseReport
cr)
  , case CaseReport -> [ChannelReport]
crChannels CaseReport
cr of
      []  -> String
""
      [ChannelReport]
chs -> String
",\"channels\":["
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((ChannelReport -> String) -> [ChannelReport] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ChannelReport -> String
channelJSON [ChannelReport]
chs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  , String -> ([Frame] -> String) -> Maybe [Frame] -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\[Frame]
frs -> String
",\"trace\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Frame] -> String
traceArrayJSON [Frame]
frs) (CaseReport -> Maybe [Frame]
crTrace CaseReport
cr)
  , String
"}"
  ]

channelJSON :: ChannelReport -> String
channelJSON :: ChannelReport -> String
channelJSON ChannelReport
ch = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"{\"name\":",   String -> String
jstr (ChannelReport -> String
chName ChannelReport
ch)
  , String
",\"unit\":",   String -> String
jstr (ChannelReport -> String
chUnit ChannelReport
ch)
  , String
",\"result\":", Result -> String
resultToJSON (ChannelReport -> Result
chResult ChannelReport
ch)
  , String -> (Attribution -> String) -> Maybe Attribution -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Attribution
a -> String
",\"controls\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attribution -> String
controlsJSON Attribution
a)
      (ChannelReport -> Maybe Attribution
chAttribution ChannelReport
ch)
  , String
"}"
  ]

-- | Serialise a t'Result' as a stable JSON object. Includes verdict,
--   pairs, mixture peak log e-value, anytime-valid p-value, effect
--   interval, clip counts at each of the three magnitude bounds,
--   warmup bound, the resolved order seed, the CDF channel as
--   @[cut point, peak]@ pairs, per-component peaks, and the
--   'diagnose' advisories.
--
--   The seed here is the /order/ seed ('resSeed'), the one that
--   replays the A\/B order sequence. The sampler seed is a property
--   of the harness, not of a run, and appears in the report header.
--
--   The object is a single line; pipe multiple runs into a
--   line-oriented store and diff or filter with @jq@.
resultToJSON :: Result -> String
resultToJSON :: Result -> String
resultToJSON Result
r = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"{\"verdict\":",    String -> String
jstr (Result -> String
verdictName Result
r)
  , String
",\"pairs\":",      Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"peakLogW\":%.6g" (Result -> Double
resPeakLogW Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"pvalue\":%.6g"   (Result -> Double
resPValue Result
r)
  , String -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"effect\":[%.6g,%.6g]"
      ((Double, Double) -> Double
forall a b. (a, b) -> a
fst (Result -> (Double, Double)
resEffect Result
r)) ((Double, Double) -> Double
forall a b. (a, b) -> b
snd (Result -> (Double, Double)
resEffect Result
r))
  , String
",\"clipped\":",    Int -> String
forall a. Show a => a -> String
show (Result -> Int
resClipped Result
r)
  , String
",\"clipped4\":",   Int -> String
forall a. Show a => a -> String
show (Result -> Int
resClipped4 Result
r)
  , String
",\"clipped16\":",  Int -> String
forall a. Show a => a -> String
show (Result -> Int
resClipped16 Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"bound\":%.6g" (Result -> Double
resBound Result
r)
  -- the resolved absolute interval-null margin, present only on
  -- margin-mode runs (in meter units per batch, like the bound).
  , String -> (Double -> String) -> Maybe Double -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"margin\":%.6g") (Result -> Maybe Double
resMargin Result
r)
  , String
",\"orderSeed\":",  String -> String
jstr (Word64 -> String
seedHex (Result -> Word64
resSeed Result
r))
  , String
",\"cdf\":["
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
","
      [ String -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf String
"[%.6g,%.6g]" Double
q Double
p | (Double
q, Double
p) <- Result -> [(Double, Double)]
resCdf Result
r ]
  , String
"]"
  , String
",\"peaks\":{"
  ,       String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"\"sign\":%.6g"    (Result -> Double
resPeakSign Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"magn\":%.6g"         (Result -> Double
resPeakMagn Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"magn4\":%.6g"        (Result -> Double
resPeakMagn4 Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"magn16\":%.6g"       (Result -> Double
resPeakMagn16 Result
r)
  , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
",\"cdf\":%.6g"          (Result -> Double
resPeakCdf Result
r)
  , String
"}"
  , String
",\"advisories\":["
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Advisory -> String) -> [Advisory] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Advisory -> String
advisoryJSON (Result -> [Advisory]
diagnose Result
r))
  , String
"]}"
  ]

advisoryJSON :: Advisory -> String
advisoryJSON :: Advisory -> String
advisoryJSON Advisory
a = case Advisory
a of
  HighClipRate ClipRates
cr -> String -> Double -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf
    (String
"{\"kind\":\"HighClipRate\",\"clipFraction\":%.4g"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",\"clipFraction4\":%.4g,\"clipFraction16\":%.4g}")
    (ClipRates -> Double
clipTight ClipRates
cr) (ClipRates -> Double
clipWide ClipRates
cr) (ClipRates -> Double
clipWidest ClipRates
cr)
  LowPower Double
h -> String -> Double -> String
forall r. PrintfType r => String -> r
printf
    String
"{\"kind\":\"LowPower\",\"widthOverBound\":%.4g}" Double
h
  RejectionDriver LeakShape
s -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"{\"kind\":\"RejectionDriver\",\"shape\":"
    , String -> String
jstr (LeakShape -> String
shapeName LeakShape
s), String
"}"
    ]

traceArrayJSON :: [Frame] -> String
traceArrayJSON :: [Frame] -> String
traceArrayJSON [Frame]
frs =
  String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Frame -> String) -> [Frame] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Frame -> String
forall {t}. PrintfType t => Frame -> t
frameJSON ([Frame] -> [Frame]
thin [Frame]
frs)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  where
    frameJSON :: Frame -> t
frameJSON Frame
fr = String -> Int -> Double -> Double -> Double -> Double -> t
forall r. PrintfType r => String -> r
printf String
"[%d,%.4f,%.4f,%.1f,%.1f]"
      (Frame -> Int
frPair Frame
fr) (Frame -> Double
frLogW Frame
fr) (Frame -> Double
frLogWSup Frame
fr) (Frame -> Double
frLo Frame
fr) (Frame -> Double
frHi Frame
fr)

totalsJSON :: Double -> [CaseReport] -> String
totalsJSON :: Double -> [CaseReport] -> String
totalsJSON Double
alpha [CaseReport]
cs =
  let n :: Int
n            = [CaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CaseReport]
cs
      (Int
nr, Int
np, Int
pr) = [CaseReport] -> (Int, Int, Int)
tally [CaseReport]
cs
  in  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"{\"cases\":",  Int -> String
forall a. Show a => a -> String
show Int
n
        , String
",\"reject\":", Int -> String
forall a. Show a => a -> String
show Int
nr
        , String
",\"pass\":",   Int -> String
forall a. Show a => a -> String
show Int
np
        , String
",\"pairs\":",  Int -> String
forall a. Show a => a -> String
show Int
pr
        , String
",\"alpha\":",  Double -> String
showF Double
alpha
        , String
",\"familyAlpha\":", Double -> String
showF (Double -> Int -> Double
familyAlpha Double
alpha Int
n)
        , String
"}"
        ]

-- Censor's type-I guarantee is per run. A battery that calls
-- failure when /any/ of its M cells rejects has a family-wise false
-- alarm probability bounded by M * alpha (union bound), not alpha.
-- Reported so a reader does not have to reconstruct it; to actually
-- test at alpha family-wise, run each cell at alpha / M.
familyAlpha :: Double -> Int -> Double
familyAlpha :: Double -> Int -> Double
familyAlpha !Double
alpha !Int
n = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1 (Double
alpha Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n))

-- The controls block: the combined verdict plus both control runs
-- in full. Serialising the runs (rather than reducing them to a
-- label) is deliberate — 'ControlsPass' is an absence of evidence,
-- and a reader should be able to see how much evidence was
-- actually gathered before accepting it.
controlsJSON :: Attribution -> String
controlsJSON :: Attribution -> String
controlsJSON Attribution
a = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"{\"verdict\":", String -> String
jstr (ControlVerdict -> String
controlLabel (Attribution -> ControlVerdict
attVerdict Attribution
a))
  , String
",\"aa\":",      Result -> String
resultToJSON (Attribution -> Result
attAA Attribution
a)
  , String
",\"bb\":",      Result -> String
resultToJSON (Attribution -> Result
attBB Attribution
a)
  , String
"}"
  ]

controlLabel :: ControlVerdict -> String
controlLabel :: ControlVerdict -> String
controlLabel ControlVerdict
v = case ControlVerdict
v of
  ControlVerdict
ControlsPass       -> String
"controls pass"
  ControlVerdict
SampleAAsymmetry   -> String
"sampleA asymmetry"
  ControlVerdict
SampleBAsymmetry   -> String
"sampleB asymmetry"
  ControlVerdict
PervasiveAsymmetry -> String
"pervasive asymmetry"

-- plain renderer -----------------------------------------------------------

-- | ASCII-only, no ANSI, no unicode. Suitable for CI logs and grep
--   pipelines that dislike middle dots.
plain :: Renderer
plain :: Renderer
plain = Renderer
  { rndOpen :: ReportCfg -> ReportHeader -> IO ()
rndOpen  = ReportCfg -> ReportHeader -> IO ()
plainOpen
  , rndCase :: ReportCfg -> CaseReport -> IO ()
rndCase  = ReportCfg -> CaseReport -> IO ()
plainCase
  , rndClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
rndClose = ReportCfg -> ReportHeader -> BatteryTail -> IO ()
plainClose
  }

plainOpen :: ReportCfg -> ReportHeader -> IO ()
plainOpen :: ReportCfg -> ReportHeader -> IO ()
plainOpen ReportCfg
_ ReportHeader
hdr = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ppad " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
brand String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
brandVersion
  let entries :: [(String, String)]
entries = String -> ReportHeader -> [(String, String)]
headerEntries String
", " ReportHeader
hdr
      keyW :: Int
keyW = [(String, String)] -> Int
keyWidth [(String, String)]
entries
  ((String, String) -> IO ()) -> [(String, String)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(String
k, String
v) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
padR Int
keyW String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v) [(String, String)]
entries
  String -> IO ()
putStrLn String
""

plainCase :: ReportCfg -> CaseReport -> IO ()
plainCase :: ReportCfg -> CaseReport -> IO ()
plainCase ReportCfg
_ CaseReport
cr = do
  let r :: Result
r  = CaseReport -> Result
crResult CaseReport
cr
      hd :: String
hd = String -> String -> String -> Int -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%s %s pairs=%d peakLogW=%.2f p=%.2g"
             (Result -> String
verdictName Result
r) (CaseReport -> String
crName CaseReport
cr) (Result -> Int
resPairs Result
r)
             (Result -> Double
resPeakLogW Result
r) (Result -> Double
resPValue Result
r) :: String
      drv :: String
drv = case Result
r of
        Reject{} -> String
" driver=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LeakShape -> String
shapeName (Result -> LeakShape
leakShape Result
r)
        Pass{}   -> String
""
  String -> IO ()
putStrLn (String
hd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
drv)
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) (String -> CaseReport -> [String]
detailLines String
" " CaseReport
cr)

plainClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
plainClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO ()
plainClose ReportCfg
_ ReportHeader
hdr BatteryTail
tl = do
  let cs :: [CaseReport]
cs = BatteryTail -> [CaseReport]
btCases BatteryTail
tl
      (Int
nr, Int
np, Int
pr) = [CaseReport] -> (Int, Int, Int)
tally [CaseReport]
cs
      fam :: String
fam = case ReportHeader -> [CaseReport] -> [String]
familySeg ReportHeader
hdr [CaseReport]
cs of
        (String
s:[String]
_) -> String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        []    -> String
""
      wrote :: String
wrote = case BatteryTail -> Maybe String
btOutput BatteryTail
tl of
        Just String
p  -> String
" wrote=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p
        Maybe String
Nothing -> String
""
  String -> IO ()
putStrLn String
""
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"summary: reject=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nr
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" pass=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
np
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" pairs=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pr
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fam
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wrote

-- shared helpers -----------------------------------------------------------

-- (rejects, passes, pairs consumed) across a battery.
tally :: [CaseReport] -> (Int, Int, Int)
tally :: [CaseReport] -> (Int, Int, Int)
tally [CaseReport]
cs =
  let nr :: Int
nr = [CaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((CaseReport -> Bool) -> [CaseReport] -> [CaseReport]
forall a. (a -> Bool) -> [a] -> [a]
filter (Result -> Bool
isReject (Result -> Bool) -> (CaseReport -> Result) -> CaseReport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseReport -> Result
crResult) [CaseReport]
cs)
  in  (Int
nr, [CaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CaseReport]
cs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nr, [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((CaseReport -> Int) -> [CaseReport] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Result -> Int
resPairs (Result -> Int) -> (CaseReport -> Result) -> CaseReport -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseReport -> Result
crResult) [CaseReport]
cs))

isReject :: Result -> Bool
isReject :: Result -> Bool
isReject Reject{} = Bool
True
isReject Pass{}   = Bool
False

attributionText :: Attribution -> String
attributionText :: Attribution -> String
attributionText Attribution
a = case Attribution -> ControlVerdict
attVerdict Attribution
a of
  ControlVerdict
ControlsPass ->
    String
"controls: pass (A/A " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs (Attribution -> Result
attAA Attribution
a))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", B/B " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs (Attribution -> Result
attBB Attribution
a))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" pairs; consistent with a target leak, not proof of one)"
  ControlVerdict
SampleAAsymmetry ->
    String
"controls: sampleA asymmetry (A/A rejected at "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs (Attribution -> Result
attAA Attribution
a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  ControlVerdict
SampleBAsymmetry ->
    String
"controls: sampleB asymmetry (B/B rejected at "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs (Attribution -> Result
attBB Attribution
a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  ControlVerdict
PervasiveAsymmetry ->
    String
"controls: pervasive harness asymmetry (A/A at "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs (Attribution -> Result
attAA Attribution
a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", B/B at "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Result -> Int
resPairs (Attribution -> Result
attBB Attribution
a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

seedHex :: Word64 -> String
seedHex :: Word64 -> String
seedHex Word64
w = String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
w String
""

showF :: Double -> String
showF :: Double -> String
showF = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.6g"

jstr :: String -> String
jstr :: String -> String
jstr String
s = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
esc String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
  where
    esc :: Char -> String
esc Char
'"'  = String
"\\\""
    esc Char
'\\' = String
"\\\\"
    esc Char
'\n' = String
"\\n"
    esc Char
'\r' = String
"\\r"
    esc Char
'\t' = String
"\\t"
    esc Char
c    = [Char
c]

padR, padL :: Int -> String -> String
padR :: Int -> String -> String
padR Int
n String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)) Char
' '
padL :: Int -> String -> String
padL Int
n String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

-- shared suite arg surface -------------------------------------------------

-- | The parsed suite argv:
--   @[--format FMT] [--batch N] [--margin M] [METER] [EXTRA...]@.
--   'runTraceSuite' takes the first extra as an output path.
data SuiteArgs = SuiteArgs
  { SuiteArgs -> Renderer
saRenderer :: !Renderer
    -- ^ resolved from @--format@; defaults to 'pretty'.
  , SuiteArgs -> Maybe String
saMeter    :: !(Maybe String)
    -- ^ meter name (@wall@, @instructions@, ...); 'Nothing' means
    --   accept the runner's default.
  , SuiteArgs -> Maybe Int
saBatch    :: !(Maybe Int)
    -- ^ fixed batch from @--batch@, overriding every case's
    --   'BatchPolicy'; 'Nothing' leaves each case's own.
  , SuiteArgs -> Maybe Double
saMargin   :: !(Maybe Double)
    -- ^ relative interval-null margin from @--margin@ (see
    --   'Censor.cfgMargin'); 'Nothing' tests the sharp null
    --   (mirrors the dlopen CLI's flag).
  , SuiteArgs -> [String]
saExtra    :: ![String]
    -- ^ positional arguments left after meter, in order.
  }

-- | Parse the standard suite argv from 'Env.getArgs'. Dies with a
--   clear message if @--format@ or @--batch@ is malformed. The
--   extras list is handed to the runner for further interpretation.
parseSuiteArgs :: IO SuiteArgs
parseSuiteArgs :: IO SuiteArgs
parseSuiteArgs = do
  raw <- IO [String]
Env.getArgs
  let (farg, rest0) = takeFormatArg raw
      (barg, rest1) = takeFlagArg "--batch" rest0
      (garg, rest)  = takeFlagArg "--margin" rest1
  rnd <- resolveFormat farg
  bat <- case barg of
    Maybe String
Nothing -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
    Just String
s  -> case ReadS Int
forall a. Read a => ReadS a
reads String
s of
      [(Int
n, String
"")] | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
      [(Int, String)]
_ -> String -> IO (Maybe Int)
forall a. String -> IO a
die (String -> IO (Maybe Int)) -> String -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ String
"unknown --batch " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (expected a positive integer)"
  mgn <- case garg of
    Maybe String
Nothing -> Maybe Double -> IO (Maybe Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Double
forall a. Maybe a
Nothing
    Just String
s  -> case ReadS Double
forall a. Read a => ReadS a
reads String
s of
      [(Double
m, String
"")] | Double
m Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> (Double
0 :: Double) -> Maybe Double -> IO (Maybe Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
m)
      [(Double, String)]
_ -> String -> IO (Maybe Double)
forall a. String -> IO a
die (String -> IO (Maybe Double)) -> String -> IO (Maybe Double)
forall a b. (a -> b) -> a -> b
$ String
"unknown --margin " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (expected a positive number)"
  let (marg, extra) = case rest of
        []       -> (Maybe String
forall a. Maybe a
Nothing, [])
        (String
m:[String]
more) -> (String -> Maybe String
forall a. a -> Maybe a
Just String
m,  [String]
more)
  pure SuiteArgs
    { saRenderer = rnd
    , saMeter    = marg
    , saBatch    = bat
    , saMargin   = mgn
    , saExtra    = extra
    }

-- trace-recording suite scaffold -------------------------------------------

-- | How a case's 'cfgBatch' is chosen. The distinction is a
--   /repeatability contract/ the case author asserts about the
--   target, and it cannot be inferred: batching only multiplies
--   real work when each repetition genuinely recomputes.
data BatchPolicy
  = SingleShot
    -- ^ One execution per timed region. The correct policy for a
    --   pure Haskell target such as @\\a -> () <$ evaluate (f a)@:
    --   the @f a@ thunk is shared across the batch and forced once,
    --   so repetitions beyond the first are no-ops on an
    --   already-evaluated value and a calibrated batch of @N@ would
    --   describe one call plus @N-1@ no-ops. If the target is
    --   sub-quantum under the meter, widen the work rather than
    --   batching.
  | RepeatableAuto
    -- ^ Each repetition genuinely recomputes, so calibrate the
    --   batch with 'calibrateBatchReport'. Appropriate for foreign
    --   (FFI) calls and targets driving mutable state — anything
    --   that cannot be memoised by a thunk.
  | FixedBatch !Int
    -- ^ Pin the batch outright, bypassing calibration. Use when
    --   batches must match across meters for comparability.
  deriving (BatchPolicy -> BatchPolicy -> Bool
(BatchPolicy -> BatchPolicy -> Bool)
-> (BatchPolicy -> BatchPolicy -> Bool) -> Eq BatchPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BatchPolicy -> BatchPolicy -> Bool
== :: BatchPolicy -> BatchPolicy -> Bool
$c/= :: BatchPolicy -> BatchPolicy -> Bool
/= :: BatchPolicy -> BatchPolicy -> Bool
Eq, Int -> BatchPolicy -> String -> String
[BatchPolicy] -> String -> String
BatchPolicy -> String
(Int -> BatchPolicy -> String -> String)
-> (BatchPolicy -> String)
-> ([BatchPolicy] -> String -> String)
-> Show BatchPolicy
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BatchPolicy -> String -> String
showsPrec :: Int -> BatchPolicy -> String -> String
$cshow :: BatchPolicy -> String
show :: BatchPolicy -> String
$cshowList :: [BatchPolicy] -> String -> String
showList :: [BatchPolicy] -> String -> String
Show)

-- | One case in a t'TraceSuite': a display name, its 'BatchPolicy',
--   and an @IO@ action producing the hypothesis. Existentially
--   quantified over the hypothesis input type so a suite can hold
--   cases with different payload shapes in one list.
--
--   > TraceCase "encrypt" SingleShot     posAeadEncrypt
--   > TraceCase "mul"     RepeatableAuto posFfiMul
--
--   The action is re-executed for the calibration probe (under
--   'RepeatableAuto'), the main run, and (on 'Reject') the negative
--   controls, so the builder should be inexpensive and side-effect
--   free.
data TraceCase =
  forall a. TraceCase !String !BatchPolicy !(IO (Hypothesis a))

-- | A trace-recording suite: iterate a list of hypotheses under a
--   chosen meter, record each run's per-pair frame trajectory, and
--   write the whole battery as a single @censor\/report-v3@ JSON
--   artefact alongside the human-facing report.
--
--   The tool's @Main.hs@ builds one of these and calls
--   'runTraceSuite'; everything else — arg parse, meter selection,
--   per-case 'calibrateBatch', 'record', auto-attribution on
--   'Reject', header assembly, @withReport@ driver, JSON write —
--   is done inside.
data TraceSuite = TraceSuite
  { TraceSuite -> String
tsTarget :: !String
    -- ^ one-line target description shown in the header block.
  , TraceSuite -> Config
tsConfig :: !Config
    -- ^ base driver config. 'runTraceSuite' calibrates 'cfgBatch'
    --   per case (or pins it from @--batch@), so the value of
    --   @cfgBatch@ here is ignored; 'cfgAlpha', 'cfgWarmup',
    --   'cfgBudget', and 'cfgSeed' are applied verbatim.
  , TraceSuite -> Maybe Word64
tsSeed   :: !(Maybe Word64)
    -- ^ user-facing sampler seed shown in the header block.
  , TraceSuite -> Maybe String
tsNote   :: !(Maybe String)
    -- ^ optional one-line note under the header block.
  , TraceSuite -> [TraceCase]
tsCases  :: ![TraceCase]
    -- ^ heterogeneous case list.
  }

-- | Drive a t'TraceSuite' end to end. The JSON artefact is written
--   to the first positional argument after the meter, defaulting to
--   @\<progName\>-\<meter\>.json@; it carries the same content the
--   'json' renderer emits to stdout under @--format json@.
--
--   A host-environment snapshot ('captureEnv') is taken at run start
--   and rides on the header. Per case: 'calibrateBatchReport' picks
--   the batch and records the meter's noise floor at it (both
--   surface on the case row and in the JSON) unless @--batch N@
--   pins the batch (no probe, no noise floor — the honest setting
--   for pure Haskell targets is @--batch 1@), 'baselineReading'
--   records the target's baseline cost on fresh class-A draws at
--   the resolved batch (every policy — fresh draws are genuine work
--   even for pure targets), 'record' streams the run and keeps its
--   frames, and on 'Reject' 'attribute' runs the A\/A + B\/B
--   diagnostics automatically (two extra runs).
--
--   The meter @cycles+wall@ ('splitMeterName') runs each case under
--   the split meter ('Censor.runSplitWith'): the case's result is
--   the cycles channel, and the period and wall channels of the same
--   pairs are reported beside it ('crChannels'). Calibration and the
--   baseline read cycles, and the controls run when any channel
--   rejects.
runTraceSuite :: TraceSuite -> IO ()
runTraceSuite :: TraceSuite -> IO ()
runTraceSuite TraceSuite
ts = do
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  prog <- IO String
Env.getProgName
  sa   <- parseSuiteArgs
  rc   <- initReportCfg
  case tsCases ts of
    [] -> String -> IO ()
forall a. String -> IO a
die (String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": no cases configured")
    [TraceCase]
_  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let out = case SuiteArgs -> [String]
saExtra SuiteArgs
sa of
        (String
o:[String]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
o
        [String]
_     -> Maybe String
forall a. Maybe a
Nothing
      suite String
mname Config -> Maybe Int -> TraceCase -> IO CaseReport
runCase = do
        env <- IO Env
captureEnv
        let cfgBase = (TraceSuite -> Config
tsConfig TraceSuite
ts)
              { cfgMargin =
                  maybe (cfgMargin (tsConfig ts)) Just (saMargin sa) }
            hdr = ReportHeader
              { rhMeter :: String
rhMeter     = String
mname
              , rhConfig :: Config
rhConfig    = Config
cfgBase
                  { cfgBatch = fromMaybe (cfgBatch cfgBase) (saBatch sa) }
              , rhSeed :: Maybe Word64
rhSeed      = TraceSuite -> Maybe Word64
tsSeed TraceSuite
ts
              , rhTarget :: Maybe String
rhTarget    = String -> Maybe String
forall a. a -> Maybe a
Just (TraceSuite -> String
tsTarget TraceSuite
ts)
              , rhNote :: Maybe String
rhNote      = TraceSuite -> Maybe String
tsNote TraceSuite
ts
              , rhEnv :: Maybe Env
rhEnv       = Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env
              , rhPerCaseBatch :: Bool
rhPerCaseBatch = Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False) (SuiteArgs -> Maybe Int
saBatch SuiteArgs
sa)
              }
            path = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".json") Maybe String
out
        ref <- newIORef ([] :: [CaseReport])
        _ <- withReport rc (saRenderer sa) hdr $ \CaseReport -> IO ()
emit -> do
          [TraceCase] -> (TraceCase -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TraceSuite -> [TraceCase]
tsCases TraceSuite
ts) ((TraceCase -> IO ()) -> IO ()) -> (TraceCase -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TraceCase
tc -> do
            cr <- Config -> Maybe Int -> TraceCase -> IO CaseReport
runCase Config
cfgBase (SuiteArgs -> Maybe Int
saBatch SuiteArgs
sa) TraceCase
tc
            modifyIORef' ref (cr :)
            emit cr
          cases <- ([CaseReport] -> [CaseReport])
-> IO [CaseReport] -> IO [CaseReport]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [CaseReport] -> [CaseReport]
forall a. [a] -> [a]
reverse (IORef [CaseReport] -> IO [CaseReport]
forall a. IORef a -> IO a
readIORef IORef [CaseReport]
ref)
          writeFile path (reportJSON hdr cases)
          pure (Just path)
        pure ()
  case saMeter sa of
    Just String
m | String
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
splitMeterName ->
      (SplitMeter -> IO ()) -> IO ()
forall a. (SplitMeter -> IO a) -> IO a
withSplitMeterArg (String
-> (Config -> Maybe Int -> TraceCase -> IO CaseReport) -> IO ()
suite String
splitMeterName ((Config -> Maybe Int -> TraceCase -> IO CaseReport) -> IO ())
-> (SplitMeter
    -> Config -> Maybe Int -> TraceCase -> IO CaseReport)
-> SplitMeter
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitMeter -> Config -> Maybe Int -> TraceCase -> IO CaseReport
splitCase)
    Maybe String
marg -> Maybe String -> (String -> Meter -> IO ()) -> IO ()
forall a. Maybe String -> (String -> Meter -> IO a) -> IO a
withMeterArg Maybe String
marg ((String -> Meter -> IO ()) -> IO ())
-> (String -> Meter -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
mname Meter
meter ->
      String
-> (Config -> Maybe Int -> TraceCase -> IO CaseReport) -> IO ()
suite String
mname (String
-> Meter -> Config -> Maybe Int -> TraceCase -> IO CaseReport
meterCase String
mname Meter
meter)

-- One case under a single meter: the batch, the baseline, the
-- recorded run, and the controls on a rejection.
meterCase :: String -> Meter -> Config -> Maybe Int -> TraceCase
          -> IO CaseReport
meterCase :: String
-> Meter -> Config -> Maybe Int -> TraceCase -> IO CaseReport
meterCase String
mname Meter
meter Config
cfgBase Maybe Int
mbatch (TraceCase String
name BatchPolicy
policy IO (Hypothesis a)
mkH) = do
  (b, mnoise) <- Meter
-> Maybe Int
-> BatchPolicy
-> IO (Hypothesis a)
-> IO (Int, Maybe Noise)
forall a.
Meter
-> Maybe Int
-> BatchPolicy
-> IO (Hypothesis a)
-> IO (Int, Maybe Noise)
caseBatch Meter
meter Maybe Int
mbatch BatchPolicy
policy IO (Hypothesis a)
mkH
  let c = Config
cfgBase { cfgBatch = b }
  hBase <- mkH
  base  <- baselineReading meter c hBase
  h <- mkH
  t <- record name mname meter c h
  let r = Trace -> Result
traceResult Trace
t
  mat <- case r of
    Reject{} -> do
      hAtt <- IO (Hypothesis a)
mkH
      Just <$> attribute meter c hAtt
    Pass{}   -> Maybe Attribution -> IO (Maybe Attribution)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attribution
forall a. Maybe a
Nothing
  pure CaseReport
    { crName        = name
    , crResult      = r
    , crAttribution = mat
    , crBatch       = Just b
    , crNoise       = mnoise
    , crBaseline    = Just base
    , crTrace       = Just (traceFrames t)
    , crChannels    = []
    }

-- One case under the split meter: as 'meterCase', with the cycles
-- channel as the case's result (batch, noise, and baseline are in
-- cycles too) and the period and wall channels beside it. The
-- controls run when any channel rejects, and each rejecting channel
-- carries its own.
splitCase :: SplitMeter -> Config -> Maybe Int -> TraceCase
          -> IO CaseReport
splitCase :: SplitMeter -> Config -> Maybe Int -> TraceCase -> IO CaseReport
splitCase SplitMeter
meter Config
cfgBase Maybe Int
mbatch (TraceCase String
name BatchPolicy
policy IO (Hypothesis a)
mkH) = do
  let cyc :: Meter
cyc = (Int -> IO () -> IO Word64) -> Meter
Meter (\Int
k IO ()
act -> ((Word64, Word64) -> Word64) -> IO (Word64, Word64) -> IO Word64
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64, Word64) -> Word64
forall a b. (a, b) -> a
fst (SplitMeter -> Int -> IO () -> IO (Word64, Word64)
measureSplit SplitMeter
meter Int
k IO ()
act))
  (b, mnoise) <- Meter
-> Maybe Int
-> BatchPolicy
-> IO (Hypothesis a)
-> IO (Int, Maybe Noise)
forall a.
Meter
-> Maybe Int
-> BatchPolicy
-> IO (Hypothesis a)
-> IO (Int, Maybe Noise)
caseBatch Meter
cyc Maybe Int
mbatch BatchPolicy
policy IO (Hypothesis a)
mkH
  let c = Config
cfgBase { cfgBatch = b }
  hBase <- mkH
  base  <- baselineReading cyc c hBase
  h   <- mkH
  ref <- newIORef []
  sp  <- runSplitWith meter c h $ \ !Frame
fr -> IORef [Frame] -> ([Frame] -> [Frame]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Frame]
ref (Frame
fr Frame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
:)
  frs <- fmap reverse (readIORef ref)
  matt <- if any isReject [splitCycles sp, splitPeriod sp, splitWall sp]
    then do
      hAtt <- mkH
      Just <$> attributeSplit meter c hAtt
    else pure Nothing
  let ctl Result
r Maybe a
a
        | Result -> Bool
isReject Result
r = Maybe a
a
        | Bool
otherwise  = Maybe a
forall a. Maybe a
Nothing
      chan String
nm String
unit Result
r Maybe Attribution
a = String -> String -> Result -> Maybe Attribution -> ChannelReport
ChannelReport String
nm String
unit Result
r (Result -> Maybe Attribution -> Maybe Attribution
forall {a}. Result -> Maybe a -> Maybe a
ctl Result
r Maybe Attribution
a)
  pure CaseReport
    { crName        = name
    , crResult      = splitCycles sp
    , crAttribution = ctl (splitCycles sp) (fmap splitCycles matt)
    , crBatch       = Just b
    , crNoise       = mnoise
    , crBaseline    = Just base
    , crTrace       = Just frs
    , crChannels    =
        [ chan "period" "fs" (splitPeriod sp) (fmap splitPeriod matt)
        , chan "wall" "ns" (splitWall sp) (fmap splitWall matt)
        ]
    }

-- A case's batch, and the meter's noise floor at it when calibrated.
-- --batch overrides every case's policy; otherwise the case's own
-- declared policy governs, and only RepeatableAuto runs a
-- calibration probe.
--
-- Each probe gets its own instance: it runs a prologue and class-A
-- draws, and the main run should start from the same state whether
-- or not any probe happened.
caseBatch
  :: Meter -> Maybe Int -> BatchPolicy -> IO (Hypothesis a)
  -> IO (Int, Maybe Noise)
caseBatch :: forall a.
Meter
-> Maybe Int
-> BatchPolicy
-> IO (Hypothesis a)
-> IO (Int, Maybe Noise)
caseBatch Meter
meter Maybe Int
mbatch BatchPolicy
policy IO (Hypothesis a)
mkH = case BatchPolicy -> (Int -> BatchPolicy) -> Maybe Int -> BatchPolicy
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BatchPolicy
policy Int -> BatchPolicy
FixedBatch Maybe Int
mbatch of
  BatchPolicy
SingleShot     -> (Int, Maybe Noise) -> IO (Int, Maybe Noise)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Maybe Noise
forall a. Maybe a
Nothing)
  FixedBatch Int
n   -> (Int, Maybe Noise) -> IO (Int, Maybe Noise)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, Maybe Noise
forall a. Maybe a
Nothing)
  BatchPolicy
RepeatableAuto -> do
    hCal <- IO (Hypothesis a)
mkH
    cb   <- calibrateBatchReport meter hCal
    pure (C.crBatch cb, C.crNoise cb)