commit 67999374211a038876017be1b90c74742ebc555e
parent b0a7a7cf7abdbae101d2efb87bcaf13a132b7501
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 28 Jun 2026 21:17:23 -0230
reject non-finite parameters in config constructors
NaN and +/-Infinity were slipping past the existing range checks
(NaN comparisons are False, and -Inf < +Inf passes 'lo < hi'),
leaving the door open to e.g. infinite bounds that silently
zeroed the safe-bet ceilings. Tighten each smart constructor to
require finite m/lo/hi/alpha (Bounded), lo/hi/alpha (Paired),
and p0/alpha (Bernoulli) via a shared 'finite' helper in Common.
Diffstat:
5 files changed, 51 insertions(+), 15 deletions(-)
diff --git a/lib/Numeric/Eproc/Bernoulli.hs b/lib/Numeric/Eproc/Bernoulli.hs
@@ -76,6 +76,7 @@ module Numeric.Eproc.Bernoulli (
import Numeric.Eproc.Common (
Bettor(..), Verdict(..), ConfigError(..)
, BetState, init_bet, bet_lambda, step_bet
+ , finite
)
-- types ----------------------------------------------------------------------
@@ -128,9 +129,11 @@ data State = State {
-- to leave numerical margin -- the WSR safety recommendation.
--
-- Returns 'Left' with a 'ConfigError' on inputs that would leave
--- the mathematical regime: @p_0@ outside @(0, 1)@ (the degenerate
--- case @p_0 = 0@ would make @lambda_max@ infinite, and @p_0 = 1@
--- leaves no room for an alternative), or @alpha@ outside @(0, 1)@.
+-- the mathematical regime: either of @p_0@ or @alpha@ non-finite
+-- (NaN or infinite); @p_0@ outside @(0, 1)@ (the degenerate case
+-- @p_0 = 0@ would make @lambda_max@ infinite, and @p_0 = 1@
+-- leaves no room for an alternative); or @alpha@ outside
+-- @(0, 1)@.
--
-- >>> let Right cfg = config 0.05 1.0e-3 Newton
config
@@ -139,9 +142,11 @@ config
-> Bettor -- ^ bettor strategy
-> Either ConfigError Config
config !p0 !alpha !b
- | not (p0 > 0 && p0 < 1) = Left (InvalidBaselineRate p0)
- | not (alpha > 0 && alpha < 1) = Left (InvalidAlpha alpha)
- | otherwise = Right Config {
+ | not (finite p0 && p0 > 0 && p0 < 1) =
+ Left (InvalidBaselineRate p0)
+ | not (finite alpha && alpha > 0 && alpha < 1) =
+ Left (InvalidAlpha alpha)
+ | otherwise = Right Config {
cfg_bettor = b
, cfg_lam_max = 0.5 / p0
, cfg_p0 = p0
diff --git a/lib/Numeric/Eproc/Bounded.hs b/lib/Numeric/Eproc/Bounded.hs
@@ -75,6 +75,7 @@ module Numeric.Eproc.Bounded (
import Numeric.Eproc.Common (
Bettor(..), Verdict(..), ConfigError(..)
, BetState, init_bet, bet_lambda, step_bet
+ , finite
)
-- types ----------------------------------------------------------------------
@@ -149,9 +150,10 @@ data State = State {
-- adjustment for the two one-sided e-processes.
--
-- Returns 'Left' with a 'ConfigError' on inputs that would leave
--- the mathematical regime: @alpha@ outside @(0, 1)@, @lo >= hi@,
--- or @m@ outside the open interval @(lo, hi)@ (strict, to avoid
--- the safe-bet ceilings dividing by zero).
+-- the mathematical regime: any of @m@, @lo@, @hi@, @alpha@
+-- non-finite (NaN or infinite); @alpha@ outside @(0, 1)@;
+-- @lo >= hi@; or @m@ outside the open interval @(lo, hi)@
+-- (strict, to avoid the safe-bet ceilings dividing by zero).
--
-- >>> let Right cfg = config 0.5 0.0 1.0 1.0e-3 Newton
config
@@ -162,10 +164,13 @@ config
-> Bettor -- ^ bettor strategy
-> Either ConfigError Config
config !m !lo !hi !alpha !b
- | not (alpha > 0 && alpha < 1) = Left (InvalidAlpha alpha)
- | not (lo < hi) = Left (InvalidBounds lo hi)
- | not (lo < m && m < hi) = Left (InvalidNullMean m lo hi)
- | otherwise = Right Config {
+ | not (finite alpha && alpha > 0 && alpha < 1) =
+ Left (InvalidAlpha alpha)
+ | not (finite lo && finite hi && lo < hi) =
+ Left (InvalidBounds lo hi)
+ | not (finite m && lo < m && m < hi) =
+ Left (InvalidNullMean m lo hi)
+ | otherwise = Right Config {
cfg_bettor = b
, cfg_lam_max_pos = 0.5 / (m - lo)
, cfg_lam_max_neg = 0.5 / (hi - m)
diff --git a/lib/Numeric/Eproc/Common.hs b/lib/Numeric/Eproc/Common.hs
@@ -29,6 +29,9 @@ module Numeric.Eproc.Common (
, init_bet
, bet_lambda
, step_bet
+
+ -- * Internal: helpers
+ , finite
) where
-- | A predictable bettor.
@@ -107,6 +110,13 @@ data ConfigError =
| InvalidBaselineRate {-# UNPACK #-} !Double
deriving (Eq, Show)
+-- | True iff the argument is a finite IEEE-754 double (not NaN, not
+-- @+\/-Infinity@). Used by the @config@ smart constructors to keep
+-- the bounded-random-variable promise honest.
+finite :: Double -> Bool
+finite x = not (isNaN x) && not (isInfinite x)
+{-# INLINE finite #-}
+
-- | Per-bettor state. One constructor per 'Bettor' alternative; the
-- constructor used in any given state matches the 'Bettor' chosen
-- in the enclosing 'Config'.
diff --git a/lib/Numeric/Eproc/Paired.hs b/lib/Numeric/Eproc/Paired.hs
@@ -90,8 +90,8 @@ newtype State = State Bounded.State
-- mean @0@.
--
-- Returns 'Left' with a 'ConfigError' on inputs that would leave
--- the mathematical regime: @lo >= hi@ or @alpha@ outside
--- @(0, 1)@.
+-- the mathematical regime: any of @lo@, @hi@, @alpha@ non-finite
+-- (NaN or infinite); @lo >= hi@; or @alpha@ outside @(0, 1)@.
--
-- >>> let Right cfg = config 0.0 1.0 1.0e-3 Newton
config
diff --git a/test/Main.hs b/test/Main.hs
@@ -368,8 +368,24 @@ config_validation_tests = testGroup "config validation" [
assertLeft (P.config 0.0 1.0 0.0 Bounded.Newton)
, testCase "Paired: lo >= hi rejected" $
assertLeft (P.config 1.0 0.0 0.01 Bounded.Newton)
+ , testCase "Bounded: infinite bounds rejected" $
+ assertLeft (Bounded.config 0.0 nInf pInf 0.01 Bounded.Newton)
+ , testCase "Bounded: NaN m rejected" $
+ assertLeft (Bounded.config nan 0.0 1.0 0.01 Bounded.Newton)
+ , testCase "Bounded: NaN alpha rejected" $
+ assertLeft (Bounded.config 0.5 0.0 1.0 nan Bounded.Newton)
+ , testCase "Bernoulli: NaN p0 rejected" $
+ assertLeft (Bern.config nan 0.01 Bern.Newton)
+ , testCase "Bernoulli: infinite alpha rejected" $
+ assertLeft (Bern.config 0.05 pInf Bern.Newton)
+ , testCase "Paired: infinite hi rejected" $
+ assertLeft (P.config 0.0 pInf 0.01 Bounded.Newton)
]
where
+ nan, pInf, nInf :: Double
+ nan = 0 / 0
+ pInf = 1 / 0
+ nInf = negate (1 / 0)
assertLeft :: Either C.ConfigError a -> Assertion
assertLeft e = case e of
Left _ -> pure ()
